Commit | Line | Data |
---|---|---|
e49298ea JH |
1 | use File::Spec; |
2 | ||
3 | require "test.pl"; | |
4 | ||
e486a898 JH |
5 | sub unidump { |
6 | join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; | |
7 | } | |
8 | ||
e49298ea JH |
9 | sub casetest { |
10 | my ($base, $spec, $func) = @_; | |
11 | my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, | |
12 | "lib", "unicore", "To"), | |
13 | "$base.pl"); | |
14 | my $simple = do $file; | |
15 | my %simple; | |
16 | for my $i (split(/\n/, $simple)) { | |
17 | my ($k, $v) = split(' ', $i); | |
18 | $simple{$k} = $v; | |
19 | } | |
20 | my %seen; | |
21 | ||
22 | for my $i (sort keys %simple) { | |
23 | $seen{hex $i}++; | |
24 | } | |
25 | print "# ", scalar keys %simple, " simple mappings\n"; | |
26 | ||
27 | my $both; | |
28 | ||
29 | for my $i (sort keys %$spec) { | |
30 | if (++$seen{hex $i} == 2) { | |
31 | warn "$base: $i seen twice\n"; | |
32 | $both++; | |
33 | } | |
34 | } | |
35 | print "# ", scalar keys %$spec, " special mappings\n"; | |
36 | ||
37 | exit(1) if $both; | |
38 | ||
39 | my %none; | |
40 | for my $i (map { ord } split //, | |
41 | "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { | |
42 | next if pack("U0U", $i) =~ /\w/; | |
43 | $none{$i}++ unless $seen{$i}; | |
44 | } | |
45 | print "# ", scalar keys %none, " noncase mappings\n"; | |
46 | ||
47 | my $tests = | |
48 | (scalar keys %simple) + | |
49 | (scalar keys %$spec) + | |
50 | (scalar keys %none); | |
51 | print "1..$tests\n"; | |
52 | ||
53 | my $test = 1; | |
54 | ||
55 | for my $i (sort { hex $a <=> hex $b } keys %simple) { | |
e486a898 | 56 | my $w = $simple{$i}; |
e49298ea JH |
57 | my $c = pack "U0U", hex $i; |
58 | my $d = $func->($c); | |
e486a898 | 59 | my $e = unidump($d); |
e49298ea | 60 | print $d eq pack("U0U", hex $simple{$i}) ? |
e486a898 | 61 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; |
e49298ea JH |
62 | $test++; |
63 | } | |
64 | ||
65 | for my $i (sort { hex $a <=> hex $b } keys %$spec) { | |
e486a898 | 66 | my $w = unidump($spec->{$i}); |
e49298ea JH |
67 | my $c = pack "U0U", hex $i; |
68 | my $d = $func->($c); | |
e486a898 | 69 | my $e = unidump($d); |
0c23d0e0 JH |
70 | if (ord "A" == 193) { # EBCDIC |
71 | # We need to a little bit of remapping. | |
72 | # | |
73 | # For example, in titlecase (ucfirst) mapping | |
74 | # of U+0149 the Unicode mapping is U+02BC U+004E. | |
75 | # The 4E is N, which in EBCDIC is 2B-- | |
76 | # and the ucfirst() does that right. | |
77 | # The problem is that our reference | |
78 | # data is in Unicode code points. | |
79 | # | |
80 | # The Right Way here would be to use, say, | |
81 | # Encode, to remap the less-than 0x100 code points, | |
82 | # but let's try to be Encode-independent here. | |
83 | # | |
84 | # These are the titlecase exceptions: | |
85 | # | |
86 | # Unicode Unicode+EBCDIC | |
87 | # | |
88 | # 0149 -> 02BC 004E (02BC 002B) | |
89 | # 01F0 -> 004A 030C (00A2 030C) | |
90 | # 1E96 -> 0048 0331 (00E7 0331) | |
91 | # 1E97 -> 0054 0308 (00E8 0308) | |
92 | # 1E98 -> 0057 030A (00EF 030A) | |
93 | # 1E99 -> 0059 030A (00DF 030A) | |
94 | # 1E9A -> 0041 02BE (00A0 02BE) | |
95 | # | |
96 | # The uppercase exceptions are identical. | |
97 | # | |
dcdcee7d JH |
98 | # The lowercase has one more: |
99 | # | |
100 | # Unicode Unicode+EBCDIC | |
101 | # | |
102 | # 0130 -> 0069 0307 (00D1 0307) | |
103 | # | |
104 | if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { | |
0c23d0e0 JH |
105 | $e =~ s/004E/002B/; # N |
106 | $e =~ s/004A/00A2/; # J | |
107 | $e =~ s/0048/00E7/; # H | |
108 | $e =~ s/0054/00E8/; # T | |
109 | $e =~ s/0057/00EF/; # W | |
110 | $e =~ s/0059/00DF/; # Y | |
111 | $e =~ s/0041/00A0/; # A | |
dcdcee7d | 112 | $e =~ s/0069/00D1/; # i |
0c23d0e0 JH |
113 | } |
114 | # We have to map the output, not the input, because | |
115 | # pack/unpack U has been EBCDICified, too, it would | |
116 | # just undo our remapping. | |
117 | } | |
118 | print $w eq $e ? | |
e486a898 | 119 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; |
e49298ea JH |
120 | $test++; |
121 | } | |
122 | ||
e49298ea | 123 | for my $i (sort { $a <=> $b } keys %none) { |
e486a898 JH |
124 | my $w = $i = sprintf "%04X", $i; |
125 | my $c = pack "U0U", hex $i; | |
e49298ea | 126 | my $d = $func->($c); |
e486a898 | 127 | my $e = unidump($d); |
e49298ea | 128 | print $d eq $c ? |
e486a898 | 129 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; |
e49298ea JH |
130 | $test++; |
131 | } | |
132 | } | |
133 | ||
134 | 1; |