ext/Encode/t/perlio.t

   1 BEGIN {
   2     if ($ENV{'PERL_CORE'}){
   3         chdir 't';
   4         unshift @INC, '../lib';
   5     }
   6     require Config; import Config;
   7     if ($Config{'extensions'} !~ /\bEncode\b/) {
   8       print "1..0 # Skip: Encode was not built\n";
   9       exit 0;
  10     }
  11     if (ord("A") == 193) {
  12     print "1..0 # Skip: EBCDIC\n";
  13     exit 0;
  14     }
  15     unless (PerlIO::Layer->find('perlio')){
  16         print "1..0 # Skip: PerlIO required\n";
  17         exit 0;
  18     }
  19     $| = 1;
  20 }
  21
  22 use strict;
  23 use File::Basename;
  24 use File::Spec;
  25 use File::Compare qw(compare_text);
  26 use File::Copy;
  27 use FileHandle;
  28
  29 #use Test::More qw(no_plan);
  30 use Test::More tests => 38;
  31
  32 our $DEBUG = 0;
  33
  34 use Encode (":all");
  35 {
  36     no warnings;
  37     @ARGV and $DEBUG = shift;
  38     #require Encode::JP::JIS7;
  39     #require Encode::KR::2022_KR;
  40     #$Encode::JP::JIS7::DEBUG = $DEBUG;
  41 }
  42
  43 my $seq = 0;
  44 my $dir = dirname(__FILE__);
  45
  46 my %e =
  47     (
  48      jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/],
  49      ksc5601  => [ qw/euc-kr/],
  50      gb2312   => [ qw/euc-cn hz/],
  51     );
  52
  53 $/ = "\x0a"; # may fix VMS problem for test #28 and #29
  54
  55 for my $src (sort keys %e) {
  56     my $ufile = File::Spec->catfile($dir,"$src.utf");
  57     open my $fh, "<:utf8", $ufile or die "$ufile : $!";
  58     my @uline = <$fh>;
  59     my $utext = join('' => @uline);
  60     close $fh;
  61
  62     for my $e (@{$e{$src}}){
  63     my $sfile = File::Spec->catfile($dir,"$$.sio");
  64     my $pfile = File::Spec->catfile($dir,"$$.pio");
  65
  66     # first create a file without perlio
  67     dump2file($sfile, &encode($e, $utext, 0));
  68
  69     # then create a file via perlio without autoflush
  70
  71     SKIP:{
  72         skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG);
  73         no warnings 'uninitialized';
  74         open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  75         $fh->autoflush(0);
  76         print $fh $utext;
  77         close $fh;
  78         $seq++;
  79         is(compare_text($sfile, $pfile), 0 => ">:encoding($e)");
  80         if ($DEBUG){
  81         copy $sfile, "$sfile.$seq";
  82         copy $pfile, "$pfile.$seq";
  83         }
  84
  85         # this time print line by line.
  86         # works even for ISO-2022 but not ISO-2022-KR
  87         open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  88         $fh->autoflush(1);
  89         for my $l (@uline) {
  90         print $fh $l;
  91         }
  92         close $fh;
  93         $seq++;
  94         is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines");
  95         if ($DEBUG){
  96         copy $sfile, "$sfile.$seq";
  97         copy $pfile, "$pfile.$seq";
  98         }
  99         my $dtext;
 100         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 101         $fh->autoflush(0);
 102         $dtext = join('' => <$fh>);
 103         close $fh;
 104         $seq++;
 105         ok($utext eq $dtext, "<:encoding($e)");
 106         if ($DEBUG){
 107         dump2file("$sfile.$seq", $utext);
 108         dump2file("$pfile.$seq", $dtext);
 109         }
 110         if (perlio_ok($e) or $DEBUG){
 111         $dtext = '';
 112         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 113         while(defined(my $l = <$fh>)) {
 114             $dtext .= $l;
 115         }
 116         close $fh;
 117         }
 118         $seq++;
 119         ok($utext eq $dtext,  "<:encoding($e) by lines");
 120         if ($DEBUG){
 121         dump2file("$sfile.$seq", $utext);
 122         dump2file("$pfile.$seq", $dtext);
 123         }
 124     }
 125      if ( ! $DEBUG ) {
 126             1 while unlink ($sfile);
 127             1 while unlink ($pfile);
 128         }
 129     }
 130 }
 131
 132 # BOM Test
 133
 134 SKIP:{
 135     my $pev = PerlIO::encoding->VERSION;
 136     skip "PerlIO::encoding->VERSION = $pev <= 0.07 ", 6
 137     unless ($pev >= 0.07 or $DEBUG);
 138
 139     my $file = File::Spec->catfile($dir,"jisx0208.utf");
 140     open my $fh, "<:utf8", $file or die "$file : $!";
 141     my $str = join('' => <$fh>);
 142     close $fh;
 143     my %bom = (
 144            'UTF-16BE' => pack('n', 0xFeFF),
 145            'UTF-16LE' => pack('v', 0xFeFF),
 146            'UTF-32BE' => pack('N', 0xFeFF),
 147            'UTF-32LE' => pack('V', 0xFeFF),
 148           );
 149     # reading
 150     for my $utf (sort keys %bom){
 151     my $bomed = $bom{$utf} . encode($utf, $str);
 152     my $sfile = File::Spec->catfile($dir,".${utf}_${seq}_$$");
 153     dump2file($sfile, $bomed);
 154     my $utf_nobom = $utf; $utf_nobom =~ s/(LE|BE)$//o;
 155     # reading
 156     open $fh, "<:encoding($utf_nobom)", $sfile or die "$sfile : $!";
 157     my $cmp = join '' => <$fh>;
 158     close $fh;
 159     is($str, $cmp, "<:encoding($utf_nobom) eq $utf");
 160     unlink $sfile;  $seq++;
 161     }
 162     # writing
 163     for my $utf_nobom (qw/UTF-16 UTF-32/){
 164     my $utf = $utf_nobom . 'BE';
 165     my $sfile = File::Spec->catfile($dir,".${utf_nobom}_${seq}_$$");
 166     my $bomed = $bom{$utf} . encode($utf, $str);
 167     open  $fh, ">:encoding($utf_nobom)", $sfile or die "$sfile : $!";
 168     print $fh $str;
 169     close $fh;
 170     open my $fh, "<:bytes", $sfile or die "$sfile : $!";
 171     read $fh, my $cmp, -s $sfile;
 172     close $fh;
 173     use bytes ();
 174     ok($bomed eq $cmp, ">:encoding($utf_nobom) eq $utf");
 175     unlink $sfile; $seq++;
 176     }
 177 }
 178 sub dump2file{
 179     no warnings;
 180     open my $fh, ">", $_[0] or die "$_[0]: $!";
 181     binmode $fh;
 182     print $fh $_[1];
 183     close $fh;
 184 }