Move Encode from ext/ to cpan/
[perl.git] / cpan / Encode / t / Encode.t
1 BEGIN {
2     if ($ENV{'PERL_CORE'}){
3         chdir 't';
4         unshift @INC, '../lib';
5     }
6     if (ord("A") == 193) {
7         print "1..0 # Skip: EBCDIC\n";
8         exit 0;
9     }
10     require Config; import Config;
11     if ($Config{'extensions'} !~ /\bEncode\b/) {
12       print "1..0 # Skip: Encode was not built\n";
13       exit 0;
14     }
15 }
16 use strict;
17 use Test;
18 use Encode qw(from_to encode decode
19           encode_utf8 decode_utf8
20           find_encoding is_utf8);
21 use charnames qw(greek);
22 my @encodings = grep(/iso-?8859/,Encode::encodings());
23 my $n = 2;
24 my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
25 my @source = qw(ascii iso8859-1 cp1250);
26 my @destiny = qw(cp1047 cp37 posix-bc);
27 my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
28 plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 2;
29 my $str = join('',map(chr($_),0x20..0x7E));
30 my $cpy = $str;
31 ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
32 ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode");
33 $cpy = $str;
34 ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong");
35 ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1");
36
37 $str = join('',map(chr($_),0xa0..0xff));
38 $cpy = $str;
39 ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
40
41 my $sym = Encode->getEncoding('symbol');
42 my $uni = $sym->decode(encode(ascii => 'a'));
43 ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'");
44 $str = $sym->encode("\N{Beta}");
45 ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta");
46
47 foreach my $enc (qw(symbol dingbats ascii),@encodings)
48  {
49   my $tab = Encode->getEncoding($enc);
50   ok(1,defined($tab),"Could not load $enc");
51   $str = join('',map(chr($_),0x20..0x7E));
52   $uni = $tab->decode($str);
53   $cpy = $tab->encode($uni);
54   ok($cpy,$str,"$enc mangled translating to Unicode and back");
55  }
56
57 # On ASCII based machines see if we can map several codepoints from
58 # three distinct ASCII sets to three distinct EBCDIC coded character sets.
59 # On EBCDIC machines see if we can map from three EBCDIC sets to three
60 # distinct ASCII sets.
61
62 my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
63 if (ord('A') != 65) {
64     my @temp = @destiny;
65     @destiny = @source;
66     @source = @temp;
67     undef(@temp);
68     @expectation = (48..57, 65..90, 97..122);
69 }
70
71 foreach my $to (@destiny)
72  {
73   foreach my $from (@source)
74    {
75     my @expected = @expectation;
76     foreach my $chr (@character_set)
77      {
78       my $native_chr = $chr;
79       my $cpy = $chr;
80       my $rc = from_to($cpy,$from,$to);
81       ok(1,$rc,"Could not translate from $from to $to");
82       ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to");
83      }
84    }
85  }
86
87 # On either ASCII or EBCDIC machines ensure we can take the full one
88 # byte repetoire to EBCDIC sets and back.
89
90 my $enc_as = 'iso8859-1';
91 foreach my $enc_eb (@ebcdic_sets)
92  {
93   foreach my $ord (0..255)
94    {
95     $str = chr($ord);
96     my $rc = from_to($str,$enc_as,$enc_eb);
97     $rc += from_to($str,$enc_eb,$enc_as);
98     ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained");
99     ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back");
100    }
101  }
102
103 my $mime = find_encoding('iso-8859-2');
104 ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'");
105 my $x11 = find_encoding('iso8859-2');
106 ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'");
107 ok($mime,$x11,"iso8598-2 and iso-8859-2 not same");
108 my $spc = find_encoding('iso 8859-2');
109 ok(defined($spc),1,"Cannot find 'iso 8859-2'");
110 ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same");
111
112 for my $i (256,128,129,256)
113  {
114   my $c = chr($i);
115   my $s = "$c\n".sprintf("%02X",$i);
116   ok(utf8::valid($s),1,"concat of $i botched");
117   utf8::upgrade($s);
118   ok(utf8::valid($s),1,"concat of $i botched");
119  }
120
121 # Spot check a few points in/out of utf8
122 for my $i (ord('A'),128,256,0x20AC)
123  {
124   my $c = chr($i);
125   my $o = encode_utf8($c);
126   ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i");
127   ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i");
128   ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i");
129  }
130
131
132 # is_utf8
133
134 ok(  is_utf8("\x{100}"));
135 ok(! is_utf8("a"));
136 ok(! is_utf8(""));
137 "\x{100}" =~ /(.)/;
138 ok(  is_utf8($1)); # ID 20011127.151
139 $a = $1;
140 ok(  is_utf8($a));
141 $a = "\x{100}";
142 chop $a;
143 ok(  is_utf8($a)); # weird but true: an empty UTF-8 string
144
145 # non-string arguments
146 package Encode::Dummy;
147 use overload q("") => sub { $_[0]->[0] };
148 sub new { my $class = shift; bless [ @_  ] => $class }
149 package main;
150 ok(decode(latin1 => Encode::Dummy->new("foobar")), "foobar");
151 ok(encode(utf8   => Encode::Dummy->new("foobar")), "foobar");