ext/PerlIO/t/encoding.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     no warnings; # Need global -w flag for later tests, but don't want this
   7     # to warn here:
   8     push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
   9     unless (find PerlIO::Layer 'perlio') {
  10         print "1..0 # Skip: not perlio\n";
  11         exit 0;
  12     }
  13 }
  14
  15 print "1..13\n";
  16
  17 my $grk = "grk$$";
  18 my $utf = "utf$$";
  19 my $fail1 = "fa$$";
  20 my $fail2 = "fb$$";
  21 my $russki = "koi8r$$";
  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     use Encode;
  32     open(my $i,'<:encoding(iso-8859-7)',$grk);
  33     print "ok 1\n";
  34     open(my $o,'>:utf8',$utf);
  35     print "ok 2\n";
  36     print $o readline($i);
  37     print "ok 3\n";
  38     close($o) or die "Could not close: $!";
  39     close($i);
  40 }
  41
  42 if (open(UTF, "<$utf")) {
  43     binmode(UTF, ":bytes");
  44     if (ord('A') == 193) { # EBCDIC
  45         # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
  46         print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
  47     } else {
  48         # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
  49         print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
  50     }
  51     print "ok 4\n";
  52     close UTF;
  53 }
  54
  55 {
  56     use Encode;
  57     open(my $i,'<:utf8',$utf);
  58     print "ok 5\n";
  59     open(my $o,'>:encoding(iso-8859-7)',$grk);
  60     print "ok 6\n";
  61     print $o readline($i);
  62     print "ok 7\n";
  63     close($o) or die "Could not close: $!";
  64     close($i);
  65 }
  66
  67 if (open(GRK, "<$grk")) {
  68     binmode(GRK, ":bytes");
  69     print "not " unless <GRK> eq "\xe1\xe2\xe3";
  70     print "ok 8\n";
  71     close GRK;
  72 }
  73
  74 $SIG{__WARN__} = sub {$warn .= $_[0]};
  75
  76 if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
  77     print "not ok 9 # Open should fail\n";
  78 } else {
  79     print "ok 9\n";
  80 }
  81 if (!defined $warn) {
  82     print "not ok 10 # warning is undef\n";
  83 } elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
  84     print "ok 10\n";
  85 } else {
  86     print "not ok 10 # warning is '$warn'";
  87 }
  88
  89 if (open(RUSSKI, ">$russki")) {
  90     print RUSSKI "\x3c\x3f\x78";
  91     close RUSSKI or die "Could not close: $!";
  92     open(RUSSKI, "$russki");
  93     binmode(RUSSKI, ":raw");
  94     my $buf1;
  95     read(RUSSKI, $buf1, 1);
  96     # eof(RUSSKI);
  97     binmode(RUSSKI, ":encoding(koi8-r)");
  98     my $buf2;
  99     read(RUSSKI, $buf2, 1);
 100     my $offset = tell(RUSSKI);
 101     if (ord($buf1) == 0x3c &&
 102         ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
 103         $offset == 2) {
 104         print "ok 11\n";
 105     } else {
 106         printf "not ok 11 # [%s] [%s] %d\n",
 107                join(" ", unpack("H*", $buf1)),
 108                join(" ", unpack("H*", $buf2)), $offset;
 109     }
 110     close(RUSSKI);
 111 } else {
 112     print "not ok 11 # open failed: $!\n";
 113 }
 114
 115 undef $warn;
 116
 117 # Check there is no Use of uninitialized value in concatenation (.) warning
 118 # due to the way @latin2iso_num was used to make aliases.
 119 if (open(FAIL, ">:encoding(latin42)", $fail2)) {
 120     print "not ok 12 # Open should fail\n";
 121 } else {
 122     print "ok 12\n";
 123 }
 124 if (!defined $warn) {
 125     print "not ok 13 # warning is undef\n";
 126 } elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) {
 127     print "ok 13\n";
 128 } else {
 129     print "not ok 13 # warning is: \n";
 130     $warn =~ s/^/# /mg;
 131     print "$warn";
 132 }
 133
 134 END {
 135     unlink($grk, $utf, $fail1, $fail2, $russki);
 136 }