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     require Encode;
  16     eval { require PerlIO::encoding };
  17     unless ($INC{"PerlIO/encoding.pm"}
  18             and PerlIO::encoding->VERSION >= 0.02
  19            ){
  20         print "1..0 # Skip:: PerlIO::encoding 0.02 or better required\n";
  21         exit 0;
  22     }
  23     # warn "PerlIO::encoding->VERSION == ", PerlIO::encoding->VERSION, "\n";
  24     $| = 1;
  25 }
  26
  27 use strict;
  28 use File::Basename;
  29 use File::Spec;
  30 use File::Compare;
  31 use File::Copy;
  32 use FileHandle;
  33
  34 #use Test::More qw(no_plan);
  35 use Test::More tests => 20;
  36
  37 our $DEBUG = 0;
  38
  39 {
  40     no warnings;
  41     @ARGV and $DEBUG = shift;
  42     require Encode::JP::JIS7;
  43     $Encode::JP::JIS7::DEBUG = $DEBUG;
  44 }
  45
  46 Encode->import(":all");
  47
  48 my $dir = dirname(__FILE__);
  49 my $ufile = File::Spec->catfile($dir,"jisx0208.ref");
  50 open my $fh, "<:utf8", $ufile or die "$ufile : $!";
  51 my @uline = <$fh>;
  52 my $utext = join('' => @uline);
  53 close $fh;
  54 my $seq = 0;
  55
  56 for my $e (qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/){
  57     my $sfile = File::Spec->catfile($dir,"$$.sio");
  58     my $pfile = File::Spec->catfile($dir,"$$.pio");
  59
  60     # first create a file without perlio
  61     dump2file($sfile, &encode($e, $utext, 0));
  62
  63     # then create a file via perlio without autoflush
  64
  65  SKIP:{
  66         skip "$e: !perlio_ok", 1  unless perlio_ok($e) or $DEBUG;
  67         open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  68         binmode $fh;
  69         $fh->autoflush(0);
  70         print $fh $utext;
  71         close $fh;
  72         $seq++;
  73         unless (is(compare($sfile, $pfile), 0 => ">:encoding($e)")){
  74             copy $sfile, "$sfile.$seq";
  75             copy $pfile, "$pfile.$seq";
  76         }
  77     }
  78
  79     # this time print line by line.
  80     # works even for ISO-2022!
  81     open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  82     binmode $fh;
  83     $fh->autoflush(1);
  84     for my $l (@uline) {
  85         print $fh $l;
  86     }
  87     close $fh;
  88     $seq++;
  89     unless(is(compare($sfile, $pfile), 0
  90               => ">:encoding($e); by lines")){
  91         copy $sfile, "$sfile.$seq";
  92         copy $pfile, "$pfile.$seq";
  93     }
  94
  95  SKIP:{
  96         skip "$e: !perlio_ok", 2 unless perlio_ok($e) or $DEBUG;
  97         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
  98         $fh->autoflush(0);
  99         my $dtext = join('' => <$fh>);
 100         close $fh;
 101         $seq++;
 102         unless(ok($utext eq $dtext, "<:encoding($e)")){
 103             dump2file("$sfile.$seq", $utext);
 104             dump2file("$pfile.$seq", $dtext);
 105         }
 106         $dtext = '';
 107         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 108         while(defined(my $l = <$fh>)) {
 109             $dtext .= $l;
 110         }
 111         close $fh;
 112         $seq++;
 113         unless (ok($utext eq $dtext,  "<:encoding($e); by lines")) {
 114             dump2file("$sfile.$seq", $utext);
 115             dump2file("$pfile.$seq", $dtext);
 116         }
 117     }
 118     $DEBUG or unlink ($sfile, $pfile);
 119 }
 120
 121 sub dump2file{
 122     no warnings;
 123     open my $fh, ">", $_[0] or die "$_[0]: $!";
 124     binmode $fh;
 125     print $fh $_[1];
 126     close $fh;
 127 }