ext/PerlIO-encoding/t/encoding.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     unless (find PerlIO::Layer 'perlio') {
   5         print "1..0 # Skip: not perlio\n";
   6         exit 0;
   7     }
   8     unless (eval { require Encode } ) {
   9         print "1..0 # Skip: not Encode\n";
  10         exit 0;
  11     }
  12 }
  13
  14 print "1..15\n";
  15
  16 my $grk = "grk$$";
  17 my $utf = "utf$$";
  18 my $fail1 = "fa$$";
  19 my $fail2 = "fb$$";
  20 my $russki = "koi8r$$";
  21 my $threebyte = "3byte$$";
  22
  23 if (open(GRK, ">$grk")) {
  24     binmode(GRK, ":bytes");
  25     # alpha beta gamma in ISO 8859-7
  26     print GRK "\xe1\xe2\xe3";
  27     close GRK or die "Could not close: $!";
  28 }
  29
  30 {
  31     open(my $i,'<:encoding(iso-8859-7)',$grk);
  32     print "ok 1\n";
  33     open(my $o,'>:utf8',$utf);
  34     print "ok 2\n";
  35     print $o readline($i);
  36     print "ok 3\n";
  37     close($o) or die "Could not close: $!";
  38     close($i);
  39 }
  40
  41 if (open(UTF, "<$utf")) {
  42     binmode(UTF, ":bytes");
  43     if (ord('A') == 193) { # EBCDIC
  44         # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
  45         print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
  46     } else {
  47         # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
  48         print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
  49     }
  50     print "ok 4\n";
  51     close UTF;
  52 }
  53
  54 {
  55     use Encode;
  56     open(my $i,'<:utf8',$utf);
  57     print "ok 5\n";
  58     open(my $o,'>:encoding(iso-8859-7)',$grk);
  59     print "ok 6\n";
  60     print $o readline($i);
  61     print "ok 7\n";
  62     close($o) or die "Could not close: $!";
  63     close($i);
  64 }
  65
  66 if (open(GRK, "<$grk")) {
  67     binmode(GRK, ":bytes");
  68     print "not " unless <GRK> eq "\xe1\xe2\xe3";
  69     print "ok 8\n";
  70     close GRK;
  71 }
  72
  73 $SIG{__WARN__} = sub {$warn .= $_[0]};
  74
  75 if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
  76     print "not ok 9 # Open should fail\n";
  77 } else {
  78     print "ok 9\n";
  79 }
  80 if (!defined $warn) {
  81     print "not ok 10 # warning is undef\n";
  82 } elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
  83     print "ok 10\n";
  84 } else {
  85     print "not ok 10 # warning is '$warn'";
  86 }
  87
  88 if (open(RUSSKI, ">$russki")) {
  89     print RUSSKI "\x3c\x3f\x78";
  90     close RUSSKI or die "Could not close: $!";
  91     open(RUSSKI, "$russki");
  92     binmode(RUSSKI, ":raw");
  93     my $buf1;
  94     read(RUSSKI, $buf1, 1);
  95     # eof(RUSSKI);
  96     binmode(RUSSKI, ":encoding(koi8-r)");
  97     my $buf2;
  98     read(RUSSKI, $buf2, 1);
  99     my $offset = tell(RUSSKI);
 100     if (ord($buf1) == 0x3c &&
 101         ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
 102         $offset == 2) {
 103         print "ok 11\n";
 104     } else {
 105         printf "not ok 11 # [%s] [%s] %d\n",
 106                join(" ", unpack("H*", $buf1)),
 107                join(" ", unpack("H*", $buf2)), $offset;
 108     }
 109     close(RUSSKI);
 110 } else {
 111     print "not ok 11 # open failed: $!\n";
 112 }
 113
 114 undef $warn;
 115
 116 # Check there is no Use of uninitialized value in concatenation (.) warning
 117 # due to the way @latin2iso_num was used to make aliases.
 118 if (open(FAIL, ">:encoding(latin42)", $fail2)) {
 119     print "not ok 12 # Open should fail\n";
 120 } else {
 121     print "ok 12\n";
 122 }
 123 if (!defined $warn) {
 124     print "not ok 13 # warning is undef\n";
 125 } elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) {
 126     print "ok 13\n";
 127 } else {
 128     print "not ok 13 # warning is: \n";
 129     $warn =~ s/^/# /mg;
 130     print "$warn";
 131 }
 132
 133 # Create a string of chars that are 3 bytes in UTF-8
 134 my $str = "\x{1f80}" x 2048;
 135
 136 # Write them to a file
 137 open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
 138 print F $str;
 139 close(F);
 140
 141 # Read file back as UTF-8
 142 open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
 143 my $dstr = <F>;
 144 close(F);
 145 print "not " unless ($dstr eq $str);
 146 print "ok 14\n";
 147
 148 # Try decoding some bad stuff
 149 open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!";
 150 if (ord('A') == 193) { # EBCDIC
 151     print F "foo\x8c\x80\x80\x80bar\n\x80foo\n";
 152 } else {
 153     print F "foo\xF0\x80\x80\x80bar\n\x80foo\n";
 154 }
 155 close(F);
 156
 157 open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
 158 $dstr = join(":", <F>);
 159 close(F);
 160 if (ord('A') == 193) { # EBCDIC
 161     print "not " unless $dstr eq "foo\\x8C\\x80\\x80\\x80bar\n:\\x80foo\n";
 162 } else {
 163     print "not " unless $dstr eq "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n";
 164 }
 165 print "ok 15\n";
 166
 167 END {
 168     1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
 169 }