Historic version labels

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

#!/usr/local/bin/perl
#
# $Id: rt.pl,v 1.1 2002/10/20 15:44:00 dankogai Exp $
#

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;
    }
    use strict;
    require Test::More;
    my $ucmdir  = "ucm";
    our $DEBUG;
    our @ucm;
    unless(@ARGV){
	use File::Spec;
	Test::More->import(tests => 103);
	opendir my $dh, $ucmdir or die "$ucmdir:$!";
	@ucm = 
	    map {File::Spec->catfile($ucmdir, $_) } 
		sort grep {/\.ucm$/o} readdir($dh);
	closedir $dh;
    }else{
	Test::More->import("no_plan");
	$DEBUG = 1;
	@ucm = @ARGV;
    }
}

use strict;
use Encode qw/encode decode/;
our $DEBUG;
our @ucm;

for my $ucm (@ucm){
    my ($name, $nchar, $nrt, $nok) = rttest($ucm);
    $nok += 0;
    ok($nok == 0, "$ucm => $name ($nchar, $nrt, $nok)");
}

sub rttest{
    my $ucm = shift;
    my ($name, $nchar, $nrt, $nok);
    open my $rfh, "<$ucm" or die "$ucm:$!";
    # <U0000> \x00 |0 # <control>
    while(<$rfh>){
	s/#.*//o; /^$/ and next;
	unless ($name){
	    /^<code_set_name>\s+"([^\"]+)"/io or next;
	    $name = $1 and next;
	}else{
	    /^<U([0-9a-f]+)>\s+(\S+)\s+\|(\d)/io or next;
	    $nchar++;
	    $3 == 0 or next;
	    $nrt++;
	    my $uni = chr(hex($1));
	    my $enc = eval qq{ "$2" };
	    decode($name, $enc) eq $uni or $nok++;
	    encode($name, $uni) eq $enc or $nok++;
	}
    }
    return($name, $nchar, $nrt, $nok);
}
__END__