X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fio%2Futf8.t;h=f77aa3fdc9b0d5fa61cde3c1ab0b27c7bc4f63c0;hb=2d862febb32638bf1f7663134644cf7e37f284ad;hp=71c0d06797fdf5666846ecf4731ff75cc84818b5;hpb=34fce102e06d66916d6dc1e5501e4ed517024fcf;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/io/utf8.t b/t/io/utf8.t index 71c0d06..f77aa3f 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -11,138 +11,125 @@ BEGIN { no utf8; # needed for use utf8 not griping about the raw octets +require "./test.pl"; + +plan(tests => 49); + $| = 1; -print "1..29\n"; open(F,"+>:utf8",'a'); print F chr(0x100).'£'; -print '#'.tell(F)."\n"; -print "not " unless tell(F) == 4; -print "ok 1\n"; +ok( tell(F) == 4, tell(F) ); print F "\n"; -print '#'.tell(F)."\n"; -print "not " unless tell(F) >= 5; -print "ok 2\n"; +ok( tell(F) >= 5, tell(F) ); seek(F,0,0); -print "not " unless getc(F) eq chr(0x100); -print "ok 3\n"; -print "not " unless getc(F) eq "£"; -print "ok 4\n"; -print "not " unless getc(F) eq "\n"; -print "ok 5\n"; +ok( getc(F) eq chr(0x100) ); +ok( getc(F) eq "£" ); +ok( getc(F) eq "\n" ); seek(F,0,0); binmode(F,":bytes"); my $chr = chr(0xc4); if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC -print "not " unless getc(F) eq $chr; -print "ok 6\n"; +ok( getc(F) eq $chr ); $chr = chr(0x80); if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC -print "not " unless getc(F) eq $chr; -print "ok 7\n"; +ok( getc(F) eq $chr ); $chr = chr(0xc2); if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC -print "not " unless getc(F) eq $chr; -print "ok 8\n"; +ok( getc(F) eq $chr ); $chr = chr(0xa3); if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC -print "not " unless getc(F) eq $chr; -print "ok 9\n"; -print "not " unless getc(F) eq "\n"; -print "ok 10\n"; +ok( getc(F) eq $chr ); +ok( getc(F) eq "\n" ); seek(F,0,0); binmode(F,":utf8"); -print "not " unless scalar() eq "\x{100}£\n"; -print "ok 11\n"; +ok( scalar() eq "\x{100}£\n" ); seek(F,0,0); $buf = chr(0x200); $count = read(F,$buf,2,1); -print "not " unless $count == 2; -print "ok 12\n"; -print "not " unless $buf eq "\x{200}\x{100}£"; -print "ok 13\n"; +ok( $count == 2 ); +ok( $buf eq "\x{200}\x{100}£" ); close(F); { -$a = chr(300); # This *is* UTF-encoded -$b = chr(130); # This is not. - -open F, ">:utf8", 'a' or die $!; -print F $a,"\n"; -close F; - -open F, "<:utf8", 'a' or die $!; -$x = ; -chomp($x); -print "not " unless $x eq chr(300); -print "ok 14\n"; - -open F, "a" or die $!; # Not UTF -$x = ; -chomp($x); -$chr = chr(196).chr(172); -if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC -print "not " unless $x eq $chr; -print "ok 15\n"; -close F; - -open F, ">:utf8", 'a' or die $!; -binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. -print F $a; -my $y; -{ my $x = tell(F); - { use bytes; $y = length($a);} - print "not " unless $x == $y; - print "ok 16\n"; -} - -{ # Check byte length of $b -use bytes; my $y = length($b); -print "not " unless $y == 1; -print "ok 17\n"; -} + $a = chr(300); # This *is* UTF-encoded + $b = chr(130); # This is not. + + open F, ">:utf8", 'a' or die $!; + print F $a,"\n"; + close F; + + open F, "<:utf8", 'a' or die $!; + $x = ; + chomp($x); + ok( $x eq chr(300) ); + + open F, "a" or die $!; # Not UTF + binmode(F, ":bytes"); + $x = ; + chomp($x); + $chr = chr(196).chr(172); + if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC + ok( $x eq $chr ); + close F; + + open F, ">:utf8", 'a' or die $!; + binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. + binmode(F,":utf8"); # turn UTF-8-ness back on + print F $a; + my $y; + { my $x = tell(F); + { use bytes; $y = length($a);} + ok( $x == $y ); + } + + { # Check byte length of $b + use bytes; my $y = length($b); + ok( $y == 1 ); + } -print F $b,"\n"; # Don't upgrades $b + print F $b,"\n"; # Don't upgrades $b -{ # Check byte length of $b -use bytes; my $y = length($b); -print "not ($y) " unless $y == 1; -print "ok 18\n"; -} + { # Check byte length of $b + use bytes; my $y = length($b); + ok( $y == 1 ); + } -{ my $x = tell(F); - { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII - print "not ($x,$y) " unless $x == $y; - print "ok 19\n"; -} + { + my $x = tell(F); + { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII + ok( $x == $y ); + } -close F; + close F; -open F, "a" or die $!; # Not UTF -$x = ; -chomp($x); -$chr = v196.172.194.130; -if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC -printf "not (%vd) ", $x unless $x eq $chr; -print "ok 20\n"; + open F, "a" or die $!; # Not UTF + binmode(F, ":bytes"); + $x = ; + chomp($x); + $chr = v196.172.194.130; + if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC + ok( $x eq $chr, sprintf('(%vd)', $x) ); -open F, "<:utf8", "a" or die $!; -$x = ; -chomp($x); -close F; -printf "not (%vd) ", $x unless $x eq chr(300).chr(130); -print "ok 21\n"; + open F, "<:utf8", "a" or die $!; + $x = ; + chomp($x); + close F; + ok( $x eq chr(300).chr(130), sprintf('(%vd)', $x) ); + + open F, ">", "a" or die $!; + if (${^OPEN} =~ /:utf8/) { + binmode(F, ":bytes:"); + } -# Now let's make it suffer. -open F, ">", "a" or die $!; -my $w; -{ - use warnings 'utf8'; - local $SIG{__WARN__} = sub { $w = $_[0] }; - print F $a; -} -print "not " if ($@ || $w !~ /Wide character in print/i); -print "ok 22\n"; + # Now let's make it suffer. + my $w; + { + use warnings 'utf8'; + local $SIG{__WARN__} = sub { $w = $_[0] }; + print F $a; + ok( !($@ || $w !~ /Wide character in print/i) ); + } } # Hm. Time to get more evil. @@ -153,11 +140,11 @@ print F chr(130)."\n"; close F; open F, "<", "a" or die $!; +binmode(F, ":bytes"); $x = ; chomp $x; $chr = v196.172.130; if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC -print "not " unless $x eq $chr; -print "ok 23\n"; +ok( $x eq $chr ); # Right. open F, ">:utf8", "a" or die $!; @@ -169,24 +156,25 @@ close F; open F, "<", "a" or die $!; $x = ; chomp $x; -print "not " unless $x eq $chr; -print "ok 24\n"; +ok( $x eq $chr ); # Now we have a deformed file. -if (ord('A') == 193) { - print "ok 25 # Skip: EBCDIC\n"; # EBCDIC doesn't complain -} else { - open F, "<:utf8", "a" or die $!; - $x = ; chomp $x; - local $SIG{__WARN__} = sub { print "ok 25\n" }; - eval { sprintf "%vd\n", $x }; +SKIP: { + if (ord('A') == 193) { + skip( "EBCDIC doesn't complain" ); + } else { + open F, "<:utf8", "a" or die $!; + $x = ; chomp $x; + local $SIG{__WARN__} = sub { ok( 1 ) }; + eval { sprintf "%vd\n", $x }; + } } close F; unlink('a'); -open F, ">a"; +open F, ">:utf8", "a"; @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 unshift @a, chr(0); # ... and a null byte in front just for fun print F @a; @@ -214,77 +202,109 @@ for (@a) { } } close F; -print "ok 26\n"; +ok( 1 ); -# Set to 0 to fail on Linux as of 13096. -my $skiptell = 1; +{ + # Check that warnings are on on I/O, and that they can be muffled. -# sysread() should work on characters, not bytes -open F, "<:utf8", "a"; -$a = 0; -for (@a) { - unless (($c = sysread(F, $b, 1)) == 1 && - length($b) == 1 && - ord($b) == ord($_) && - ($skiptell || tell(F) == ($a += bytes::length($b))) - ) { - print '# ord($_) == ', ord($_), "\n"; - print '# ord($b) == ', ord($b), "\n"; - print '# length($b) == ', length($b), "\n"; - print '# bytes::length($b) == ', bytes::length($b), "\n"; - print '# tell(F) == ', tell(F), "\n"; - print '# $a == ', $a, "\n"; - print '# $c == ', $c, "\n"; - print "not "; - last; - } + local $SIG{__WARN__} = sub { $@ = shift }; + + undef $@; + open F, ">a"; + binmode(F, ":bytes"); + print F chr(0x100); + close(F); + + like( $@, 'Wide character in print' ); + + undef $@; + open F, ">:utf8", "a"; + print F chr(0x100); + close(F); + + isnt( defined $@ ); + + undef $@; + open F, ">a"; + binmode(F, ":utf8"); + print F chr(0x100); + close(F); + + isnt( defined $@ ); + + no warnings 'utf8'; + + undef $@; + open F, ">a"; + print F chr(0x100); + close(F); + + isnt( defined $@ ); + + use warnings 'utf8'; + + undef $@; + open F, ">a"; + binmode(F, ":bytes"); + print F chr(0x100); + close(F); + + like( $@, 'Wide character in print' ); } -close F; -print "ok 27\n"; -# syswrite() on should work on characters, not bytes -open G, ">:utf8", "b"; -$a = 0; -for (@a) { - unless (($c = syswrite(G, $_, 1)) == 1 && - ($skiptell || tell(G) == ($a += bytes::length($_))) - ) { - print '# ord($_) == ', ord($_), "\n"; - print '# bytes::length($_) == ', bytes::length($_), "\n"; - print '# tell(G) == ', tell(G), "\n"; - print '# $a == ', $a, "\n"; - print '# $c == ', $c, "\n"; - print "not "; - last; - } +{ + open F, ">:bytes","a"; print F "\xde"; close F; + + open F, "<:bytes", "a"; + my $b = chr 0x100; + $b .= ; + ok( $b eq chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" ); + close F; } -close G; -print "ok 28\n"; -# did syswrite() get it right? -open G, "<:utf8", "b"; -$a = 0; -for (@a) { - unless (($c = sysread(G, $b, 1)) == 1 && - length($b) == 1 && - ord($b) == ord($_) && - ($skiptell || tell(G) == ($a += bytes::length($_))) - ) { - print '# ord($_) == ', ord($_), "\n"; - print '# ord($b) == ', ord($b), "\n"; - print '# length($b) == ', length($b), "\n"; - print '# bytes::length($b) == ', bytes::length($b), "\n"; - print '# tell(G) == ', tell(G), "\n"; - print '# $a == ', $a, "\n"; - print '# $c == ', $c, "\n"; - print "not "; - last; +{ + open F, ">:utf8","a"; print F chr 0x100; close F; + + open F, "<:utf8", "a"; + my $b = "\xde"; + $b .= ; + ok( $b eq chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" ); + close F; +} + +{ + my @a = ( [ 0x007F, "bytes" ], + [ 0x0080, "bytes" ], + [ 0x0080, "utf8" ], + [ 0x0100, "utf8" ] ); + my $t = 34; + for my $u (@a) { + for my $v (@a) { + # print "# @$u - @$v\n"; + open F, ">a"; + binmode(F, ":" . $u->[1]); + print F chr($u->[0]); + close F; + + open F, "[1]); + + my $s = chr($v->[0]); + utf8::upgrade($s) if $v->[1] eq "utf8"; + + $s .= ; + ok( $s eq chr($v->[0]) . chr($u->[0]), 'rcatline utf8' ); + close F; + $t++; + } } + # last test here 49 } -close G; -print "ok 29\n"; + +# sysread() and syswrite() tested in lib/open.t since Fnctl is used END { 1 while unlink "a"; 1 while unlink "b"; } +