ext/Encode/t/rt.pl

   1 #!/usr/local/bin/perl
   2 #
   3 # $Id: rt.pl,v 2.1 2006/05/03 18:24:10 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__