Commit | Line | Data |
---|---|---|
c8191e19 | 1 | BEGIN { |
624c42e2 | 2 | require "./test.pl"; |
c8191e19 | 3 | set_up_inc(qw(../lib .)); |
5820e6f9 | 4 | skip_all_without_unicode_tables(); |
c8191e19 | 5 | } |
83e3658b KW |
6 | use strict; |
7 | use warnings; | |
61900f46 | 8 | use feature 'unicode_strings'; |
e49298ea | 9 | |
e486a898 | 10 | sub unidump { |
61900f46 | 11 | join "", map { sprintf "\\x{%04X}", $_ } unpack "W*", $_[0]; |
e486a898 JH |
12 | } |
13 | ||
e49298ea | 14 | sub casetest { |
227e818e | 15 | my ($already_run, $base, %funcs) = @_; |
2d6d4018 KW |
16 | |
17 | my %spec; | |
18 | ||
2cb111f2 | 19 | # For each provided function run it, and run a version with some extra |
9b382af3 | 20 | # characters afterwards. Use a recycling symbol, as it doesn't change case. |
cc70200b KW |
21 | # $already_run is the number of extra tests the caller has run before this |
22 | # call. | |
2cb111f2 | 23 | my $ballast = chr (0x2672) x 3; |
227e818e KW |
24 | foreach my $name (keys %funcs) { |
25 | $funcs{"${name}_with_ballast"} = | |
26 | sub {my $r = $funcs{$name}->($_[0] . $ballast); # Add it before | |
2cb111f2 NC |
27 | $r =~ s/$ballast\z//so # Remove it afterwards |
28 | or die "'$_[0]' to '$r' mangled"; | |
29 | $r; # Result with $ballast removed. | |
227e818e KW |
30 | }; |
31 | } | |
2cb111f2 | 32 | |
2d6d4018 KW |
33 | use Unicode::UCD 'prop_invmap'; |
34 | ||
35 | # Get the case mappings | |
36 | my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base); | |
e49298ea | 37 | my %simple; |
2d6d4018 KW |
38 | |
39 | for my $i (0 .. @$invlist_ref - 1 - 1) { | |
40 | next if $invmap_ref->[$i] == $default; | |
41 | ||
42 | # Add simple mappings to the simples test list | |
43 | if (! ref $invmap_ref->[$i]) { | |
44 | ||
45 | # The returned map needs to have adjustments made. Each | |
46 | # subsequent element of the range requires adjustment of +1 from | |
47 | # the previous element | |
48 | my $adjust = 0; | |
49 | for my $k ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) { | |
50 | $simple{$k} = $invmap_ref->[$i] + $adjust++; | |
51 | } | |
52 | } | |
53 | else { # The return is a list of the characters mapped-to. | |
54 | # prop_invmap() guarantees a single element in the range in | |
55 | # this case, so no adjustments are needed. | |
61900f46 | 56 | $spec{$invlist_ref->[$i]} = pack "W*" , @{$invmap_ref->[$i]}; |
2d6d4018 | 57 | } |
e49298ea | 58 | } |
2d6d4018 | 59 | |
e49298ea JH |
60 | my %seen; |
61 | ||
62 | for my $i (sort keys %simple) { | |
b08cf34e | 63 | $seen{$i}++; |
e49298ea JH |
64 | } |
65 | print "# ", scalar keys %simple, " simple mappings\n"; | |
66 | ||
2d6d4018 | 67 | for my $i (sort keys %spec) { |
b08cf34e JH |
68 | if (++$seen{$i} == 2) { |
69 | warn sprintf "$base: $i seen twice\n"; | |
e49298ea JH |
70 | } |
71 | } | |
2d6d4018 | 72 | print "# ", scalar keys %spec, " special mappings\n"; |
e49298ea JH |
73 | |
74 | my %none; | |
75 | for my $i (map { ord } split //, | |
76 | "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { | |
61900f46 | 77 | next if pack("W", $i) =~ /\w/; |
e49298ea JH |
78 | $none{$i}++ unless $seen{$i}; |
79 | } | |
80 | print "# ", scalar keys %none, " noncase mappings\n"; | |
81 | ||
e49298ea | 82 | |
cc70200b | 83 | my $test = $already_run + 1; |
e49298ea | 84 | |
08cb077e | 85 | for my $ord (sort { $a <=> $b } keys %simple) { |
61900f46 | 86 | my $char = pack "W", $ord; |
227e818e KW |
87 | my $disp_input = unidump($char); |
88 | ||
61900f46 | 89 | my $expected = pack("W", $simple{$ord}); |
227e818e KW |
90 | my $disp_expected = unidump($expected); |
91 | ||
92 | foreach my $name (sort keys %funcs) { | |
93 | my $got = $funcs{$name}->($char); | |
94 | is( $got, $expected, | |
95 | "Verify $name(\"$disp_input\") eq \"$disp_expected\""); | |
6f9b16a7 | 96 | } |
e49298ea JH |
97 | } |
98 | ||
08cb077e | 99 | for my $ord (sort { $a <=> $b } keys %spec) { |
61900f46 | 100 | my $char = pack "W", $ord; |
227e818e KW |
101 | my $disp_input = unidump($char); |
102 | ||
103 | my $expected = unidump($spec{$ord}); | |
104 | ||
105 | foreach my $name (sort keys %funcs) { | |
106 | my $got = $funcs{$name}->($char); | |
107 | is( unidump($got), $expected, | |
108 | "Verify $name(\"$disp_input\") eq \"$expected\""); | |
0c23d0e0 | 109 | } |
e49298ea JH |
110 | } |
111 | ||
227e818e | 112 | for my $ord (sort { $a <=> $b } keys %none) { |
61900f46 | 113 | my $char = pack "W", $ord; |
227e818e KW |
114 | my $disp_input = unidump($char); |
115 | ||
116 | foreach my $name (sort keys %funcs) { | |
117 | my $got = $funcs{$name}->($char); | |
118 | is( $got, $char, | |
119 | "Verify $name(\"$disp_input\") eq \"$disp_input\""); | |
6f9b16a7 | 120 | } |
e49298ea | 121 | } |
cc70200b | 122 | |
d2579e9a KW |
123 | plan $already_run + |
124 | ((scalar keys %simple) + | |
125 | (scalar keys %spec) + | |
227e818e | 126 | (scalar keys %none)) * scalar keys %funcs; |
e49298ea JH |
127 | } |
128 | ||
129 | 1; |