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 => 28;
  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
  44
  45 my $seq = 0;
  46 my $dir = dirname(__FILE__);
  47
  48 my %e =
  49     (
  50      jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/],
  51      #ksc5601  => [ qw/euc-kr iso-2022-kr/],
  52      ksc5601  => [ qw/euc-kr/],
  53      #gb2312   => [ qw/euc-cn hz/],
  54      gb2312   => [ qw/euc-cn/],
  55     );
  56
  57
  58 for my $src(sort keys %e) {
  59     my $ufile = File::Spec->catfile($dir,"$src.ref");
  60     open my $fh, "<:utf8", $ufile or die "$ufile : $!";
  61     my @uline = <$fh>;
  62     my $utext = join('' => @uline);
  63     close $fh;
  64
  65     for my $e (@{$e{$src}}){
  66         my $sfile = File::Spec->catfile($dir,"$$.sio");
  67         my $pfile = File::Spec->catfile($dir,"$$.pio");
  68
  69         # first create a file without perlio
  70         dump2file($sfile, &encode($e, $utext, 0));
  71
  72         # then create a file via perlio without autoflush
  73
  74     TODO:{
  75             #local $TODO = "$e: !perlio_ok" unless (perlio_ok($e) or $DEBUG);
  76             todo_skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG);
  77             no warnings 'uninitialized';
  78             open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  79             $fh->autoflush(0);
  80             print $fh $utext;
  81             close $fh;
  82             $seq++;
  83             is(compare_text($sfile, $pfile), 0 => ">:encoding($e)");
  84             if ($DEBUG){
  85                 copy $sfile, "$sfile.$seq";
  86                 copy $pfile, "$pfile.$seq";
  87             }
  88
  89             # this time print line by line.
  90             # works even for ISO-2022 but not ISO-2022-KR
  91             open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  92             $fh->autoflush(1);
  93             for my $l (@uline) {
  94                 print $fh $l;
  95             }
  96             close $fh;
  97             $seq++;
  98             is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines");
  99             if ($DEBUG){
 100                 copy $sfile, "$sfile.$seq";
 101                 copy $pfile, "$pfile.$seq";
 102             }
 103             my $dtext;
 104             open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 105             $fh->autoflush(0);
 106             $dtext = join('' => <$fh>);
 107             close $fh;
 108             $seq++;
 109             ok($utext eq $dtext, "<:encoding($e)");
 110             if ($DEBUG){
 111                 dump2file("$sfile.$seq", $utext);
 112                 dump2file("$pfile.$seq", $dtext);
 113             }
 114             if (perlio_ok($e) or $DEBUG){
 115                 $dtext = '';
 116                 open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 117                 while(defined(my $l = <$fh>)) {
 118                     $dtext .= $l;
 119                 }
 120                 close $fh;
 121             }
 122             $seq++;
 123             ok($utext eq $dtext,  "<:encoding($e) by lines");
 124             if ($DEBUG){
 125                 dump2file("$sfile.$seq", $utext);
 126                 dump2file("$pfile.$seq", $dtext);
 127             }
 128         }
 129         $DEBUG or unlink ($sfile, $pfile);
 130     }
 131 }
 132
 133
 134 sub dump2file{
 135     no warnings;
 136     open my $fh, ">", $_[0] or die "$_[0]: $!";
 137     binmode $fh;
 138     print $fh $_[1];
 139     close $fh;
 140 }