X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fio%2Futf8.t;h=f77aa3fdc9b0d5fa61cde3c1ab0b27c7bc4f63c0;hb=2d862febb32638bf1f7663134644cf7e37f284ad;hp=ac5cde7a6e8d7c4df4c553eb14647cf0632d0f84;hpb=ae79846703a543a04b4fe449abfd6b1e08a9e149;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/io/utf8.t b/t/io/utf8.t index ac5cde7..f77aa3f 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -3,142 +3,133 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; - unless (exists $open::layers{'perlio'}) { + unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: not perlio\n"; exit 0; } } +no utf8; # needed for use utf8 not griping about the raw octets + +require "./test.pl"; + +plan(tests => 49); + $| = 1; -my $total_tests = 25; -if (ord('A') == 193) { $total_tests = 24; } # EBCDIC platforms do not warn on UTF-8 -print "1..$total_tests\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. + $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 $!; + 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 $!; + $x = ; + chomp($x); + ok( $x eq chr(300) ); -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"; -} + 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; -{ # Check byte length of $b -use bytes; my $y = length($b); -print "not " unless $y == 1; -print "ok 17\n"; -} + 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 ); + } -print F $b,"\n"; # Don't upgrades $b + { # Check byte length of $b + use bytes; my $y = length($b); + ok( $y == 1 ); + } -{ # Check byte length of $b -use bytes; my $y = length($b); -print "not ($y) " unless $y == 1; -print "ok 18\n"; -} + print F $b,"\n"; # Don't upgrades $b -{ 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"; -} + { # Check byte length of $b + use bytes; my $y = length($b); + ok( $y == 1 ); + } -close F; + { + my $x = tell(F); + { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII + ok( $x == $y ); + } -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"; + close F; -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; -eval {local $SIG{__WARN__} = sub { $w = $_[0] }; print F $a; }; -print "not " if ($@ || $w !~ /Wide character in print/i); -print "ok 22\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; + 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. + 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. @@ -149,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 $!; @@ -165,15 +156,155 @@ 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. -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, ">: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; +close F; + +my $c; + +# read() should work on characters, not bytes +open F, "<:utf8", "a"; +$a = 0; +for (@a) { + unless (($c = read(F, $b, 1) == 1) && + length($b) == 1 && + ord($b) == ord($_) && + 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; +ok( 1 ); + +{ + # Check that warnings are on on I/O, and that they can be muffled. + + 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' ); +} + +{ + 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; +} + +{ + 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 +} + +# sysread() and syswrite() tested in lib/open.t since Fnctl is used + +END { + 1 while unlink "a"; + 1 while unlink "b"; +} +