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