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 => 49);
  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 if (ord('A') == 193) {
 164     skip( "EBCDIC doesn't complain" );
 165 } else {
 166     open F, "<:utf8", "a" or die $!;
 167     $x = <F>; chomp $x;
 168     local $SIG{__WARN__} = sub { ok( 1 ) };
 169     eval { sprintf "%vd\n", $x };
 170 }
 171
 172 close F;
 173 unlink('a');
 174
 175 open F, ">:utf8", "a";
 176 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
 177 unshift @a, chr(0); # ... and a null byte in front just for fun
 178 print F @a;
 179 close F;
 180
 181 my $c;
 182
 183 # read() should work on characters, not bytes
 184 open F, "<:utf8", "a";
 185 $a = 0;
 186 for (@a) {
 187     unless (($c = read(F, $b, 1) == 1)  &&
 188             length($b)           == 1  &&
 189             ord($b)              == ord($_) &&
 190             tell(F)              == ($a += bytes::length($b))) {
 191         print '# ord($_)           == ', ord($_), "\n";
 192         print '# ord($b)           == ', ord($b), "\n";
 193         print '# length($b)        == ', length($b), "\n";
 194         print '# bytes::length($b) == ', bytes::length($b), "\n";
 195         print '# tell(F)           == ', tell(F), "\n";
 196         print '# $a                == ', $a, "\n";
 197         print '# $c                == ', $c, "\n";
 198         print "not ";
 199         last;
 200     }
 201 }
 202 close F;
 203 ok( 1 );
 204
 205 {
 206     # Check that warnings are on on I/O, and that they can be muffled.
 207
 208     local $SIG{__WARN__} = sub { $@ = shift };
 209
 210     undef $@;
 211     open F, ">a";
 212     binmode(F, ":bytes");
 213     print F chr(0x100);
 214     close(F);
 215
 216     like( $@, 'Wide character in print' );
 217
 218     undef $@;
 219     open F, ">:utf8", "a";
 220     print F chr(0x100);
 221     close(F);
 222
 223     isnt( defined $@ );
 224
 225     undef $@;
 226     open F, ">a";
 227     binmode(F, ":utf8");
 228     print F chr(0x100);
 229     close(F);
 230
 231     isnt( defined $@ );
 232
 233     no warnings 'utf8';
 234
 235     undef $@;
 236     open F, ">a";
 237     print F chr(0x100);
 238     close(F);
 239
 240     isnt( defined $@ );
 241
 242     use warnings 'utf8';
 243
 244     undef $@;
 245     open F, ">a";
 246     binmode(F, ":bytes");
 247     print F chr(0x100);
 248     close(F);
 249
 250     like( $@, 'Wide character in print' );
 251 }
 252
 253 {
 254     open F, ">:bytes","a"; print F "\xde"; close F;
 255
 256     open F, "<:bytes", "a";
 257     my $b = chr 0x100;
 258     $b .= <F>;
 259     ok( $b eq chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" );
 260     close F;
 261 }
 262
 263 {
 264     open F, ">:utf8","a"; print F chr 0x100; close F;
 265
 266     open F, "<:utf8", "a";
 267     my $b = "\xde";
 268     $b .= <F>;
 269     ok( $b eq chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" );
 270     close F;
 271 }
 272
 273 {
 274     my @a = ( [ 0x007F, "bytes" ],
 275               [ 0x0080, "bytes" ],
 276               [ 0x0080, "utf8"  ],
 277               [ 0x0100, "utf8"  ] );
 278     my $t = 34;
 279     for my $u (@a) {
 280         for my $v (@a) {
 281             # print "# @$u - @$v\n";
 282             open F, ">a";
 283             binmode(F, ":" . $u->[1]);
 284             print F chr($u->[0]);
 285             close F;
 286
 287             open F, "<a";
 288             binmode(F, ":" . $u->[1]);
 289
 290             my $s = chr($v->[0]);
 291             utf8::upgrade($s) if $v->[1] eq "utf8";
 292
 293             $s .= <F>;
 294             ok( $s eq chr($v->[0]) . chr($u->[0]), 'rcatline utf8' );
 295             close F;
 296             $t++;
 297         }
 298     }
 299     # last test here 49
 300 }
 301
 302 # sysread() and syswrite() tested in lib/open.t since Fnctl is used
 303
 304 END {
 305     1 while unlink "a";
 306     1 while unlink "b";
 307 }
 308