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 { |
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 |
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 |
62 | $test++; |
63 | } |
64 | |
65 | for my $i (sort { hex $a <=> hex $b } keys %$spec) { |
e486a898 |
66 | my $w = unidump($spec->{$i}); |
e49298ea |
67 | my $c = pack "U0U", hex $i; |
68 | my $d = $func->($c); |
e486a898 |
69 | my $e = unidump($d); |
0c23d0e0 |
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 |
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 |
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 |
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 |
120 | $test++; |
121 | } |
122 | |
e49298ea |
123 | for my $i (sort { $a <=> $b } keys %none) { |
e486a898 |
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 |
130 | $test++; |
131 | } |
132 | } |
133 | |
134 | 1; |