← Back to branch summary

~ubuntu-branches/ubuntu/raring/libencode-perl/raring

« back to all changes in this revision

Viewing changes to t/rt.pl

  • Committer: Bazaar Package Importer
  • Author(s): Jose Luis Rivas
  • Date: 2007-05-18 23:49:27 UTC
  • Revision ID: james.westby@ubuntu.com-20070518234927-bs37c807cty7i1ny
Tags: upstream-2.21
Import upstream version 2.21

Show diffs side-by-side

added added

removed removed

Lines of Context:
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__