summaryrefslogtreecommitdiff
path: root/t/uni/case.pl
blob: 25f8f4c97738203603200f20056e78899c2efe5c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
use File::Spec;

require "test.pl";

sub casetest {
    my ($base, $spec, $func) = @_;
    my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir,
						      "lib", "unicore", "To"),
				   "$base.pl");
    my $simple = do $file;
    my %simple;
    for my $i (split(/\n/, $simple)) {
	my ($k, $v) = split(' ', $i);
	$simple{$k} = $v;
    }
    my %seen;

    for my $i (sort keys %simple) {
	$seen{hex $i}++;
    }
    print "# ", scalar keys %simple, " simple mappings\n";

    my $both;

    for my $i (sort keys %$spec) {
	$both++ if ++$seen{hex $i} == 2;
    }
    print "# ", scalar keys %$spec, " special mappings\n";

    my %none;
    for my $i (map { ord } split //,
	       "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") {
	next if pack("U0U", $i) =~ /\w/;
	$none{$i}++ unless $seen{$i};
    }
    print "# ", scalar keys %none, " noncase mappings\n";

    my $tests = 
	(scalar keys %simple) +
	(scalar keys %$spec) +
	(scalar keys %none) - $both;
    print "1..$tests\n";

    my $test = 1;

    for my $i (sort { hex $a <=> hex $b } keys %simple) {
	my $w = "$i -> $simple{$i}";
	my $c = pack "U0U", hex $i;
	my $d = $func->($c);
	print $d eq pack("U0U", hex $simple{$i}) ?
	    "ok $test # $w\n" : "not ok $test # $w\n";
	$test++;
    }

    for my $i (sort { hex $a <=> hex $b } keys %$spec) {
	next if $seen{hex $i} == 2;
	my $w = qq[$i -> "] . display($spec->{$i}) . qq["];
	my $c = pack "U0U", hex $i;
	my $d = $func->($c);
	print $d eq $spec->{$i} ?
	    "ok $test # $w\n" : "not ok $test # $w\n";
	$test++;
    }


    for my $i (sort { $a <=> $b } keys %none) {
	my $w = sprintf "%04X -> %04X", $i, $i;
	my $c = pack "U0U", $i;
	my $d = $func->($c);
	print $d eq $c ?
	    "ok $test # $w\n" : "not ok $test # $w\n";
	$test++;
    }
}

1;