Commit | Line | Data |
---|---|---|
e49298ea JH |
1 | require "test.pl"; |
2 | ||
e486a898 JH |
3 | sub unidump { |
4 | join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; | |
5 | } | |
6 | ||
e49298ea | 7 | sub casetest { |
cc70200b | 8 | my ($already_run, $base, $spec, @funcs) = @_; |
2cb111f2 | 9 | # For each provided function run it, and run a version with some extra |
9b382af3 | 10 | # characters afterwards. Use a recycling symbol, as it doesn't change case. |
cc70200b KW |
11 | # $already_run is the number of extra tests the caller has run before this |
12 | # call. | |
2cb111f2 NC |
13 | my $ballast = chr (0x2672) x 3; |
14 | @funcs = map {my $f = $_; | |
15 | ($f, | |
16 | sub {my $r = $f->($_[0] . $ballast); # Add it before | |
17 | $r =~ s/$ballast\z//so # Remove it afterwards | |
18 | or die "'$_[0]' to '$r' mangled"; | |
19 | $r; # Result with $ballast removed. | |
20 | }, | |
21 | )} @funcs; | |
22 | ||
519ecd2c | 23 | my $file = "../lib/unicore/To/$base.pl"; |
e81465be | 24 | my $simple = do $file or die $@; |
e49298ea JH |
25 | my %simple; |
26 | for my $i (split(/\n/, $simple)) { | |
27 | my ($k, $v) = split(' ', $i); | |
28 | $simple{$k} = $v; | |
29 | } | |
30 | my %seen; | |
31 | ||
32 | for my $i (sort keys %simple) { | |
b08cf34e | 33 | $seen{$i}++; |
e49298ea JH |
34 | } |
35 | print "# ", scalar keys %simple, " simple mappings\n"; | |
36 | ||
37 | my $both; | |
38 | ||
39 | for my $i (sort keys %$spec) { | |
b08cf34e JH |
40 | if (++$seen{$i} == 2) { |
41 | warn sprintf "$base: $i seen twice\n"; | |
e49298ea JH |
42 | $both++; |
43 | } | |
44 | } | |
45 | print "# ", scalar keys %$spec, " special mappings\n"; | |
46 | ||
47 | exit(1) if $both; | |
48 | ||
49 | my %none; | |
50 | for my $i (map { ord } split //, | |
51 | "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { | |
52 | next if pack("U0U", $i) =~ /\w/; | |
53 | $none{$i}++ unless $seen{$i}; | |
54 | } | |
55 | print "# ", scalar keys %none, " noncase mappings\n"; | |
56 | ||
57 | my $tests = | |
cc70200b | 58 | $already_run + |
6f9b16a7 NC |
59 | ((scalar keys %simple) + |
60 | (scalar keys %$spec) + | |
61 | (scalar keys %none)) * @funcs; | |
e49298ea | 62 | |
cc70200b | 63 | my $test = $already_run + 1; |
e49298ea | 64 | |
b08cf34e | 65 | for my $i (sort keys %simple) { |
e486a898 | 66 | my $w = $simple{$i}; |
e49298ea | 67 | my $c = pack "U0U", hex $i; |
6f9b16a7 NC |
68 | foreach my $func (@funcs) { |
69 | my $d = $func->($c); | |
70 | my $e = unidump($d); | |
71 | print $d eq pack("U0U", hex $simple{$i}) ? | |
72 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; | |
73 | $test++; | |
74 | } | |
e49298ea JH |
75 | } |
76 | ||
b08cf34e | 77 | for my $i (sort keys %$spec) { |
e486a898 | 78 | my $w = unidump($spec->{$i}); |
250d67eb | 79 | if (ord('A') == 193 && $i eq "\x8A\x73") { |
9b382af3 | 80 | $w = '0178'; # It's a Latin small Y with diaeresis and not a Latin small letter sharp 's'. |
250d67eb | 81 | } |
08ca2aa3 | 82 | my $u = unpack "C0U", $i; |
b08cf34e JH |
83 | my $h = sprintf "%04X", $u; |
84 | my $c = chr($u); $c .= chr(0x100); chop $c; | |
6f9b16a7 NC |
85 | foreach my $func (@funcs) { |
86 | my $d = $func->($c); | |
87 | my $e = unidump($d); | |
88 | if (ord "A" == 193) { # EBCDIC | |
89 | # We need to a little bit of remapping. | |
90 | # | |
91 | # For example, in titlecase (ucfirst) mapping | |
92 | # of U+0149 the Unicode mapping is U+02BC U+004E. | |
93 | # The 4E is N, which in EBCDIC is 2B-- | |
94 | # and the ucfirst() does that right. | |
95 | # The problem is that our reference | |
96 | # data is in Unicode code points. | |
97 | # | |
98 | # The Right Way here would be to use, say, | |
99 | # Encode, to remap the less-than 0x100 code points, | |
100 | # but let's try to be Encode-independent here. | |
101 | # | |
102 | # These are the titlecase exceptions: | |
103 | # | |
104 | # Unicode Unicode+EBCDIC | |
105 | # | |
106 | # 0149 -> 02BC 004E (02BC 002B) | |
107 | # 01F0 -> 004A 030C (00A2 030C) | |
108 | # 1E96 -> 0048 0331 (00E7 0331) | |
109 | # 1E97 -> 0054 0308 (00E8 0308) | |
110 | # 1E98 -> 0057 030A (00EF 030A) | |
111 | # 1E99 -> 0059 030A (00DF 030A) | |
112 | # 1E9A -> 0041 02BE (00A0 02BE) | |
113 | # | |
114 | # The uppercase exceptions are identical. | |
115 | # | |
116 | # The lowercase has one more: | |
117 | # | |
118 | # Unicode Unicode+EBCDIC | |
119 | # | |
120 | # 0130 -> 0069 0307 (00D1 0307) | |
121 | # | |
250d67eb | 122 | if ($h =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { |
6f9b16a7 NC |
123 | $e =~ s/004E/002B/; # N |
124 | $e =~ s/004A/00A2/; # J | |
125 | $e =~ s/0048/00E7/; # H | |
126 | $e =~ s/0054/00E8/; # T | |
127 | $e =~ s/0057/00EF/; # W | |
128 | $e =~ s/0059/00DF/; # Y | |
129 | $e =~ s/0041/00A0/; # A | |
130 | $e =~ s/0069/00D1/; # i | |
131 | } | |
132 | # We have to map the output, not the input, because | |
133 | # pack/unpack U has been EBCDICified, too, it would | |
134 | # just undo our remapping. | |
0c23d0e0 | 135 | } |
6f9b16a7 NC |
136 | print $w eq $e ? |
137 | "ok $test # $i -> $w\n" : "not ok $test # $h -> $e ($w)\n"; | |
138 | $test++; | |
0c23d0e0 | 139 | } |
e49298ea JH |
140 | } |
141 | ||
e49298ea | 142 | for my $i (sort { $a <=> $b } keys %none) { |
e486a898 JH |
143 | my $w = $i = sprintf "%04X", $i; |
144 | my $c = pack "U0U", hex $i; | |
6f9b16a7 NC |
145 | foreach my $func (@funcs) { |
146 | my $d = $func->($c); | |
147 | my $e = unidump($d); | |
148 | print $d eq $c ? | |
149 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; | |
150 | $test++; | |
151 | } | |
e49298ea | 152 | } |
cc70200b KW |
153 | |
154 | print "1..$tests\n"; | |
e49298ea JH |
155 | } |
156 | ||
157 | 1; |