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, "<", $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 }