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