ext/Encode/t/rt.pl

   1 #!/usr/local/bin/perl
   2 #
   3 # $Id: rt.pl,v 1.2 2002/11/08 18:29:27 dankogai Exp $
   4 #
   5
   6 BEGIN {
   7     my $ucmdir  = "ucm";
   8     if ($ENV{'PERL_CORE'}){
   9         chdir 't';
  10         unshift @INC, '../lib';
  11         $ucmdir = "../ext/Encode/ucm";
  12     }
  13     require Config; import Config;
  14     if ($Config{'extensions'} !~ /\bEncode\b/) {
  15       print "1..0 # Skip: Encode was not built\n";
  16       exit 0;
  17     }
  18     if (ord("A") == 193) {
  19         print "1..0 # Skip: EBCDIC\n";
  20         exit 0;
  21     }
  22     use strict;
  23     require Test::More;
  24     our $DEBUG;
  25     our @ucm;
  26     unless(@ARGV){
  27         use File::Spec;
  28         Test::More->import(tests => 103);
  29         opendir my $dh, $ucmdir or die "$ucmdir:$!";
  30         @ucm =
  31             map {File::Spec->catfile($ucmdir, $_) }
  32                 sort grep {/\.ucm$/o} readdir($dh);
  33         closedir $dh;
  34     }else{
  35         Test::More->import("no_plan");
  36         $DEBUG = 1;
  37         @ucm = @ARGV;
  38     }
  39 }
  40
  41 use strict;
  42 use Encode qw/encode decode/;
  43 our $DEBUG;
  44 our @ucm;
  45
  46 for my $ucm (@ucm){
  47     my ($name, $nchar, $nrt, $nok) = rttest($ucm);
  48     $nok += 0;
  49     ok($nok == 0, "$ucm => $name ($nchar, $nrt, $nok)");
  50 }
  51
  52 sub rttest{
  53     my $ucm = shift;
  54     my ($name, $nchar, $nrt, $nok);
  55     open my $rfh, "<$ucm" or die "$ucm:$!";
  56     # <U0000> \x00 |0 # <control>
  57     while(<$rfh>){
  58         s/#.*//o; /^$/ and next;
  59         unless ($name){
  60             /^<code_set_name>\s+"([^\"]+)"/io or next;
  61             $name = $1 and next;
  62         }else{
  63             /^<U([0-9a-f]+)>\s+(\S+)\s+\|(\d)/io or next;
  64             $nchar++;
  65             $3 == 0 or next;
  66             $nrt++;
  67             my $uni = chr(hex($1));
  68             my $enc = eval qq{ "$2" };
  69             decode($name, $enc) eq $uni or $nok++;
  70             encode($name, $uni) eq $enc or $nok++;
  71         }
  72     }
  73     return($name, $nchar, $nrt, $nok);
  74 }
  75 __END__