Remove pseudo-hashes (complete)

[p5sagit/p5-mst-13.2.git] / ext / Encode / t / perlio.t

BEGIN {
    if ($ENV{'PERL_CORE'}){
        chdir 't';
        unshift @INC, '../lib';
    }
    require Config; import Config;
    if ($Config{'extensions'} !~ /\bEncode\b/) {
      print "1..0 # Skip: Encode was not built\n";
      exit 0;
    }
    if (ord("A") == 193) {
	print "1..0 # Skip: EBCDIC\n";
	exit 0;
    }
    unless (PerlIO::Layer->find('perlio')){
        print "1..0 # Skip: PerlIO required\n";
        exit 0;
    }
    $| = 1;
}

use strict;
use File::Basename;
use File::Spec;
use File::Compare qw(compare_text);
use File::Copy;
use FileHandle;

#use Test::More qw(no_plan);
use Test::More tests => 28;

our $DEBUG = 0;

use Encode (":all");
{
    no warnings;
    @ARGV and $DEBUG = shift;
    #require Encode::JP::JIS7;
    #require Encode::KR::2022_KR;
    #$Encode::JP::JIS7::DEBUG = $DEBUG;
}



my $seq = 0;
my $dir = dirname(__FILE__);

my %e = 
    (
     jisx0208 => [ qw/euc-jp shiftjis 7bit-jis iso-2022-jp iso-2022-jp-1/],
     #ksc5601  => [ qw/euc-kr iso-2022-kr/],
     ksc5601  => [ qw/euc-kr/],
     #gb2312   => [ qw/euc-cn hz/],
     gb2312   => [ qw/euc-cn/],
    );

$/ = "\x0a"; # may fix VMS problem for test #28 and #29

for my $src(sort keys %e) {
    my $ufile = File::Spec->catfile($dir,"$src.utf");
    open my $fh, "<:utf8", $ufile or die "$ufile : $!";
    my @uline = <$fh>;
    my $utext = join('' => @uline);
    close $fh;

    for my $e (@{$e{$src}}){
	my $sfile = File::Spec->catfile($dir,"$$.sio");
	my $pfile = File::Spec->catfile($dir,"$$.pio");
    
	# first create a file without perlio
	dump2file($sfile, &encode($e, $utext, 0));
    
	# then create a file via perlio without autoflush

    TODO:{
	    #local $TODO = "$e: !perlio_ok" unless (perlio_ok($e) or $DEBUG);
	    todo_skip "$e: !perlio_ok", 4 unless (perlio_ok($e) or $DEBUG);
	    no warnings 'uninitialized';
	    open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
	    $fh->autoflush(0);
	    print $fh $utext;
	    close $fh;
	    $seq++;
	    is(compare_text($sfile, $pfile), 0 => ">:encoding($e)");
	    if ($DEBUG){
		copy $sfile, "$sfile.$seq";
		copy $pfile, "$pfile.$seq";
	    }
	    
	    # this time print line by line.
	    # works even for ISO-2022 but not ISO-2022-KR
	    open $fh, ">:encoding($e)", $pfile or die "$sfile : $!";
	    $fh->autoflush(1);
	    for my $l (@uline) {
		print $fh $l;
	    }
	    close $fh;
	    $seq++;
	    is(compare_text($sfile, $pfile), 0 => ">:encoding($e) by lines");
	    if ($DEBUG){
		copy $sfile, "$sfile.$seq";
		copy $pfile, "$pfile.$seq";
	    }
	    my $dtext;
	    open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
	    $fh->autoflush(0);
	    $dtext = join('' => <$fh>);
	    close $fh;
	    $seq++;
	    ok($utext eq $dtext, "<:encoding($e)");
	    if ($DEBUG){
		dump2file("$sfile.$seq", $utext);
		dump2file("$pfile.$seq", $dtext);
	    }
	    if (perlio_ok($e) or $DEBUG){
		$dtext = '';
		open $fh, "<:encoding($e)", $pfile or die "$pfile : $!";
		while(defined(my $l = <$fh>)) {
		    $dtext .= $l;
		}
		close $fh;
	    }
	    $seq++;
	    ok($utext eq $dtext,  "<:encoding($e) by lines");
	    if ($DEBUG){
		dump2file("$sfile.$seq", $utext);
		dump2file("$pfile.$seq", $dtext);
	    }
	}
	$DEBUG or unlink ($sfile, $pfile);
    }
}
    

sub dump2file{
    no warnings;
    open my $fh, ">", $_[0] or die "$_[0]: $!";
    binmode $fh;
    print $fh $_[1];
    close $fh;
}