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; # so that the naked 8-bit chars won't gripe under use utf8
  13
  14 $| = 1;
  15 my $total_tests = 25;
  16 if (ord('A') == 193) { $total_tests = 24; } # EBCDIC platforms do not warn on UTF-8
  17 print "1..$total_tests\n";
  18
  19 open(F,"+>:utf8",'a');
  20 print F chr(0x100).'£';
  21 print '#'.tell(F)."\n";
  22 print "not " unless tell(F) == 4;
  23 print "ok 1\n";
  24 print F "\n";
  25 print '#'.tell(F)."\n";
  26 print "not " unless tell(F) >= 5;
  27 print "ok 2\n";
  28 seek(F,0,0);
  29 print "not " unless getc(F) eq chr(0x100);
  30 print "ok 3\n";
  31 print "not " unless getc(F) eq "£";
  32 print "ok 4\n";
  33 print "not " unless getc(F) eq "\n";
  34 print "ok 5\n";
  35 seek(F,0,0);
  36 binmode(F,":bytes");
  37 my $chr = chr(0xc4);
  38 if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
  39 print "not " unless getc(F) eq $chr;
  40 print "ok 6\n";
  41 $chr = chr(0x80);
  42 if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
  43 print "not " unless getc(F) eq $chr;
  44 print "ok 7\n";
  45 $chr = chr(0xc2);
  46 if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
  47 print "not " unless getc(F) eq $chr;
  48 print "ok 8\n";
  49 $chr = chr(0xa3);
  50 if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
  51 print "not " unless getc(F) eq $chr;
  52 print "ok 9\n";
  53 print "not " unless getc(F) eq "\n";
  54 print "ok 10\n";
  55 seek(F,0,0);
  56 binmode(F,":utf8");
  57 print "not " unless scalar(<F>) eq "\x{100}£\n";
  58 print "ok 11\n";
  59 seek(F,0,0);
  60 $buf = chr(0x200);
  61 $count = read(F,$buf,2,1);
  62 print "not " unless $count == 2;
  63 print "ok 12\n";
  64 print "not " unless $buf eq "\x{200}\x{100}£";
  65 print "ok 13\n";
  66 close(F);
  67
  68 {
  69 $a = chr(300); # This *is* UTF-encoded
  70 $b = chr(130); # This is not.
  71
  72 open F, ">:utf8", 'a' or die $!;
  73 print F $a,"\n";
  74 close F;
  75
  76 open F, "<:utf8", 'a' or die $!;
  77 $x = <F>;
  78 chomp($x);
  79 print "not " unless $x eq chr(300);
  80 print "ok 14\n";
  81
  82 open F, "a" or die $!; # Not UTF
  83 $x = <F>;
  84 chomp($x);
  85 $chr = chr(196).chr(172);
  86 if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC
  87 print "not " unless $x eq $chr;
  88 print "ok 15\n";
  89 close F;
  90
  91 open F, ">:utf8", 'a' or die $!;
  92 binmode(F);  # we write a "\n" and then tell() - avoid CRLF issues.
  93 print F $a;
  94 my $y;
  95 { my $x = tell(F);
  96     { use bytes; $y = length($a);}
  97     print "not " unless $x == $y;
  98     print "ok 16\n";
  99 }
 100
 101 { # Check byte length of $b
 102 use bytes; my $y = length($b);
 103 print "not " unless $y == 1;
 104 print "ok 17\n";
 105 }
 106
 107 print F $b,"\n"; # Don't upgrades $b
 108
 109 { # Check byte length of $b
 110 use bytes; my $y = length($b);
 111 print "not ($y) " unless $y == 1;
 112 print "ok 18\n";
 113 }
 114
 115 { my $x = tell(F);
 116     { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
 117     print "not ($x,$y) " unless $x == $y;
 118     print "ok 19\n";
 119 }
 120
 121 close F;
 122
 123 open F, "a" or die $!; # Not UTF
 124 $x = <F>;
 125 chomp($x);
 126 $chr = v196.172.194.130;
 127 if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
 128 printf "not (%vd) ", $x unless $x eq $chr;
 129 print "ok 20\n";
 130
 131 open F, "<:utf8", "a" or die $!;
 132 $x = <F>;
 133 chomp($x);
 134 close F;
 135 printf "not (%vd) ", $x unless $x eq chr(300).chr(130);
 136 print "ok 21\n";
 137
 138 # Now let's make it suffer.
 139 open F, ">", "a" or die $!;
 140 my $w;
 141 eval {local $SIG{__WARN__} = sub { $w = $_[0] };  print F $a; };
 142 print "not " if ($@ || $w !~ /Wide character in print/i);
 143 print "ok 22\n";
 144 }
 145
 146 # Hm. Time to get more evil.
 147 open F, ">:utf8", "a" or die $!;
 148 print F $a;
 149 binmode(F, ":bytes");
 150 print F chr(130)."\n";
 151 close F;
 152
 153 open F, "<", "a" or die $!;
 154 $x = <F>; chomp $x;
 155 $chr = v196.172.130;
 156 if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
 157 print "not " unless $x eq $chr;
 158 print "ok 23\n";
 159
 160 # Right.
 161 open F, ">:utf8", "a" or die $!;
 162 print F $a;
 163 close F;
 164 open F, ">>", "a" or die $!;
 165 print F chr(130)."\n";
 166 close F;
 167
 168 open F, "<", "a" or die $!;
 169 $x = <F>; chomp $x;
 170 print "not " unless $x eq $chr;
 171 print "ok 24\n";
 172
 173 # Now we have a deformed file.
 174 open F, "<:utf8", "a" or die $!;
 175 $x = <F>; chomp $x;
 176 { local $SIG{__WARN__} = sub { print "ok 25\n"; };
 177 eval { sprintf "%vd\n", $x; }
 178 }
 179
 180 close F;
 181 unlink('a');
 182