X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fio%2Futf8.t;h=f77aa3fdc9b0d5fa61cde3c1ab0b27c7bc4f63c0;hb=2d862febb32638bf1f7663134644cf7e37f284ad;hp=337bd52144897ee7050fbe4e81a05dad1c651461;hpb=2b1ff55aaecd3cdbb8a785e9cee9007fdd4fc04c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/io/utf8.t b/t/io/utf8.t index 337bd52..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..31\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,18 +156,19 @@ 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; @@ -214,7 +202,7 @@ for (@a) { } } close F; -print "ok 26\n"; +ok( 1 ); { # Check that warnings are on on I/O, and that they can be muffled. @@ -223,17 +211,18 @@ print "ok 26\n"; undef $@; open F, ">a"; + binmode(F, ":bytes"); print F chr(0x100); close(F); - print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n"; + like( $@, 'Wide character in print' ); undef $@; open F, ">:utf8", "a"; print F chr(0x100); close(F); - print defined $@ ? "not ok 28\n" : "ok 28\n"; + isnt( defined $@ ); undef $@; open F, ">a"; @@ -241,7 +230,7 @@ print "ok 26\n"; print F chr(0x100); close(F); - print defined $@ ? "not ok 29\n" : "ok 29\n"; + isnt( defined $@ ); no warnings 'utf8'; @@ -250,16 +239,66 @@ print "ok 26\n"; print F chr(0x100); close(F); - print defined $@ ? "not ok 30\n" : "ok 30\n"; + isnt( defined $@ ); 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"; + 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