1use File::Spec; 2 3require "test.pl"; 4 5sub unidump { 6 join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; 7} 8 9sub casetest { 10 my ($base, $spec, $func) = @_; 11 my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, 12 "lib", "unicore", "To"), 13 "$base.pl"); 14 my $simple = do $file; 15 my %simple; 16 for my $i (split(/\n/, $simple)) { 17 my ($k, $v) = split(' ', $i); 18 $simple{$k} = $v; 19 } 20 my %seen; 21 22 for my $i (sort keys %simple) { 23 $seen{$i}++; 24 } 25 print "# ", scalar keys %simple, " simple mappings\n"; 26 27 my $both; 28 29 for my $i (sort keys %$spec) { 30 if (++$seen{$i} == 2) { 31 warn sprintf "$base: $i seen twice\n"; 32 $both++; 33 } 34 } 35 print "# ", scalar keys %$spec, " special mappings\n"; 36 37 exit(1) if $both; 38 39 my %none; 40 for my $i (map { ord } split //, 41 "\e !\"#\$%&'()+,-./0123456789:;<=>?\@[\\]^_{|}~\b") { 42 next if pack("U0U", $i) =~ /\w/; 43 $none{$i}++ unless $seen{$i}; 44 } 45 print "# ", scalar keys %none, " noncase mappings\n"; 46 47 my $tests = 48 (scalar keys %simple) + 49 (scalar keys %$spec) + 50 (scalar keys %none); 51 print "1..$tests\n"; 52 53 my $test = 1; 54 55 for my $i (sort keys %simple) { 56 my $w = $simple{$i}; 57 my $c = pack "U0U", hex $i; 58 my $d = $func->($c); 59 my $e = unidump($d); 60 print $d eq pack("U0U", hex $simple{$i}) ? 61 "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; 62 $test++; 63 } 64 65 for my $i (sort keys %$spec) { 66 my $w = unidump($spec->{$i}); 67 my $u = unpack "U0U", $i; 68 my $h = sprintf "%04X", $u; 69 my $c = chr($u); $c .= chr(0x100); chop $c; 70 my $d = $func->($c); 71 my $e = unidump($d); 72 if (ord "A" == 193) { # EBCDIC 73 # We need to a little bit of remapping. 74 # 75 # For example, in titlecase (ucfirst) mapping 76 # of U+0149 the Unicode mapping is U+02BC U+004E. 77 # The 4E is N, which in EBCDIC is 2B-- 78 # and the ucfirst() does that right. 79 # The problem is that our reference 80 # data is in Unicode code points. 81 # 82 # The Right Way here would be to use, say, 83 # Encode, to remap the less-than 0x100 code points, 84 # but let's try to be Encode-independent here. 85 # 86 # These are the titlecase exceptions: 87 # 88 # Unicode Unicode+EBCDIC 89 # 90 # 0149 -> 02BC 004E (02BC 002B) 91 # 01F0 -> 004A 030C (00A2 030C) 92 # 1E96 -> 0048 0331 (00E7 0331) 93 # 1E97 -> 0054 0308 (00E8 0308) 94 # 1E98 -> 0057 030A (00EF 030A) 95 # 1E99 -> 0059 030A (00DF 030A) 96 # 1E9A -> 0041 02BE (00A0 02BE) 97 # 98 # The uppercase exceptions are identical. 99 # 100 # The lowercase has one more: 101 # 102 # Unicode Unicode+EBCDIC 103 # 104 # 0130 -> 0069 0307 (00D1 0307) 105 # 106 if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { 107 $e =~ s/004E/002B/; # N 108 $e =~ s/004A/00A2/; # J 109 $e =~ s/0048/00E7/; # H 110 $e =~ s/0054/00E8/; # T 111 $e =~ s/0057/00EF/; # W 112 $e =~ s/0059/00DF/; # Y 113 $e =~ s/0041/00A0/; # A 114 $e =~ s/0069/00D1/; # i 115 } 116 # We have to map the output, not the input, because 117 # pack/unpack U has been EBCDICified, too, it would 118 # just undo our remapping. 119 } 120 print $w eq $e ? 121 "ok $test # $i -> $w\n" : "not ok $test # $h -> $e ($w)\n"; 122 $test++; 123 } 124 125 for my $i (sort { $a <=> $b } keys %none) { 126 my $w = $i = sprintf "%04X", $i; 127 my $c = pack "U0U", hex $i; 128 my $d = $func->($c); 129 my $e = unidump($d); 130 print $d eq $c ? 131 "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; 132 $test++; 133 } 134} 135 1361; 137