Commit | Line | Data |
00f254e2 |
1 | use warnings; |
2 | use strict; |
3 | |
4 | BEGIN { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | require './test.pl'; |
8 | } |
9 | |
10 | #use Test::More; |
11 | |
12 | #plan("no_plan"); |
13 | plan(13312); |
14 | |
15 | # First compute the case mappings without resorting to the functions we're |
16 | # testing. |
17 | |
18 | # Initialize the arrays so each $i maps to itself. |
19 | my @posix_to_upper; |
20 | for my $i (0 .. 255) { |
21 | $posix_to_upper[$i] = chr($i); |
22 | } |
23 | my @posix_to_lower |
24 | = my @posix_to_title |
25 | = my @latin1_to_upper |
26 | = my @latin1_to_lower |
27 | = my @latin1_to_title |
28 | = @posix_to_upper; |
29 | |
30 | # Override the elements in the to_lower arrays that have different lower case |
31 | # mappings with those mappings. |
32 | for my $i (0x41 .. 0x5A) { |
33 | $posix_to_lower[$i] = chr(ord($posix_to_lower[$i]) + 32); |
34 | $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32); |
35 | } |
36 | |
37 | # Same for upper and title |
38 | for my $i (0x61 .. 0x7A) { |
39 | $posix_to_upper[$i] = chr(ord($posix_to_upper[$i]) - 32); |
40 | $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32); |
41 | $posix_to_title[$i] = chr(ord($posix_to_title[$i]) - 32); |
42 | $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32); |
43 | } |
44 | |
45 | # And the same for those in the latin1 range |
46 | for my $i (0xC0 .. 0xD6, 0xD8 .. 0xDE) { |
47 | $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32); |
48 | } |
49 | for my $i (0xE0 .. 0xF6, 0xF8 .. 0xFE) { |
50 | $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32); |
51 | $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32); |
52 | } |
53 | |
54 | # Override the abnormal cases. |
55 | $latin1_to_upper[0xB5] = chr(0x39C); |
56 | $latin1_to_title[0xB5] = chr(0x39C); |
57 | $latin1_to_upper[0xDF] = 'SS'; |
58 | $latin1_to_title[0xDF] = 'Ss'; |
59 | $latin1_to_upper[0xFF] = chr(0x178); |
60 | $latin1_to_title[0xFF] = chr(0x178); |
61 | |
62 | my $repeat = 25; # Length to make strings. |
63 | |
64 | # Create hashes of strings in several ranges, both for uc and lc. |
65 | my %posix; |
66 | $posix{'uc'} = 'A' x $repeat; |
67 | $posix{'lc'} = 'a' x $repeat ; |
68 | |
69 | my %cyrillic; |
70 | $cyrillic{'uc'} = chr(0x42F) x $repeat; |
71 | $cyrillic{'lc'} = chr(0x44F) x $repeat; |
72 | |
73 | my %latin1; |
74 | $latin1{'uc'} = chr(0xD8) x $repeat; |
75 | $latin1{'lc'} = chr(0xF8) x $repeat; |
76 | |
77 | my %empty; |
78 | $empty{'lc'} = $empty{'uc'} = ""; |
79 | |
80 | # Loop so prefix each character being tested with nothing, and the various |
81 | # strings; then loop for suffixes of those strings as well. |
82 | for my $prefix (\%empty, \%posix, \%cyrillic, \%latin1) { |
83 | for my $suffix (\%empty, \%posix, \%cyrillic, \%latin1) { |
84 | for my $i (0 .. 255) { # For each possible posix or latin1 character |
85 | my $cp = sprintf "%02X", $i; |
86 | |
87 | # First try using latin1 (Unicode) semantics. |
88 | no legacy "unicode8bit"; |
89 | |
90 | my $phrase = 'with unicode'; |
91 | my $char = chr($i); |
92 | my $pre_lc = $prefix->{'lc'}; |
93 | my $pre_uc = $prefix->{'uc'}; |
94 | my $post_lc = $suffix->{'lc'}; |
95 | my $post_uc = $suffix->{'uc'}; |
96 | my $to_upper = $pre_lc . $char . $post_lc; |
97 | my $expected_upper = $pre_uc . $latin1_to_upper[$i] . $post_uc; |
98 | my $to_lower = $pre_uc . $char . $post_uc; |
99 | my $expected_lower = $pre_lc . $latin1_to_lower[$i] . $post_lc; |
100 | |
101 | is (uc($to_upper), $expected_upper, |
102 | |
103 | # The names are commented out for now to avoid 'wide character |
104 | # in print' messages. |
105 | ); #"$cp: $phrase: uc('$to_upper') eq '$expected_upper'"); |
106 | is (lc($to_lower), $expected_lower, |
107 | ); #"$cp: $phrase: lc('$to_lower') eq '$expected_lower'"); |
108 | |
109 | if ($pre_uc eq "") { # Title case if null prefix. |
110 | my $expected_title = $latin1_to_title[$i] . $post_lc; |
111 | is (ucfirst($to_upper), $expected_title, |
112 | ); #"$cp: $phrase: ucfirst('$to_upper') eq '$expected_title'"); |
113 | my $expected_lcfirst = $latin1_to_lower[$i] . $post_uc; |
114 | is (lcfirst($to_lower), $expected_lcfirst, |
115 | ); #"$cp: $phrase: lcfirst('$to_lower') eq '$expected_lcfirst'"); |
116 | } |
117 | |
118 | # Then try with posix semantics. |
119 | use legacy "unicode8bit"; |
120 | $phrase = 'no unicode'; |
121 | |
122 | # These don't contribute anything in this case. |
123 | next if $suffix == \%cyrillic; |
124 | next if $suffix == \%latin1; |
125 | next if $prefix == \%cyrillic; |
126 | next if $prefix == \%latin1; |
127 | |
128 | $expected_upper = $pre_uc . $posix_to_upper[$i] . $post_uc; |
129 | $expected_lower = $pre_lc . $posix_to_lower[$i] . $post_lc; |
130 | |
131 | is (uc($to_upper), $expected_upper, |
132 | ); #"$cp: $phrase: uc('$to_upper') eq '$expected_upper'"); |
133 | is (lc($to_lower), $expected_lower, |
134 | ); #"$cp: $phrase: lc('$to_lower') eq '$expected_lower'"); |
135 | |
136 | if ($pre_uc eq "") { |
137 | my $expected_title = $posix_to_title[$i] . $post_lc; |
138 | is (ucfirst($to_upper), $expected_title, |
139 | ); #"$cp: $phrase: ucfirst('$to_upper') eq '$expected_title'"); |
140 | my $expected_lcfirst = $posix_to_lower[$i] . $post_uc; |
141 | is (lcfirst($to_lower), $expected_lcfirst, |
142 | ); #"$cp: $phrase: lcfirst('$to_lower') eq '$expected_lcfirst'"); |
143 | } |
144 | } |
145 | } |
146 | } |