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) = @_; |
e49298ea |
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) { |
b08cf34e |
23 | $seen{$i}++; |
e49298ea |
24 | } |
25 | print "# ", scalar keys %simple, " simple mappings\n"; |
26 | |
27 | my $both; |
28 | |
29 | for my $i (sort keys %$spec) { |
b08cf34e |
30 | if (++$seen{$i} == 2) { |
31 | warn sprintf "$base: $i seen twice\n"; |
e49298ea |
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 = |
6f9b16a7 |
48 | ((scalar keys %simple) + |
49 | (scalar keys %$spec) + |
50 | (scalar keys %none)) * @funcs; |
e49298ea |
51 | print "1..$tests\n"; |
52 | |
53 | my $test = 1; |
54 | |
b08cf34e |
55 | for my $i (sort keys %simple) { |
e486a898 |
56 | my $w = $simple{$i}; |
e49298ea |
57 | my $c = pack "U0U", hex $i; |
6f9b16a7 |
58 | foreach my $func (@funcs) { |
59 | my $d = $func->($c); |
60 | my $e = unidump($d); |
61 | print $d eq pack("U0U", hex $simple{$i}) ? |
62 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; |
63 | $test++; |
64 | } |
e49298ea |
65 | } |
66 | |
b08cf34e |
67 | for my $i (sort keys %$spec) { |
e486a898 |
68 | my $w = unidump($spec->{$i}); |
08ca2aa3 |
69 | my $u = unpack "C0U", $i; |
b08cf34e |
70 | my $h = sprintf "%04X", $u; |
71 | my $c = chr($u); $c .= chr(0x100); chop $c; |
6f9b16a7 |
72 | foreach my $func (@funcs) { |
73 | my $d = $func->($c); |
74 | my $e = unidump($d); |
75 | if (ord "A" == 193) { # EBCDIC |
76 | # We need to a little bit of remapping. |
77 | # |
78 | # For example, in titlecase (ucfirst) mapping |
79 | # of U+0149 the Unicode mapping is U+02BC U+004E. |
80 | # The 4E is N, which in EBCDIC is 2B-- |
81 | # and the ucfirst() does that right. |
82 | # The problem is that our reference |
83 | # data is in Unicode code points. |
84 | # |
85 | # The Right Way here would be to use, say, |
86 | # Encode, to remap the less-than 0x100 code points, |
87 | # but let's try to be Encode-independent here. |
88 | # |
89 | # These are the titlecase exceptions: |
90 | # |
91 | # Unicode Unicode+EBCDIC |
92 | # |
93 | # 0149 -> 02BC 004E (02BC 002B) |
94 | # 01F0 -> 004A 030C (00A2 030C) |
95 | # 1E96 -> 0048 0331 (00E7 0331) |
96 | # 1E97 -> 0054 0308 (00E8 0308) |
97 | # 1E98 -> 0057 030A (00EF 030A) |
98 | # 1E99 -> 0059 030A (00DF 030A) |
99 | # 1E9A -> 0041 02BE (00A0 02BE) |
100 | # |
101 | # The uppercase exceptions are identical. |
102 | # |
103 | # The lowercase has one more: |
104 | # |
105 | # Unicode Unicode+EBCDIC |
106 | # |
107 | # 0130 -> 0069 0307 (00D1 0307) |
108 | # |
109 | if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { |
110 | $e =~ s/004E/002B/; # N |
111 | $e =~ s/004A/00A2/; # J |
112 | $e =~ s/0048/00E7/; # H |
113 | $e =~ s/0054/00E8/; # T |
114 | $e =~ s/0057/00EF/; # W |
115 | $e =~ s/0059/00DF/; # Y |
116 | $e =~ s/0041/00A0/; # A |
117 | $e =~ s/0069/00D1/; # i |
118 | } |
119 | # We have to map the output, not the input, because |
120 | # pack/unpack U has been EBCDICified, too, it would |
121 | # just undo our remapping. |
0c23d0e0 |
122 | } |
6f9b16a7 |
123 | print $w eq $e ? |
124 | "ok $test # $i -> $w\n" : "not ok $test # $h -> $e ($w)\n"; |
125 | $test++; |
0c23d0e0 |
126 | } |
e49298ea |
127 | } |
128 | |
e49298ea |
129 | for my $i (sort { $a <=> $b } keys %none) { |
e486a898 |
130 | my $w = $i = sprintf "%04X", $i; |
131 | my $c = pack "U0U", hex $i; |
6f9b16a7 |
132 | foreach my $func (@funcs) { |
133 | my $d = $func->($c); |
134 | my $e = unidump($d); |
135 | print $d eq $c ? |
136 | "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; |
137 | $test++; |
138 | } |
e49298ea |
139 | } |
140 | } |
141 | |
142 | 1; |