case.pl revision 1.2
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