X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fio%2Futf8.t;h=af356fc88fc60d1ae61d799bb4cfef340dba0a97;hb=ec3f2d8be8ce8cf45558045599c51ca3f4d57e3e;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..af356fc 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -12,7 +12,7 @@ BEGIN { no utf8; # needed for use utf8 not griping about the raw octets $| = 1; -print "1..29\n"; +print "1..31\n"; open(F,"+>:utf8",'a'); print F chr(0x100).'£'; @@ -64,85 +64,92 @@ print "ok 13\n"; 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"; -} - -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"; -} - -{ 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"; -} - -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, "<:utf8", "a" or die $!; -$x = ; -chomp($x); -close F; -printf "not (%vd) ", $x unless $x eq chr(300).chr(130); -print "ok 21\n"; - -# Now let's make it suffer. -open F, ">", "a" or die $!; -my $w; -{ - use warnings 'utf8'; - local $SIG{__WARN__} = sub { $w = $_[0] }; + $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 + binmode(F, ":bytes"); + $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; -} -print "not " if ($@ || $w !~ /Wide character in print/i); -print "ok 22\n"; + 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"; + } + + 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"; + } + + { + 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"; + } + + close F; + + 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 + printf "not (%vd) ", $x unless $x eq $chr; + print "ok 20\n"; + + 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, ">", "a" or die $!; + if (${^OPEN} =~ /:utf8/) { + binmode(F, ":bytes:"); + } + + # Now let's make it suffer. + 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"; } # Hm. Time to get more evil. @@ -151,8 +158,9 @@ print F $a; binmode(F, ":bytes"); 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 @@ -186,7 +194,7 @@ if (ord('A') == 193) { 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; @@ -216,75 +224,58 @@ for (@a) { close F; print "ok 26\n"; -# 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; - } -} -close F; -print "ok 27\n"; + local $SIG{__WARN__} = sub { $@ = shift }; -# 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; - } -} -close G; -print "ok 28\n"; + undef $@; + open F, ">a"; + binmode(F, ":bytes"); + print F chr(0x100); + close(F); -# 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; - } + print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n"; + + undef $@; + open F, ">:utf8", "a"; + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 28\n" : "ok 28\n"; + + undef $@; + open F, ">a"; + binmode(F, ":utf8"); + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 29\n" : "ok 29\n"; + + no warnings 'utf8'; + + undef $@; + open F, ">a"; + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 30\n" : "ok 30\n"; + + use warnings 'utf8'; + + undef $@; + open F, ">a"; + binmode(F, ":bytes"); + print F chr(0x100); + close(F); + + print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n"; } -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"; } +