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