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;