cpan/Encode/t/perlio.t

   1 BEGIN {
   2     require Config; import Config;
   3     if ($Config{'extensions'} !~ /\bEncode\b/) {
   4       print "1..0 # Skip: Encode was not built\n";
   5       exit 0;
   6     }
   7     if (ord("A") == 193) {
   8     print "1..0 # Skip: EBCDIC\n";
   9     exit 0;
  10     }
  11     unless (PerlIO::Layer->find('perlio')){
  12         print "1..0 # Skip: PerlIO required\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 => 38;
  27
  28 our $DEBUG = 0;
  29
  30 use Encode (":all");
  31 {
  32     no warnings;
  33     @ARGV and $DEBUG = shift;
  34     #require Encode::JP::JIS7;
  35     #require Encode::KR::2022_KR;
  36     #$Encode::JP::JIS7::DEBUG = $DEBUG;
  37 }
  38
  39 my $seq = 0;
  40 my $dir = dirname(__FILE__);
  41
  42 my %e =
  43     (
  44      jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/],
  45      ksc5601  => [ qw/euc-kr/],
  46      gb2312   => [ qw/euc-cn hz/],
  47     );
  48
  49 $/ = "\x0a"; # may fix VMS problem for test #28 and #29
  50
  51 for my $src (sort keys %e) {
  52     my $ufile = File::Spec->catfile($dir,"$src.utf");
  53     open my $fh, "<:utf8", $ufile or die "$ufile : $!";
  54     my @uline = <$fh>;
  55     my $utext = join('' => @uline);
  56     close $fh;
  57
  58     for my $e (@{$e{$src}}){
  59     my $sfile = File::Spec->catfile($dir,"$$.sio");
  60     my $pfile = File::Spec->catfile($dir,"$$.pio");
  61
  62     # first create a file without perlio
  63     dump2file($sfile, &encode($e, $utext, 0));
  64
  65     # then create a file via perlio without autoflush
  66
  67     SKIP:{
  68         skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG);
  69         no warnings 'uninitialized';
  70         open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  71         $fh->autoflush(0);
  72         print $fh $utext;
  73         close $fh;
  74         $seq++;
  75         is(compare_text($sfile, $pfile), 0 => ">:encoding($e)");
  76         if ($DEBUG){
  77         copy $sfile, "$sfile.$seq";
  78         copy $pfile, "$pfile.$seq";
  79         }
  80
  81         # this time print line by line.
  82         # works even for ISO-2022 but not ISO-2022-KR
  83         open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
  84         $fh->autoflush(1);
  85         for my $l (@uline) {
  86         print $fh $l;
  87         }
  88         close $fh;
  89         $seq++;
  90         is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines");
  91         if ($DEBUG){
  92         copy $sfile, "$sfile.$seq";
  93         copy $pfile, "$pfile.$seq";
  94         }
  95         my $dtext;
  96         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
  97         $fh->autoflush(0);
  98         $dtext = join('' => <$fh>);
  99         close $fh;
 100         $seq++;
 101         ok($utext eq $dtext, "<:encoding($e)");
 102         if ($DEBUG){
 103         dump2file("$sfile.$seq", $utext);
 104         dump2file("$pfile.$seq", $dtext);
 105         }
 106         if (perlio_ok($e) or $DEBUG){
 107         $dtext = '';
 108         open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
 109         while(defined(my $l = <$fh>)) {
 110             $dtext .= $l;
 111         }
 112         close $fh;
 113         }
 114         $seq++;
 115         ok($utext eq $dtext,  "<:encoding($e) by lines");
 116         if ($DEBUG){
 117         dump2file("$sfile.$seq", $utext);
 118         dump2file("$pfile.$seq", $dtext);
 119         }
 120     }
 121      if ( ! $DEBUG ) {
 122             1 while unlink ($sfile);
 123             1 while unlink ($pfile);
 124         }
 125     }
 126 }
 127
 128 # BOM Test
 129
 130 SKIP:{
 131     my $pev = PerlIO::encoding->VERSION;
 132     skip "PerlIO::encoding->VERSION = $pev <= 0.07 ", 6
 133     unless ($pev >= 0.07 or $DEBUG);
 134
 135     my $file = File::Spec->catfile($dir,"jisx0208.utf");
 136     open my $fh, "<:utf8", $file or die "$file : $!";
 137     my $str = join('' => <$fh>);
 138     close $fh;
 139     my %bom = (
 140            'UTF-16BE' => pack('n', 0xFeFF),
 141            'UTF-16LE' => pack('v', 0xFeFF),
 142            'UTF-32BE' => pack('N', 0xFeFF),
 143            'UTF-32LE' => pack('V', 0xFeFF),
 144           );
 145     # reading
 146     for my $utf (sort keys %bom){
 147     my $bomed = $bom{$utf} . encode($utf, $str);
 148     my $sfile = File::Spec->catfile($dir,".${utf}_${seq}_$$");
 149     dump2file($sfile, $bomed);
 150     my $utf_nobom = $utf; $utf_nobom =~ s/(LE|BE)$//o;
 151     # reading
 152     open $fh, "<:encoding($utf_nobom)", $sfile or die "$sfile : $!";
 153     my $cmp = join '' => <$fh>;
 154     close $fh;
 155     is($str, $cmp, "<:encoding($utf_nobom) eq $utf");
 156     unlink $sfile;  $seq++;
 157     }
 158     # writing
 159     for my $utf_nobom (qw/UTF-16 UTF-32/){
 160     my $utf = $utf_nobom . 'BE';
 161     my $sfile = File::Spec->catfile($dir,".${utf_nobom}_${seq}_$$");
 162     my $bomed = $bom{$utf} . encode($utf, $str);
 163     open  $fh, ">:encoding($utf_nobom)", $sfile or die "$sfile : $!";
 164     print $fh $str;
 165     close $fh;
 166     open my $fh, "<:bytes", $sfile or die "$sfile : $!";
 167     read $fh, my $cmp, -s $sfile;
 168     close $fh;
 169     use bytes ();
 170     ok($bomed eq $cmp, ">:encoding($utf_nobom) eq $utf");
 171     unlink $sfile; $seq++;
 172     }
 173 }
 174 sub dump2file{
 175     no warnings;
 176     open my $fh, ">", $_[0] or die "$_[0]: $!";
 177     binmode $fh;
 178     print $fh $_[1];
 179     close $fh;
 180 }