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