t/io/utf8.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     unless (find PerlIO::Layer 'perlio') {
   7         print "1..0 # Skip: not perlio\n";
   8         exit 0;
   9     }
  10 }
  11
  12 no utf8; # needed for use utf8 not griping about the raw octets
  13
  14 require "./test.pl";
  15
  16 plan(tests => 53);
  17
  18 $| = 1;
  19
  20 open(F,"+>:utf8",'a');
  21 print F chr(0x100).'£';
  22 ok( tell(F) == 4, tell(F) );
  23 print F "\n";
  24 ok( tell(F) >= 5, tell(F) );
  25 seek(F,0,0);
  26 ok( getc(F) eq chr(0x100) );
  27 ok( getc(F) eq "£" );
  28 ok( getc(F) eq "\n" );
  29 seek(F,0,0);
  30 binmode(F,":bytes");
  31 my $chr = chr(0xc4);
  32 if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
  33 ok( getc(F) eq $chr );
  34 $chr = chr(0x80);
  35 if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
  36 ok( getc(F) eq $chr );
  37 $chr = chr(0xc2);
  38 if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
  39 ok( getc(F) eq $chr );
  40 $chr = chr(0xa3);
  41 if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
  42 ok( getc(F) eq $chr );
  43 ok( getc(F) eq "\n" );
  44 seek(F,0,0);
  45 binmode(F,":utf8");
  46 ok( scalar(<F>) eq "\x{100}£\n" );
  47 seek(F,0,0);
  48 $buf = chr(0x200);
  49 $count = read(F,$buf,2,1);
  50 ok( $count == 2 );
  51 ok( $buf eq "\x{200}\x{100}£" );
  52 close(F);
  53
  54 {
  55     $a = chr(300); # This *is* UTF-encoded
  56     $b = chr(130); # This is not.
  57
  58     open F, ">:utf8", 'a' or die $!;
  59     print F $a,"\n";
  60     close F;
  61
  62     open F, "<:utf8", 'a' or die $!;
  63     $x = <F>;
  64     chomp($x);
  65     ok( $x eq chr(300) );
  66
  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
  73     ok( $x eq $chr );
  74     close F;
  75
  76     open F, ">:utf8", 'a' or die $!;
  77     binmode(F);  # we write a "\n" and then tell() - avoid CRLF issues.
  78     binmode(F,":utf8"); # turn UTF-8-ness back on
  79     print F $a;
  80     my $y;
  81     { my $x = tell(F);
  82       { use bytes; $y = length($a);}
  83       ok( $x == $y );
  84   }
  85
  86     { # Check byte length of $b
  87         use bytes; my $y = length($b);
  88         ok( $y == 1 );
  89     }
  90
  91     print F $b,"\n"; # Don't upgrades $b
  92
  93     { # Check byte length of $b
  94         use bytes; my $y = length($b);
  95         ok( $y == 1 );
  96     }
  97
  98     {
  99         my $x = tell(F);
 100         { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
 101         ok( $x == $y );
 102     }
 103
 104     close F;
 105
 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
 112     ok( $x eq $chr, sprintf('(%vd)', $x) );
 113
 114     open F, "<:utf8", "a" or die $!;
 115     $x = <F>;
 116     chomp($x);
 117     close F;
 118     ok( $x eq chr(300).chr(130), sprintf('(%vd)', $x) );
 119
 120     open F, ">", "a" or die $!;
 121     if (${^OPEN} =~ /:utf8/) {
 122         binmode(F, ":bytes:");
 123     }
 124
 125     # Now let's make it suffer.
 126     my $w;
 127     {
 128         use warnings 'utf8';
 129         local $SIG{__WARN__} = sub { $w = $_[0] };
 130         print F $a;
 131         ok( !($@ || $w !~ /Wide character in print/i) );
 132     }
 133 }
 134
 135 # Hm. Time to get more evil.
 136 open F, ">:utf8", "a" or die $!;
 137 print F $a;
 138 binmode(F, ":bytes");
 139 print F chr(130)."\n";
 140 close F;
 141
 142 open F, "<", "a" or die $!;
 143 binmode(F, ":bytes");
 144 $x = <F>; chomp $x;
 145 $chr = v196.172.130;
 146 if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
 147 ok( $x eq $chr );
 148
 149 # Right.
 150 open F, ">:utf8", "a" or die $!;
 151 print F $a;
 152 close F;
 153 open F, ">>", "a" or die $!;
 154 print F chr(130)."\n";
 155 close F;
 156
 157 open F, "<", "a" or die $!;
 158 $x = <F>; chomp $x;
 159 ok( $x eq $chr );
 160
 161 # Now we have a deformed file.
 162
 163 SKIP: {
 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     }
 172 }
 173
 174 close F;
 175 unlink('a');
 176
 177 open F, ">:utf8", "a";
 178 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
 179 unshift @a, chr(0); # ... and a null byte in front just for fun
 180 print F @a;
 181 close F;
 182
 183 my $c;
 184
 185 # read() should work on characters, not bytes
 186 open F, "<:utf8", "a";
 187 $a = 0;
 188 for (@a) {
 189     unless (($c = read(F, $b, 1) == 1)  &&
 190             length($b)           == 1  &&
 191             ord($b)              == ord($_) &&
 192             tell(F)              == ($a += bytes::length($b))) {
 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";
 200         print "not ";
 201         last;
 202     }
 203 }
 204 close F;
 205 ok( 1 );
 206
 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";
 214     binmode(F, ":bytes");
 215     print F chr(0x100);
 216     close(F);
 217
 218     like( $@, 'Wide character in print' );
 219
 220     undef $@;
 221     open F, ">:utf8", "a";
 222     print F chr(0x100);
 223     close(F);
 224
 225     isnt( defined $@ );
 226
 227     undef $@;
 228     open F, ">a";
 229     binmode(F, ":utf8");
 230     print F chr(0x100);
 231     close(F);
 232
 233     isnt( defined $@ );
 234
 235     no warnings 'utf8';
 236
 237     undef $@;
 238     open F, ">a";
 239     print F chr(0x100);
 240     close(F);
 241
 242     isnt( defined $@ );
 243
 244     use warnings 'utf8';
 245
 246     undef $@;
 247     open F, ">a";
 248     binmode(F, ":bytes");
 249     print F chr(0x100);
 250     close(F);
 251
 252     like( $@, 'Wide character in print' );
 253 }
 254
 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>;
 261     ok( $b eq chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" );
 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>;
 271     ok( $b eq chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" );
 272     close F;
 273 }
 274
 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>;
 296             ok( $s eq chr($v->[0]) . chr($u->[0]), 'rcatline utf8' );
 297             close F;
 298             $t++;
 299         }
 300     }
 301     # last test here 49
 302 }
 303
 304 {
 305     # [perl #23428] Somethings rotten in unicode semantics
 306     open F, ">a";
 307     binmode F, ":utf8";
 308     syswrite(F, $a = chr(0x100));
 309     close F;
 310     is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' );
 311     like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' );
 312 }
 313
 314 # sysread() and syswrite() tested in lib/open.t since Fcntl is used
 315
 316 {
 317     # <FH> on a :utf8 stream should complain immediately with -w
 318     # if it finds bad UTF-8 (:encoding(utf8) works this way)
 319     use warnings 'utf8';
 320     undef $@;
 321     local $SIG{__WARN__} = sub { $@ = shift };
 322     open F, ">a";
 323     binmode F;
 324     print F "foo", chr(0xE4), "\n";
 325     print F "foo", chr(0xF6), "\n";
 326     close F;
 327     open F, "<:utf8", "a";
 328     undef $@;
 329     my $line = <F>;
 330     like( $@, qr/utf8 "\\xE4" does not map to Unicode .+ <F> line 1/,
 331           "<:utf8 readline must warn about bad utf8");
 332     undef $@;
 333     $line .= <F>;
 334     like( $@, qr/utf8 "\\xF6" does not map to Unicode .+ <F> line 2/,
 335           "<:utf8 rcatline must warn about bad utf8");
 336     close F;
 337 }
 338
 339 END {
 340     1 while unlink "a";
 341     1 while unlink "b";
 342 }