Move Encode from ext/ to cpan/
[perl.git] / cpan / Encode / t / fallback.t
1 BEGIN {
2     if ($ENV{'PERL_CORE'}){
3         chdir 't';
4         unshift @INC, '../lib';
5     }
6     require Config; import Config;
7     if ($Config{'extensions'} !~ /\bEncode\b/) {
8       print "1..0 # Skip: Encode was not built\n";
9       exit 0;
10     }
11     if (ord("A") == 193) {
12     print "1..0 # Skip: EBCDIC\n";
13     exit 0;
14     }
15     $| = 1;
16 }
17
18 use strict;
19 #use Test::More qw(no_plan);
20 use Test::More tests => 48;
21 use Encode q(:all);
22
23 my $uo = '';
24 my $nf  = '';
25 my ($af, $aq, $ap, $ah, $ax, $uf, $uq, $up, $uh, $ux, $ac, $uc);
26 for my $i (0x20..0x7e){
27     $uo .= chr($i);
28 }
29 $af = $aq = $ap = $ah = $ax = $ac =
30 $uf = $uq = $up = $uh = $ux = $uc =
31 $nf = $uo;
32
33 my $residue = '';
34 for my $i (0x80..0xff){
35     $uo   .= chr($i);
36     $residue    .= chr($i);
37     $af .= '?';
38     $uf .= "\x{FFFD}";
39     $ap .= sprintf("\\x{%04x}", $i);
40     $up .= sprintf("\\x%02X", $i);
41     $ah .= sprintf("&#%d;", $i);
42     $uh .= sprintf("\\x%02X", $i);
43     $ax .= sprintf("&#x%x;", $i);
44     $ux .= sprintf("\\x%02X", $i);
45     $ac .= sprintf("<U+%04X>", $i);
46     $uc .= sprintf("[%02X]", $i);
47 }
48
49 my $ao = $uo;
50 utf8::upgrade($uo);
51
52 my $ascii  = find_encoding('ascii');
53 my $utf8   = find_encoding('utf8');
54
55 my $src = $uo;
56 my $dst = $ascii->encode($src, FB_DEFAULT);
57 is($dst, $af, "FB_DEFAULT ascii");
58 is($src, $uo, "FB_DEFAULT residue ascii");
59
60 $src = $ao;
61 $dst = $utf8->decode($src, FB_DEFAULT);
62 is($dst, $uf, "FB_DEFAULT utf8");
63 is($src, $ao, "FB_DEFAULT residue utf8");
64
65 $src = $uo;
66 eval{ $dst = $ascii->encode($src, FB_CROAK) };
67 like($@, qr/does not map to ascii/o, "FB_CROAK ascii");
68 is($src, $uo, "FB_CROAK residue ascii");
69
70 $src = $ao;
71 eval{ $dst = $utf8->decode($src, FB_CROAK) };
72 like($@, qr/does not map to Unicode/o, "FB_CROAK utf8");
73 is($src, $ao, "FB_CROAK residue utf8");
74
75 $src = $nf;
76 eval{ $dst = $ascii->encode($src, FB_CROAK) };
77 is($@, '', "FB_CROAK on success ascii");
78 is($src, '', "FB_CROAK on success residue ascii");
79
80 $src = $nf;
81 eval{ $dst = $utf8->decode($src, FB_CROAK) };
82 is($@, '', "FB_CROAK on success utf8");
83 is($src, '', "FB_CROAK on success residue utf8");
84
85 $src = $uo;
86 $dst = $ascii->encode($src, FB_QUIET);
87 is($dst, $aq,   "FB_QUIET ascii");
88 is($src, $residue, "FB_QUIET residue ascii");
89
90 $src = $ao;
91 $dst = $utf8->decode($src, FB_QUIET);
92 is($dst, $uq,   "FB_QUIET utf8");
93 is($src, $residue, "FB_QUIET residue utf8");
94
95 {
96     my $message = '';
97     local $SIG{__WARN__} = sub { $message = $_[0] };
98
99     $src = $uo;
100     $dst = $ascii->encode($src, FB_WARN);
101     is($dst, $aq,   "FB_WARN ascii");
102     is($src, $residue, "FB_WARN residue ascii");
103     like($message, qr/does not map to ascii/o, "FB_WARN message ascii");
104
105     $message = '';
106     $src = $ao;
107     $dst = $utf8->decode($src, FB_WARN);
108     is($dst, $uq,   "FB_WARN utf8");
109     is($src, $residue, "FB_WARN residue utf8");
110     like($message, qr/does not map to Unicode/o, "FB_WARN message utf8");
111
112     $message = '';
113     $src = $uo;
114     $dst = $ascii->encode($src, WARN_ON_ERR);
115     is($dst, $af, "WARN_ON_ERR ascii");
116     is($src, '',  "WARN_ON_ERR residue ascii");
117     like($message, qr/does not map to ascii/o, "WARN_ON_ERR message ascii");
118
119     $message = '';
120     $src = $ao;
121     $dst = $utf8->decode($src, WARN_ON_ERR);
122     is($dst, $uf, "WARN_ON_ERR utf8");
123     is($src, '',  "WARN_ON_ERR residue utf8");
124     like($message, qr/does not map to Unicode/o, "WARN_ON_ERR message ascii");
125 }
126
127 $src = $uo;
128 $dst = $ascii->encode($src, FB_PERLQQ);
129 is($dst, $ap, "FB_PERLQQ encode");
130 is($src, $uo, "FB_PERLQQ residue encode");
131
132 $src = $ao;
133 $dst = $ascii->decode($src, FB_PERLQQ);
134 is($dst, $up, "FB_PERLQQ decode");
135 is($src, $ao, "FB_PERLQQ residue decode");
136
137 $src = $uo;
138 $dst = $ascii->encode($src, FB_HTMLCREF);
139 is($dst, $ah, "FB_HTMLCREF encode");
140 is($src, $uo, "FB_HTMLCREF residue encode");
141
142 $src = $ao;
143 $dst = $ascii->decode($src, FB_HTMLCREF);
144 is($dst, $uh, "FB_HTMLCREF decode");
145 is($src, $ao, "FB_HTMLCREF residue decode");
146
147 $src = $uo;
148 $dst = $ascii->encode($src, FB_XMLCREF);
149 is($dst, $ax, "FB_XMLCREF encode");
150 is($src, $uo, "FB_XMLCREF residue encode");
151
152 $src = $ao;
153 $dst = $ascii->decode($src, FB_XMLCREF);
154 is($dst, $ux, "FB_XMLCREF decode");
155 is($src, $ao, "FB_XMLCREF residue decode");
156
157 $src = $uo;
158 $dst = $ascii->encode($src, sub{ sprintf "<U+%04X>", shift });
159 is($dst, $ac, "coderef encode");
160 is($src, $uo, "coderef residue encode");
161
162 $src = $ao;
163 $dst = $ascii->decode($src, sub{ sprintf "[%02X]", shift });
164 is($dst, $uc, "coderef decode");
165 is($src, $ao, "coderef residue decode");
166
167 $src = "\x{3000}";
168 $dst = $ascii->encode($src, sub{ $_[0] });
169 is $dst, 0x3000."", qq{$ascii->encode(\$src, sub{ \$_[0] } )};
170 $dst = encode("ascii", "\x{3000}", sub{ $_[0] });
171 is $dst, 0x3000."", qq{encode("ascii", "\\x{3000}", sub{ \$_[0] })};
172
173 $src = pack "C*", 0xFF;
174 $dst = $ascii->decode($src, sub{ $_[0] });
175 is $dst, 0xFF."", qq{$ascii->encode(\$src, sub{ \$_[0] } )};
176 $dst = decode("ascii", (pack "C*", 0xFF), sub{ $_[0] });
177 is $dst, 0xFF."", qq{decode("ascii", (pack "C*", 0xFF), sub{ \$_[0] })};