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