xref: /openbsd/gnu/usr.bin/perl/cpan/Encode/t/fallback.t (revision d415bd75) 
1BEGIN {
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
18use strict;
19#use Test::More qw(no_plan);
20use Test::More tests => 58;
21use Encode q(:all);
22
23my $uo = '';
24my $nf  = '';
25my ($af, $aq, $ap, $ah, $ax, $uf, $uq, $up, $uh, $ux, $ac, $uc);
26for 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
33my $residue = '';
34for 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
49my $ao = $uo;
50utf8::upgrade($uo);
51
52my $ascii  = find_encoding('ascii');
53my $latin1 = find_encoding('latin1');
54my $utf8   = find_encoding('utf8');
55
56my $src = $uo;
57my $dst = $ascii->encode($src, FB_DEFAULT);
58is($dst, $af, "FB_DEFAULT ascii");
59is($src, $uo, "FB_DEFAULT residue ascii");
60
61$src = $ao;
62$dst = $utf8->decode($src, FB_DEFAULT);
63is($dst, $uf, "FB_DEFAULT utf8");
64is($src, $ao, "FB_DEFAULT residue utf8");
65
66$src = $uo;
67eval{ $dst = $ascii->encode($src, FB_CROAK) };
68like($@, qr/does not map to ascii/o, "FB_CROAK ascii");
69is($src, $uo, "FB_CROAK residue ascii");
70
71$src = $ao;
72eval{ $dst = $utf8->decode($src, FB_CROAK) };
73like($@, qr/does not map to Unicode/o, "FB_CROAK utf8");
74is($src, $ao, "FB_CROAK residue utf8");
75
76$src = $nf;
77eval{ $dst = $ascii->encode($src, FB_CROAK) };
78is($@, '', "FB_CROAK on success ascii");
79is($src, '', "FB_CROAK on success residue ascii");
80
81$src = $nf;
82eval{ $dst = $utf8->decode($src, FB_CROAK) };
83is($@, '', "FB_CROAK on success utf8");
84is($src, '', "FB_CROAK on success residue utf8");
85
86$src = $uo;
87$dst = $ascii->encode($src, FB_QUIET);
88is($dst, $aq,   "FB_QUIET ascii");
89is($src, $residue, "FB_QUIET residue ascii");
90
91$src = $ao;
92$dst = $utf8->decode($src, FB_QUIET);
93is($dst, $uq,   "FB_QUIET utf8");
94is($src, $residue, "FB_QUIET residue utf8");
95
96{
97    my $message = '';
98    local $SIG{__WARN__} = sub { $message = $_[0] };
99
100    $src = $uo;
101    $dst = $ascii->encode($src, FB_WARN);
102    is($dst, $aq,   "FB_WARN ascii");
103    is($src, $residue, "FB_WARN residue ascii");
104    like($message, qr/does not map to ascii/o, "FB_WARN message ascii");
105
106    $message = '';
107    $src = $ao;
108    $dst = $utf8->decode($src, FB_WARN);
109    is($dst, $uq,   "FB_WARN utf8");
110    is($src, $residue, "FB_WARN residue utf8");
111    like($message, qr/does not map to Unicode/o, "FB_WARN message utf8");
112
113    $message = '';
114    $src = $uo;
115    $dst = $ascii->encode($src, WARN_ON_ERR);
116    is($dst, $af, "WARN_ON_ERR ascii");
117    is($src, '',  "WARN_ON_ERR residue ascii");
118    like($message, qr/does not map to ascii/o, "WARN_ON_ERR message ascii");
119
120    $message = '';
121    $src = $ao;
122    $dst = $utf8->decode($src, WARN_ON_ERR);
123    is($dst, $uf, "WARN_ON_ERR utf8");
124    is($src, '',  "WARN_ON_ERR residue utf8");
125    like($message, qr/does not map to Unicode/o, "WARN_ON_ERR message ascii");
126}
127
128$src = $uo;
129$dst = $ascii->encode($src, FB_PERLQQ);
130is($dst, $ap, "FB_PERLQQ encode");
131is($src, $uo, "FB_PERLQQ residue encode");
132
133$src = $ao;
134$dst = $ascii->decode($src, FB_PERLQQ);
135is($dst, $up, "FB_PERLQQ decode");
136is($src, $ao, "FB_PERLQQ residue decode");
137
138$src = $uo;
139$dst = $ascii->encode($src, FB_HTMLCREF);
140is($dst, $ah, "FB_HTMLCREF encode");
141is($src, $uo, "FB_HTMLCREF residue encode");
142
143$src = $ao;
144$dst = $ascii->decode($src, FB_HTMLCREF);
145is($dst, $uh, "FB_HTMLCREF decode");
146is($src, $ao, "FB_HTMLCREF residue decode");
147
148$src = $uo;
149$dst = $ascii->encode($src, FB_XMLCREF);
150is($dst, $ax, "FB_XMLCREF encode");
151is($src, $uo, "FB_XMLCREF residue encode");
152
153$src = $ao;
154$dst = $ascii->decode($src, FB_XMLCREF);
155is($dst, $ux, "FB_XMLCREF decode");
156is($src, $ao, "FB_XMLCREF residue decode");
157
158$src = $uo;
159$dst = $ascii->encode($src, sub{ sprintf "<U+%04X>", shift });
160is($dst, $ac, "coderef encode");
161is($src, $uo, "coderef residue encode");
162
163$src = $ao;
164$dst = $ascii->decode($src, sub{ sprintf "[%02X]", shift });
165is($dst, $uc, "coderef decode");
166is($src, $ao, "coderef residue decode");
167
168$src = "\x{3000}";
169$dst = $ascii->encode($src, sub{ $_[0] });
170is $dst, 0x3000."", q{$ascii->encode($src, sub{ $_[0] } )};
171$dst = encode("ascii", "\x{3000}", sub{ $_[0] });
172is $dst, 0x3000."", q{encode("ascii", "\x{3000}", sub{ $_[0] })};
173
174$src = pack "C*", 0xFF;
175$dst = $ascii->decode($src, sub{ $_[0] });
176is $dst, 0xFF."", q{$ascii->encode($src, sub{ $_[0] } )};
177$dst = decode("ascii", (pack "C*", 0xFF), sub{ $_[0] });
178is $dst, 0xFF."", q{decode("ascii", (pack "C*", 0xFF), sub{ $_[0] })};
179
180
181$src = pack "C*", 0x80;
182$dst = $utf8->decode($src, sub{ $_[0] });
183is $dst, 0x80."", q{$utf8->encode($src, sub{ $_[0] } )};
184$dst = decode("utf8", $src, sub{ $_[0] });
185is $dst, 0x80."", q{decode("utf8", (pack "C*", 0x80), sub{ $_[0] })};
186
187$src = "\x{3000}";
188$dst = $latin1->encode($src, sub { "\N{U+FF}" });
189is $dst, "\x{ff}", q{$latin1->encode($src, sub { "\N{U+FF}" })};
190$dst = encode("latin1", $src, sub { "\N{U+FF}" });
191is $dst, "\x{ff}", q{encode("latin1", $src, sub { "\N{U+FF}" })};
192
193$src = "\x{3000}";
194$dst = $latin1->encode($src, sub { utf8::upgrade(my $r = "\x{ff}"); $r });
195is $dst, "\x{ff}", q{$latin1->encode($src, sub { utf8::upgrade(my $r = "\x{ff}"); $r })};
196$dst = encode("latin1", $src, sub { utf8::upgrade(my $r = "\x{ff}"); $r });
197is $dst, "\x{ff}", q{encode("latin1", $src, sub { utf8::upgrade(my $r = "\x{ff}"); $r })};
198
199$src = "\x{ff}";
200$dst = $utf8->decode($src, sub { chr($_[0]) });
201is $dst, "\x{ff}", q{$utf8->decode($src, sub { chr($_[0]) })};
202$dst = decode("utf8", $src, sub { chr($_[0]) });
203is $dst, "\x{ff}", q{decode("utf8", $src, sub { chr($_[0]) })};
204
205{
206    use charnames ':full';
207    $src = "\x{ff}";
208    $dst = $utf8->decode($src, sub { utf8::downgrade(my $r = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"); $r });
209    is $dst, "\N{LATIN SMALL LETTER Y WITH DIAERESIS}", q{$utf8->decode($src, sub { utf8::downgrade(my $r = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"); $r })};
210    $dst = decode("utf8", $src, sub { utf8::downgrade(my $r = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"); $r });
211    is $dst, "\N{LATIN SMALL LETTER Y WITH DIAERESIS}", q{decode("utf8", $src, sub { utf8::downgrade(my $r = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"); $r })};
212}
213