1require "test.pl"; 2use strict; 3use warnings; 4 5sub unidump { 6 join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; 7} 8 9sub casetest { 10 my ($already_run, $base, @funcs) = @_; 11 12 my %spec; 13 14 # For each provided function run it, and run a version with some extra 15 # characters afterwards. Use a recycling symbol, as it doesn't change case. 16 # $already_run is the number of extra tests the caller has run before this 17 # call. 18 my $ballast = chr (0x2672) x 3; 19 @funcs = map {my $f = $_; 20 ($f, 21 sub {my $r = $f->($_[0] . $ballast); # Add it before 22 $r =~ s/$ballast\z//so # Remove it afterwards 23 or die "'$_[0]' to '$r' mangled"; 24 $r; # Result with $ballast removed. 25 }, 26 )} @funcs; 27 28 use Unicode::UCD 'prop_invmap'; 29 30 # Get the case mappings 31 my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base); 32 my %simple; 33 34 for my $i (0 .. @$invlist_ref - 1 - 1) { 35 next if $invmap_ref->[$i] == $default; 36 37 # Add simple mappings to the simples test list 38 if (! ref $invmap_ref->[$i]) { 39 40 # The returned map needs to have adjustments made. Each 41 # subsequent element of the range requires adjustment of +1 from 42 # the previous element 43 my $adjust = 0; 44 for my $k ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) { 45 $simple{$k} = $invmap_ref->[$i] + $adjust++; 46 } 47 } 48 else { # The return is a list of the characters mapped-to. 49 # prop_invmap() guarantees a single element in the range in 50 # this case, so no adjustments are needed. 51 $spec{$invlist_ref->[$i]} = pack "U0U*" , @{$invmap_ref->[$i]}; 52 } 53 } 54 55 my %seen; 56 57 for my $i (sort keys %simple) { 58 $seen{$i}++; 59 } 60 print "# ", scalar keys %simple, " simple mappings\n"; 61 62 for my $i (sort keys %spec) { 63 if (++$seen{$i} == 2) { 64 warn sprintf "$base: $i seen twice\n"; 65 } 66 } 67 print "# ", scalar keys %spec, " special mappings\n"; 68 69 my %none; 70 for my $i (map { ord } split //, 71 "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { 72 next if pack("U0U", $i) =~ /\w/; 73 $none{$i}++ unless $seen{$i}; 74 } 75 print "# ", scalar keys %none, " noncase mappings\n"; 76 77 my $tests = 78 $already_run + 79 ((scalar keys %simple) + 80 (scalar keys %spec) + 81 (scalar keys %none)) * @funcs; 82 83 my $test = $already_run + 1; 84 85 for my $i (sort keys %simple) { 86 my $w = $simple{$i}; 87 my $c = pack "U0U", $i; 88 foreach my $func (@funcs) { 89 my $d = $func->($c); 90 my $e = unidump($d); 91 is( $d, pack("U0U", $simple{$i}), "$i -> $e ($w)" ); 92 } 93 } 94 95 for my $i (sort keys %spec) { 96 my $w = unidump($spec{$i}); 97 my $h = sprintf "%04X", $i; 98 my $c = chr($i); $c .= chr(0x100); chop $c; 99 foreach my $func (@funcs) { 100 my $d = $func->($c); 101 my $e = unidump($d); 102 is( $w, $e, "$h -> $e ($w)" ); 103 } 104 } 105 106 for my $i (sort { $a <=> $b } keys %none) { 107 my $c = pack "U0U", $i; 108 my $w = $i = sprintf "%04X", $i; 109 foreach my $func (@funcs) { 110 my $d = $func->($c); 111 my $e = unidump($d); 112 is( $d, $c, "$i -> $e ($w)" ); 113 } 114 } 115 116 done_testing(); 117} 118 1191; 120