This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5db: add tests for v command
[perl5.git] / t / uni / case.pl
1 BEGIN {
2     require "./test.pl";
3     set_up_inc(qw(../lib .));
4     skip_all_without_unicode_tables();
5 }
6 use strict;
7 use warnings;
8 use feature 'unicode_strings';
9
10 sub unidump {
11     join "", map { sprintf "\\x{%04X}", $_ } unpack "W*", $_[0];
12 }
13
14 sub 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
129 1;