t/io/utf8.t

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