This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
22f392ac788be0d223af6e2c308fe6ec1ca14eb4
[perl5.git] / t / io / utf8.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     unless (find PerlIO::Layer 'perlio') {
7         print "1..0 # Skip: not perlio\n";
8         exit 0;
9     }
10 }
11
12 no utf8; # needed for use utf8 not griping about the raw octets
13
14 require "./test.pl";
15
16 plan(tests => 55);
17
18 $| = 1;
19
20 open(F,"+>:utf8",'a');
21 print F chr(0x100).'£';
22 cmp_ok( tell(F), '==', 4, tell(F) );
23 print F "\n";
24 cmp_ok( tell(F), '>=', 5, tell(F) );
25 seek(F,0,0);
26 is( getc(F), chr(0x100) );
27 is( getc(F), "£" );
28 is( getc(F), "\n" );
29 seek(F,0,0);
30 binmode(F,":bytes");
31 my $chr = chr(0xc4);
32 if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
33 is( getc(F), $chr );
34 $chr = chr(0x80);
35 if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
36 is( getc(F), $chr );
37 $chr = chr(0xc2);
38 if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
39 is( getc(F), $chr );
40 $chr = chr(0xa3);
41 if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
42 is( getc(F), $chr );
43 is( getc(F), "\n" );
44 seek(F,0,0);
45 binmode(F,":utf8");
46 is( scalar(<F>), "\x{100}£\n" );
47 seek(F,0,0);
48 $buf = chr(0x200);
49 $count = read(F,$buf,2,1);
50 cmp_ok( $count, '==', 2 );
51 is( $buf, "\x{200}\x{100}£" );
52 close(F);
53
54 {
55     $a = chr(300); # This *is* UTF-encoded
56     $b = chr(130); # This is not.
57
58     open F, ">:utf8", 'a' or die $!;
59     print F $a,"\n";
60     close F;
61
62     open F, "<:utf8", 'a' or die $!;
63     $x = <F>;
64     chomp($x);
65     is( $x, chr(300) );
66
67     open F, "a" or die $!; # Not UTF
68     binmode(F, ":bytes");
69     $x = <F>;
70     chomp($x);
71     $chr = chr(196).chr(172);
72     if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC
73     is( $x, $chr );
74     close F;
75
76     open F, ">:utf8", 'a' or die $!;
77     binmode(F);  # we write a "\n" and then tell() - avoid CRLF issues.
78     binmode(F,":utf8"); # turn UTF-8-ness back on
79     print F $a;
80     my $y;
81     { my $x = tell(F);
82       { use bytes; $y = length($a);}
83       cmp_ok( $x, '==', $y );
84   }
85
86     { # Check byte length of $b
87         use bytes; my $y = length($b);
88         cmp_ok( $y, '==', 1 );
89     }
90
91     print F $b,"\n"; # Don't upgrades $b
92
93     { # Check byte length of $b
94         use bytes; my $y = length($b);
95         cmp_ok( $y, '==', 1 );
96     }
97
98     {
99         my $x = tell(F);
100         { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
101         cmp_ok( $x, '==', $y );
102     }
103
104     close F;
105
106     open F, "a" or die $!; # Not UTF
107     binmode(F, ":bytes");
108     $x = <F>;
109     chomp($x);
110     $chr = v196.172.194.130;
111     if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
112     is( $x, $chr, sprintf('(%vd)', $x) );
113
114     open F, "<:utf8", "a" or die $!;
115     $x = <F>;
116     chomp($x);
117     close F;
118     is( $x, chr(300).chr(130), sprintf('(%vd)', $x) );
119
120     open F, ">", "a" or die $!;
121     binmode(F, ":bytes:");
122
123     # Now let's make it suffer.
124     my $w;
125     {
126         use warnings 'utf8';
127         local $SIG{__WARN__} = sub { $w = $_[0] };
128         print F $a;
129         ok( (!$@));
130         like($w, qr/Wide character in print/i );
131     }
132 }
133
134 # Hm. Time to get more evil.
135 open F, ">:utf8", "a" or die $!;
136 print F $a;
137 binmode(F, ":bytes");
138 print F chr(130)."\n";
139 close F;
140
141 open F, "<", "a" or die $!;
142 binmode(F, ":bytes");
143 $x = <F>; chomp $x;
144 $chr = v196.172.130;
145 if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
146 is( $x, $chr );
147
148 # Right.
149 open F, ">:utf8", "a" or die $!;
150 print F $a;
151 close F;
152 open F, ">>", "a" or die $!;
153 binmode(F, ":bytes");
154 print F chr(130)."\n";
155 close F;
156
157 open F, "<", "a" or die $!;
158 binmode(F, ":bytes");
159 $x = <F>; chomp $x;
160 SKIP: {
161     skip("Defaulting to UTF-8 output means that we can't generate a mangled file")
162         if $UTF8_OUTPUT;
163     is( $x, $chr );
164 }
165
166 # Now we have a deformed file.
167
168 SKIP: {
169     if (ord('A') == 193) {
170         skip("EBCDIC doesn't complain", 2);
171     } else {
172         my @warnings;
173         open F, "<:utf8", "a" or die $!;
174         $x = <F>; chomp $x;
175         local $SIG{__WARN__} = sub { push @warnings, $_[0]; };
176         eval { sprintf "%vd\n", $x };
177         is (scalar @warnings, 1);
178         like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/);
179     }
180 }
181
182 close F;
183 unlink('a');
184
185 open F, ">:utf8", "a";
186 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
187 unshift @a, chr(0); # ... and a null byte in front just for fun
188 print F @a;
189 close F;
190
191 my $c;
192
193 # read() should work on characters, not bytes
194 open F, "<:utf8", "a";
195 $a = 0;
196 my $failed;
197 for (@a) {
198     unless (($c = read(F, $b, 1) == 1)  &&
199             length($b)           == 1  &&
200             ord($b)              == ord($_) &&
201             tell(F)              == ($a += bytes::length($b))) {
202         print '# ord($_)           == ', ord($_), "\n";
203         print '# ord($b)           == ', ord($b), "\n";
204         print '# length($b)        == ', length($b), "\n";
205         print '# bytes::length($b) == ', bytes::length($b), "\n";
206         print '# tell(F)           == ', tell(F), "\n";
207         print '# $a                == ', $a, "\n";
208         print '# $c                == ', $c, "\n";
209         $failed++;
210         last;
211     }
212 }
213 close F;
214 is($failed, undef);
215
216 {
217     # Check that warnings are on on I/O, and that they can be muffled.
218
219     local $SIG{__WARN__} = sub { $@ = shift };
220
221     undef $@;
222     open F, ">a";
223     binmode(F, ":bytes");
224     print F chr(0x100);
225     close(F);
226
227     like( $@, 'Wide character in print' );
228
229     undef $@;
230     open F, ">:utf8", "a";
231     print F chr(0x100);
232     close(F);
233
234     isnt( defined $@ );
235
236     undef $@;
237     open F, ">a";
238     binmode(F, ":utf8");
239     print F chr(0x100);
240     close(F);
241
242     isnt( defined $@ );
243
244     no warnings 'utf8';
245
246     undef $@;
247     open F, ">a";
248     print F chr(0x100);
249     close(F);
250
251     isnt( defined $@ );
252
253     use warnings 'utf8';
254
255     undef $@;
256     open F, ">a";
257     binmode(F, ":bytes");
258     print F chr(0x100);
259     close(F);
260
261     like( $@, 'Wide character in print' );
262 }
263
264 {
265     open F, ">:bytes","a"; print F "\xde"; close F;
266
267     open F, "<:bytes", "a";
268     my $b = chr 0x100;
269     $b .= <F>;
270     is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" );
271     close F;
272 }
273
274 {
275     open F, ">:utf8","a"; print F chr 0x100; close F;
276
277     open F, "<:utf8", "a";
278     my $b = "\xde";
279     $b .= <F>;
280     is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" );
281     close F;
282 }
283
284 {
285     my @a = ( [ 0x007F, "bytes" ],
286               [ 0x0080, "bytes" ],
287               [ 0x0080, "utf8"  ],
288               [ 0x0100, "utf8"  ] );
289     my $t = 34;
290     for my $u (@a) {
291         for my $v (@a) {
292             # print "# @$u - @$v\n";
293             open F, ">a";
294             binmode(F, ":" . $u->[1]);
295             print F chr($u->[0]);
296             close F;
297
298             open F, "<a";
299             binmode(F, ":" . $u->[1]);
300
301             my $s = chr($v->[0]);
302             utf8::upgrade($s) if $v->[1] eq "utf8";
303
304             $s .= <F>;
305             is( $s, chr($v->[0]) . chr($u->[0]), 'rcatline utf8' );
306             close F;
307             $t++;
308         }
309     }
310     # last test here 49
311 }
312
313 {
314     # [perl #23428] Somethings rotten in unicode semantics
315     open F, ">a";
316     binmode F, ":utf8";
317     syswrite(F, $a = chr(0x100));
318     close F;
319     is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' );
320     like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' );
321 }
322
323 # sysread() and syswrite() tested in lib/open.t since Fcntl is used
324
325 {
326     # <FH> on a :utf8 stream should complain immediately with -w
327     # if it finds bad UTF-8 (:encoding(utf8) works this way)
328     use warnings 'utf8';
329     undef $@;
330     local $SIG{__WARN__} = sub { $@ = shift };
331     open F, ">a";
332     binmode F;
333     my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6));
334     if (ord('A') == 193)        # EBCDIC
335     { ($chrE4, $chrF6) = (chr(0x43), chr(0xEC)); }
336     print F "foo", $chrE4, "\n";
337     print F "foo", $chrF6, "\n";
338     close F;
339     open F, "<:utf8", "a";
340     undef $@;
341     my $line = <F>;
342     my ($chrE4, $chrF6) = ("E4", "F6");
343     if (ord('A') == 193) { ($chrE4, $chrF6) = ("43", "EC"); } # EBCDIC
344     like( $@, qr/utf8 "\\x$chrE4" does not map to Unicode .+ <F> line 1/,
345           "<:utf8 readline must warn about bad utf8");
346     undef $@;
347     $line .= <F>;
348     like( $@, qr/utf8 "\\x$chrF6" does not map to Unicode .+ <F> line 2/,
349           "<:utf8 rcatline must warn about bad utf8");
350     close F;
351 }
352
353 END {
354     1 while unlink "a";
355     1 while unlink "b";
356 }