1BEGIN {
2    require "./test.pl";
3    set_up_inc(qw(../lib .));
4    skip_all_without_unicode_tables();
5}
6use strict;
7use warnings;
8use feature 'unicode_strings';
9
10sub unidump {
11    join "", map { sprintf "\\x{%04X}", $_ } unpack "W*", $_[0];
12}
13
14sub casetest {
15    my ($already_run, $base, %funcs) = @_;
16
17    my %spec;
18
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
22    # call.
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.
30		    };
31    }
32
33    use Unicode::UCD 'prop_invmap';
34
35    # Get the case mappings
36    my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base);
37    my %simple;
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.
56            $spec{$invlist_ref->[$i]} = pack "W*" , @{$invmap_ref->[$i]};
57        }
58    }
59
60    my %seen;
61
62    for my $i (sort keys %simple) {
63	$seen{$i}++;
64    }
65    print "# ", scalar keys %simple, " simple mappings\n";
66
67    for my $i (sort keys %spec) {
68	if (++$seen{$i} == 2) {
69	    warn sprintf "$base: $i seen twice\n";
70	}
71    }
72    print "# ", scalar keys %spec, " special mappings\n";
73
74    my %none;
75    for my $i (map { ord } split //,
76	       "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") {
77	next if pack("W", $i) =~ /\w/;
78	$none{$i}++ unless $seen{$i};
79    }
80    print "# ", scalar keys %none, " noncase mappings\n";
81
82
83    my $test = $already_run + 1;
84
85    for my $ord (sort { $a <=> $b } keys %simple) {
86	my $char = pack "W", $ord;
87        my $disp_input = unidump($char);
88
89        my $expected = pack("W", $simple{$ord});
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\"");
96	}
97    }
98
99    for my $ord (sort { $a <=> $b } keys %spec) {
100	my $char = pack "W", $ord;
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\"");
109	}
110    }
111
112    for my $ord (sort { $a <=> $b } keys %none) {
113	my $char = pack "W", $ord;
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\"");
120	}
121    }
122
123    plan $already_run +
124	((scalar keys %simple) +
125	 (scalar keys %spec) +
126	 (scalar keys %none)) * scalar keys %funcs;
127}
128
1291;
130