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