10 $_ = "abcdefghijklmnopqrstuvwxyz";
14 print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
19 print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
24 print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
27 # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
28 # Yes, discontinuities. Regardless, the \xca in the below should stay
29 # untouched (and not became \x8a).
36 print "not " unless $_ eq "i\xcaj";
41 # make sure that tr cancels IOK and NOK
43 (my $y = 12) =~ tr/1/3/;
44 ($f = 1.5) =~ tr/1/3/;
45 (my $g = 1.5) =~ tr/1/3/;
46 print "not " unless $x + $y + $f + $g == 71;
49 # make sure tr is harmless if not updating - see [ID 20000511.005]
54 print "not " if $_ ne 'Fred';
57 # check tr handles UTF8 correctly
58 ($x = 256.65.258) =~ tr/a/b/;
59 print "not " if $x ne 256.65.258 or length $x != 3;
62 if (ord("\t") == 9) { # ASCII
63 print "not " if $x ne 256.66.258 or length $x != 3;
66 print "not " if $x ne 256.65.258 or length $x != 3;
69 # EBCDIC variants of the above tests
70 ($x = 256.193.258) =~ tr/a/b/;
71 print "not " if $x ne 256.193.258 or length $x != 3;
74 if (ord("\t") == 9) { # ASCII
75 print "not " if $x ne 256.193.258 or length $x != 3;
78 print "not " if $x ne 256.194.258 or length $x != 3;
83 if (ord("\t") == 9) { # ASCII
86 # 11 - changing UTF8 characters in a UTF8 string, same length.
87 my $l = chr(300); my $r = chr(400);
89 $x =~ tr/\x{12c}/\x{190}/;
90 printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
93 # 12 - changing UTF8 characters in UTF8 string, more bytes.
95 $x =~ tr/\x{12c}/\x{be8}/;
96 printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
99 # 13 - introducing UTF8 characters to non-UTF8 string.
101 $x =~ tr/\x{64}/\x{190}/;
102 printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
105 # 14 - removing UTF8 characters from UTF8 string
107 $x =~ tr/\x{190}/\x{64}/;
108 printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
111 # 15 - counting UTF8 chars in UTF8 string
113 $y = $x =~ tr/\x{190}/\x{190}/;
114 print "not " if $y != 2;
117 # 16 - counting non-UTF8 chars in UTF8 string
118 $x = 60.400.125.60.400;
119 $y = $x =~ tr/\x{3c}/\x{3c}/;
120 print "not " if $y != 2;
123 # 17 - counting UTF8 chars in non-UTF8 string
125 $y = $x =~ tr/\x{190}/\x{190}/;
126 print "not " if $y != 0;
130 # 18: test brokenness with tr/a-z-9//;
131 $_ = "abcdefghijklmnopqrstuvwxyz";
133 print (($@ =~ /^Ambiguous range in transliteration operator/)
134 ? '' : 'not ', "ok 18\n");
136 # 19-21: Make sure leading and trailing hyphens still work
139 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
143 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
147 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
149 $_ = "abcdefghijklmnop";
151 print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
153 $_ = "abcdefghijklmnop";
155 print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
157 $_ = "abcdefghijklmnop";
159 print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
161 # 25: Test reversed range check
164 print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/)
165 ? '' : 'not ', "ok 25\n");
167 # 26: test cannot update if read-only
168 eval '$1 =~ tr/x/y/';
169 print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
172 # 27: test can count read-only
174 print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
176 # 28: test lhs OK if not updating
177 print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
179 # 29: test lhs bad if updating
180 eval '"123" =~ tr/1/1/';
181 print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
182 ? '' : 'not ', "ok 29\n");
184 # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
185 # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
187 # Transliterate a byte to a byte, all four ways.
189 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
190 print "not " unless $a eq v300.197.172.300.197.172;
193 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
194 print "not " unless $a eq v300.197.172.300.197.172;
197 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
198 print "not " unless $a eq v300.197.172.300.197.172;
201 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
202 print "not " unless $a eq v300.197.172.300.197.172;
205 # Transliterate a byte to a wide character.
207 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
208 print "not " unless $a eq v300.301.172.300.301.172;
211 # Transliterate a wide character to a byte.
213 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
214 print "not " unless $a eq v195.196.172.195.196.172;
217 # Transliterate a wide character to a wide character.
219 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
220 print "not " unless $a eq v301.196.172.301.196.172;
223 # Transliterate both ways.
225 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
226 print "not " unless $a eq v195.301.172.195.301.172;
229 # Transliterate all (four) ways.
231 ($a = v300.196.172.300.196.172.400.198.144) =~
232 tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
233 print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
236 # Transliterate and count.
239 unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2;
243 unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
246 # Transliterate with complement.
248 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
249 print "not " unless $a eq v301.196.301.301.196.301;
252 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
253 print "not " unless $a eq v300.197.197.300.197.197;
256 # Transliterate with deletion.
258 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
259 print "not " unless $a eq v300.172.300.172;
262 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
263 print "not " unless $a eq v196.172.196.172;
266 # Transliterate with squeeze.
268 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
269 print "not " unless $a eq v197.172.300.300.197.172;
272 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
273 print "not " unless $a eq v196.172.301.196.172.172;
276 # Tricky cases by Simon Cozens.
278 ($a = v196.172.200) =~ tr/\x{12c}/a/;
279 print "not " unless sprintf("%vd", $a) eq '196.172.200';
282 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
283 print "not " unless sprintf("%vd", $a) eq '196.172.200';
286 ($a = v196.172.200) =~ tr/\x{12c}//d;
287 print "not " unless sprintf("%vd", $a) eq '196.172.200';
290 # UTF8 range tests from Inaba Hiroto
292 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
293 print "not " unless $a eq v192.196.172.194.197.172;
296 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
297 print "not " unless $a eq v300.300.172.302.301.172;
300 # UTF8 range tests from Karsten Sperling (patch #9008 required)
302 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
303 print "not " unless $a eq "X";
306 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
307 print "not " unless $a eq "X";
310 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
311 print "not " unless $a eq "X";
314 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
315 print "not " unless $a eq "X";
318 # UTF8 range tests from Inaba Hiroto
320 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
321 print "not " unless $a eq "X";
324 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
325 print "not " unless $a eq "X";
328 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
329 # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
330 # from Karsten Sperling.
332 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
333 print "not " unless $c == 8 and $a eq "XXXXXXXX";
336 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
337 print "not " unless $c == 8 and $a eq "XXXXXXXX";
340 if (ord('i') == 0x89 & ord('J') == 0xd1) {
342 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
343 print "not " unless $c == 2 and $a eq "X\x8a\x8b\x8c\x8d\x8f\x90X";
346 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
347 print "not " unless $c == 2 and $a eq "X\xca\xcb\xcc\xcd\xcf\xd0X";
351 for (60..61) { print "ok $_ # Skip: not EBCDIC\n" }
354 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
355 print "not " unless ord($a) == ord("X");
358 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
359 print "not " unless ord($a) == ord("X");
362 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
363 print "not " unless $a eq "\x{100}\x{100}";
366 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
367 print "not " unless $a eq "\x{100}";
370 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
371 print "not " unless $a eq "\x{1ff}\x{1fe}";