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 # 11 - changing UTF8 characters in a UTF8 string, same length.
84 my $l = chr(300); my $r = chr(400);
86 $x =~ tr/\x{12c}/\x{190}/;
87 printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
90 # 12 - changing UTF8 characters in UTF8 string, more bytes.
92 $x =~ tr/\x{12c}/\x{be8}/;
93 printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
96 # 13 - introducing UTF8 characters to non-UTF8 string.
98 $x =~ tr/\x{64}/\x{190}/;
99 printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
102 # 14 - removing UTF8 characters from UTF8 string
104 $x =~ tr/\x{190}/\x{64}/;
105 printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
108 # 15 - counting UTF8 chars in UTF8 string
110 $y = $x =~ tr/\x{190}/\x{190}/;
111 print "not " if $y != 2;
114 # 16 - counting non-UTF8 chars in UTF8 string
115 $x = 60.400.125.60.400;
116 $y = $x =~ tr/\x{3c}/\x{3c}/;
117 print "not " if $y != 2;
120 # 17 - counting UTF8 chars in non-UTF8 string
122 $y = $x =~ tr/\x{190}/\x{190}/;
123 print "not " if $y != 0;
127 # 18: test brokenness with tr/a-z-9//;
128 $_ = "abcdefghijklmnopqrstuvwxyz";
130 print (($@ =~ /^Ambiguous range in transliteration operator/)
131 ? '' : 'not ', "ok 18\n");
133 # 19-21: Make sure leading and trailing hyphens still work
136 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
140 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
144 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
146 $_ = "abcdefghijklmnop";
148 print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
150 $_ = "abcdefghijklmnop";
152 print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
154 $_ = "abcdefghijklmnop";
156 print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
158 # 25: Test reversed range check
161 print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/)
162 ? '' : 'not ', "ok 25\n");
164 # 26: test cannot update if read-only
165 eval '$1 =~ tr/x/y/';
166 print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
169 # 27: test can count read-only
171 print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
173 # 28: test lhs OK if not updating
174 print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
176 # 29: test lhs bad if updating
177 eval '"123" =~ tr/1/1/';
178 print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
179 ? '' : 'not ', "ok 29\n");
181 # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
182 # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
184 # Transliterate a byte to a byte, all four ways.
186 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
187 print "not " unless $a eq v300.197.172.300.197.172;
190 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
191 print "not " unless $a eq v300.197.172.300.197.172;
194 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
195 print "not " unless $a eq v300.197.172.300.197.172;
198 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
199 print "not " unless $a eq v300.197.172.300.197.172;
202 # Transliterate a byte to a wide character.
204 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
205 print "not " unless $a eq v300.301.172.300.301.172;
208 # Transliterate a wide character to a byte.
210 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
211 print "not " unless $a eq v195.196.172.195.196.172;
214 # Transliterate a wide character to a wide character.
216 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
217 print "not " unless $a eq v301.196.172.301.196.172;
220 # Transliterate both ways.
222 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
223 print "not " unless $a eq v195.301.172.195.301.172;
226 # Transliterate all (four) ways.
228 ($a = v300.196.172.300.196.172.400.198.144) =~
229 tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
230 print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
233 # Transliterate and count.
236 unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2;
240 unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
243 # Transliterate with complement.
245 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
246 print "not " unless $a eq v301.196.301.301.196.301;
249 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
250 print "not " unless $a eq v300.197.197.300.197.197;
253 # Transliterate with deletion.
255 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
256 print "not " unless $a eq v300.172.300.172;
259 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
260 print "not " unless $a eq v196.172.196.172;
263 # Transliterate with squeeze.
265 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
266 print "not " unless $a eq v197.172.300.300.197.172;
269 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
270 print "not " unless $a eq v196.172.301.196.172.172;
273 # Tricky cases by Simon Cozens.
275 ($a = v196.172.200) =~ tr/\x{12c}/a/;
276 print "not " unless sprintf("%vd", $a) eq '196.172.200';
279 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
280 print "not " unless sprintf("%vd", $a) eq '196.172.200';
283 ($a = v196.172.200) =~ tr/\x{12c}//d;
284 print "not " unless sprintf("%vd", $a) eq '196.172.200';
287 # UTF8 range tests from Inaba Hiroto
289 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
290 print "not " unless $a eq v192.196.172.194.197.172;
293 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
294 print "not " unless $a eq v300.300.172.302.301.172;
297 # UTF8 range tests from Karsten Sperling (patch #9008 required)
299 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
300 print "not " unless $a eq "X";
303 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
304 print "not " unless $a eq "X";
307 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
308 print "not " unless $a eq "X";
311 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
312 print "not " unless $a eq "X";
315 # UTF8 range tests from Inaba Hiroto
317 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
318 print "not " unless $a eq "X";
321 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
322 print "not " unless $a eq "X";
325 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
326 # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
327 # from Karsten Sperling.
329 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
330 print "not " unless $c == 8 and $a eq "XXXXXXXX";
333 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
334 print "not " unless $c == 8 and $a eq "XXXXXXXX";
337 if (ord('i') == 0x89 & ord('J') == 0xd1) {
339 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
340 print "not " unless $c == 2 and $a eq "X\x8a\x8b\x8c\x8d\x8f\x90X";
343 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
344 print "not " unless $c == 2 and $a eq "X\xca\xcb\xcc\xcd\xcf\xd0X";
348 for (60..61) { print "ok $_ # Skip: not EBCDIC\n" }
351 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
352 print "not " unless ord($a) == ord("X");
355 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
356 print "not " unless ord($a) == ord("X");
359 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
360 print "not " unless $a eq "\x{100}\x{100}";
363 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
364 print "not " unless $a eq "\x{100}";
367 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
368 print "not " unless $a eq "\x{1ff}\x{1fe}";
372 ($a = "R0_001") =~ tr/R_//d;
373 print "not " if hex($a) != 1;
377 @a = (1,2); map { y/1/./ for $_ } @a;
378 print "not " if "@a" ne ". 2";
381 @a = (1,2); map { y/1/./ for $_.'' } @a;
382 print "not " if "@a" ne "1 2";
385 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
386 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
387 print "not " unless $a eq "XZY";