3 set_up_inc(qw(../lib .));
4 skip_all_without_unicode_tables();
8 use feature 'unicode_strings';
11 join "", map { sprintf "\\x{%04X}", $_ } unpack "W*", $_[0];
15 my ($already_run, $base, %funcs) = @_;
19 # For each provided function run it, and run a version with some extra
20 # characters afterwards. Use a recycling symbol, as it doesn't change case.
21 # $already_run is the number of extra tests the caller has run before this
23 my $ballast = chr (0x2672) x 3;
24 foreach my $name (keys %funcs) {
25 $funcs{"${name}_with_ballast"} =
26 sub {my $r = $funcs{$name}->($_[0] . $ballast); # Add it before
27 $r =~ s/$ballast\z//so # Remove it afterwards
28 or die "'$_[0]' to '$r' mangled";
29 $r; # Result with $ballast removed.
33 use Unicode::UCD 'prop_invmap';
35 # Get the case mappings
36 my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base);
39 for my $i (0 .. @$invlist_ref - 1 - 1) {
40 next if $invmap_ref->[$i] == $default;
42 # Add simple mappings to the simples test list
43 if (! ref $invmap_ref->[$i]) {
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
49 for my $k ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) {
50 $simple{$k} = $invmap_ref->[$i] + $adjust++;
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.
56 $spec{$invlist_ref->[$i]} = pack "W*" , @{$invmap_ref->[$i]};
62 for my $i (sort keys %simple) {
65 print "# ", scalar keys %simple, " simple mappings\n";
67 for my $i (sort keys %spec) {
68 if (++$seen{$i} == 2) {
69 warn sprintf "$base: $i seen twice\n";
72 print "# ", scalar keys %spec, " special mappings\n";
75 for my $i (map { ord } split //,
76 "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") {
77 next if pack("W", $i) =~ /\w/;
78 $none{$i}++ unless $seen{$i};
80 print "# ", scalar keys %none, " noncase mappings\n";
83 my $test = $already_run + 1;
85 for my $ord (sort keys %simple) {
86 my $char = pack "W", $ord;
87 my $disp_input = unidump($char);
89 my $expected = pack("W", $simple{$ord});
90 my $disp_expected = unidump($expected);
92 foreach my $name (sort keys %funcs) {
93 my $got = $funcs{$name}->($char);
95 "Verify $name(\"$disp_input\") eq \"$disp_expected\"");
99 for my $ord (sort keys %spec) {
100 my $char = pack "W", $ord;
101 my $disp_input = unidump($char);
103 my $expected = unidump($spec{$ord});
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\"");
112 for my $ord (sort { $a <=> $b } keys %none) {
113 my $char = pack "W", $ord;
114 my $disp_input = unidump($char);
116 foreach my $name (sort keys %funcs) {
117 my $got = $funcs{$name}->($char);
119 "Verify $name(\"$disp_input\") eq \"$disp_input\"");
124 ((scalar keys %simple) +
125 (scalar keys %spec) +
126 (scalar keys %none)) * scalar keys %funcs;