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     $| = 1;
  16 }
  17
  18 use strict;
  19 use File::Basename;
  20 use File::Spec;
  21 use File::Compare qw(compare_text);
  22 use File::Copy;
  23 use FileHandle;
  24
  25 #use Test::More qw(no_plan);
  26 use Test::More tests => 28;
  27
  28 our $DEBUG = 0;
  29
  30 use Encode (":all");
  31 eval { require PerlIO::encoding };
  32
  33 {
  34     no warnings;
  35     @ARGV and $DEBUG = shift;
  36     #require Encode::JP::JIS7;
  37     #require Encode::KR::2022_KR;
  38     #$Encode::JP::JIS7::DEBUG = $DEBUG;
  39 }
  40
  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 iso-2022-kr/],
  50      ksc5601  => [ qw/euc-kr/],
  51      #gb2312   => [ qw/euc-cn hz/],
  52      gb2312   => [ qw/euc-cn/],
  53     );
  54
  55
  56 for my $src(sort keys %e) {
  57     my $ufile = File::Spec->catfile($dir,"$src.ref");
  58     open my $fh, "<:utf8", $ufile or die "$ufile : $!";
  59     my @uline = <$fh>;
  60     my $utext = join('' => @uline);
  61     close $fh;
  62
  63     for my $e (@{$e{$src}}){
  64         my $sfile = File::Spec->catfile($dir,"$$.sio");
  65         my $pfile = File::Spec->catfile($dir,"$$.pio");
  66
  67         # first create a file without perlio
  68         dump2file($sfile, &encode($e, $utext, 0));
  69
  70         # then create a file via perlio without autoflush
  71
  72     TODO:{
  73             #local $TODO = "$e: !perlio_ok" unless (perlio_ok($e) or $DEBUG);
  74             todo_skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG);
  75             no warnings 'uninitialized';
  76             open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  77             $fh->autoflush(0);
  78             print $fh $utext;
  79             close $fh;
  80             $seq++;
  81             is(compare_text($sfile, $pfile), 0 => ">:encoding($e)");
  82             if ($DEBUG){
  83                 copy $sfile, "$sfile.$seq";
  84                 copy $pfile, "$pfile.$seq";
  85             }
  86
  87             # this time print line by line.
  88             # works even for ISO-2022 but not ISO-2022-KR
  89             open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  90             $fh->autoflush(1);
  91             for my $l (@uline) {
  92                 print $fh $l;
  93             }
  94             close $fh;
  95             $seq++;
  96             is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines");
  97             if ($DEBUG){
  98                 copy $sfile, "$sfile.$seq";
  99                 copy $pfile, "$pfile.$seq";
 100             }
 101             my $dtext;
 102             open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 103             $fh->autoflush(0);
 104             $dtext = join('' => <$fh>);
 105             close $fh;
 106             $seq++;
 107             ok($utext eq $dtext, "<:encoding($e)");
 108             if ($DEBUG){
 109                 dump2file("$sfile.$seq", $utext);
 110                 dump2file("$pfile.$seq", $dtext);
 111             }
 112             if (perlio_ok($e) or $DEBUG){
 113                 $dtext = '';
 114                 open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 115                 while(defined(my $l = <$fh>)) {
 116                     $dtext .= $l;
 117                 }
 118                 close $fh;
 119             }
 120             $seq++;
 121             ok($utext eq $dtext,  "<:encoding($e) by lines");
 122             if ($DEBUG){
 123                 dump2file("$sfile.$seq", $utext);
 124                 dump2file("$pfile.$seq", $dtext);
 125             }
 126         }
 127         $DEBUG or unlink ($sfile, $pfile);
 128     }
 129 }
 130
 131
 132 sub dump2file{
 133     no warnings;
 134     open my $fh, ">", $_[0] or die "$_[0]: $!";
 135     binmode $fh;
 136     print $fh $_[1];
 137     close $fh;
 138 }