ext/Encode/t/enc_eucjp.t

   1 # $Id: enc_eucjp.t,v 1.5 2003/08/20 11:15:31 dankogai Exp $
   2 # This is the twin of enc_utf8.t .
   3
   4 BEGIN {
   5     require Config; import Config;
   6     if ($Config{'extensions'} !~ /\bEncode\b/) {
   7       print "1..0 # Skip: Encode was not built\n";
   8       exit 0;
   9     }
  10     unless (find PerlIO::Layer 'perlio') {
  11         print "1..0 # Skip: PerlIO was not built\n";
  12         exit 0;
  13     }
  14     if (ord("A") == 193) {
  15         print "1..0 # encoding pragma does not support EBCDIC platforms\n";
  16         exit(0);
  17     }
  18     if ($] <= 5.008 and !$Config{perl_patchlevel}){
  19         print "1..0 # Skip: Perl 5.8.1 or later required\n";
  20         exit 0;
  21     }
  22 }
  23
  24 use encoding 'euc-jp';
  25
  26 my @c = (127, 128, 255, 256);
  27
  28 print "1.." . (scalar @c + 1) . "\n";
  29
  30 my @f;
  31
  32 for my $i (0..$#c) {
  33   no warnings 'pack';
  34   my $file = filename("f$i");
  35   push @f, $file;
  36   open(F, ">$file") or die "$0: failed to open '$file' for writing: $!";
  37   binmode(F, ":utf8");
  38   print F chr($c[$i]);
  39   print F pack("C" => $c[$i]);
  40   close F;
  41 }
  42
  43 my $t = 1;
  44
  45 for my $i (0..$#c) {
  46   my $file = filename("f$i");
  47   open(F, "<$file") or die "$0: failed to open '$file' for reading: $!";
  48   binmode(F, ":utf8");
  49   my $c = <F>;
  50   my $o = ord($c);
  51   print $o == $c[$i] ? "ok $t - utf8 I/O $c[$i]\n" : "not ok $t - utf8 I/O $c[$i]: $o != $c[$i]\n";
  52   $t++;
  53 }
  54
  55 my $f = filename("f" . @f);
  56
  57 push @f, $f;
  58 open(F, ">$f") or die "$0: failed to open '$f' for writing: $!";
  59 binmode(F, ":raw"); # Output raw bytes.
  60 print F chr(128); # Output illegal UTF-8.
  61 close F;
  62 open(F, $f) or die "$0: failed to open '$f' for reading: $!";
  63 binmode(F, ":encoding(utf-8)");
  64 {
  65         local $^W = 1;
  66         local $SIG{__WARN__} = sub { $a = shift };
  67         eval { <F> }; # This should get caught.
  68 }
  69 close F;
  70 print $a =~ qr{^utf8 "\\x80" does not map to Unicode} ?
  71   "ok $t - illegal utf8 input\n" : "not ok $t - illegal utf8 input: a = " . unpack("H*", $a) . "\n";
  72
  73 # On VMS temporary file names like "f0." may be more readable than "f0" since
  74 # "f0" could be a logical name pointing elsewhere.
  75 sub filename {
  76     my $name = shift;
  77     $name .= '.' if $^O eq 'VMS';
  78     return $name;
  79 }
  80
  81 END {
  82   1 while unlink @f;
  83 }