11 my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
13 $_ = "abcdefghijklmnopqrstuvwxyz";
17 is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc');
21 is($_, "abcdefghijklmnopqrstuvwxyz", 'lc');
24 is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc');
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 is($_, "i\xcaj", 'EBCDIC discontinuity');
42 (my $y = 12) =~ tr/1/3/;
43 ($f = 1.5) =~ tr/1/3/;
44 (my $g = 1.5) =~ tr/1/3/;
45 is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK');
48 # perlbug [ID 20000511.005]
53 is($_, 'Fred', 'harmless if explicitly not updating');
56 # A variant of the above, added in 5.7.2
59 eval '$1 =~ tr/A-Z/A-Z/;';
61 is($_, 'Fred', 'harmless if implicitly not updating');
62 is($@, '', ' no error');
65 # check tr handles UTF8 correctly
66 ($x = 256.65.258) =~ tr/a/b/;
67 is($x, 256.65.258, 'handles UTF8');
72 if (ord("\t") == 9) { # ASCII
79 # EBCDIC variants of the above tests
80 ($x = 256.193.258) =~ tr/a/b/;
86 if (ord("\t") == 9) { # ASCII
95 my $l = chr(300); my $r = chr(400);
97 $x =~ tr/\x{12c}/\x{190}/;
99 'changing UTF8 chars in a UTF8 string, same length');
103 $x =~ tr/\x{12c}/\x{be8}/;
104 is($x, 200.3048.400, ' more bytes');
108 $x =~ tr/\x{64}/\x{190}/;
109 is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string');
113 $x =~ tr/\x{190}/\x{64}/;
114 is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string');
118 $y = $x =~ tr/\x{190}/\x{190}/;
119 is($y, 2, 'Counting UTF8 chars in UTF8 string');
121 $x = 60.400.125.60.400;
122 $y = $x =~ tr/\x{3c}/\x{3c}/;
123 is($y, 2, ' non-UTF8 chars in UTF8 string');
125 # 17 - counting UTF8 chars in non-UTF8 string
127 $y = $x =~ tr/\x{190}/\x{190}/;
128 is($y, 0, ' UTF8 chars in non-UTFs string');
131 $_ = "abcdefghijklmnopqrstuvwxyz";
133 like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//');
135 # 19-21: Make sure leading and trailing hyphens still work
138 is($_, '..r.rot9', 'hyphens, leading');
142 is($_, '..r.rot9', ' trailing');
146 is($_, '..r.rot9', ' both');
148 $_ = "abcdefghijklmnop";
150 is($_, '.bcd....ijklm.op');
152 $_ = "abcdefghijklmnop";
154 is($_, '...de......lm...');
156 $_ = "abcdefghijklmnop";
158 is($_, '...d.f...j.l...p');
163 like($@, qr/^Invalid range "m-d" in transliteration operator/,
164 'reversed range check');
167 is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count');
168 is($@, '', ' no error');
171 is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count');
172 is($@, '', ' no error');
174 is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr');
176 eval '"123" =~ tr/1/2/';
177 like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
178 'LHS bad on updating tr');
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 is($a, v300.197.172.300.197.172, 'byte2byte transliteration');
189 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
190 is($a, v300.197.172.300.197.172);
192 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
193 is($a, v300.197.172.300.197.172);
195 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
196 is($a, v300.197.172.300.197.172);
199 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
200 is($a, v300.301.172.300.301.172, 'byte2wide transliteration');
202 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
203 is($a, v195.196.172.195.196.172, ' wide2byte');
205 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
206 is($a, v301.196.172.301.196.172, ' wide2wide');
209 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
210 is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte');
213 ($a = v300.196.172.300.196.172.400.198.144) =~
214 tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
215 is($a, v197.301.173.197.301.173.401.198.144, 'all together now!');
218 is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
219 'transliterate and count');
221 is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
224 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
225 is($a, v301.196.301.301.196.301, 'translit w/complement');
227 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
228 is($a, v300.197.197.300.197.197);
231 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
232 is($a, v300.172.300.172, 'translit w/deletion');
234 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
235 is($a, v196.172.196.172);
238 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
239 is($a, v197.172.300.300.197.172, 'translit w/squeeze');
241 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
242 is($a, v196.172.301.196.172.172);
245 # Tricky cases (When Simon Cozens Attacks)
246 ($a = v196.172.200) =~ tr/\x{12c}/a/;
247 is(sprintf("%vd", $a), '196.172.200');
249 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
250 is(sprintf("%vd", $a), '196.172.200');
252 ($a = v196.172.200) =~ tr/\x{12c}//d;
253 is(sprintf("%vd", $a), '196.172.200');
256 # UTF8 range tests from Inaba Hiroto
258 # Not working in EBCDIC as of 12674.
259 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
260 is($a, v192.196.172.194.197.172, 'UTF range');
262 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
263 is($a, v300.300.172.302.301.172);
266 # UTF8 range tests from Karsten Sperling (patch #9008 required)
268 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
271 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
274 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
277 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
281 # UTF8 range tests from Inaba Hiroto
283 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
286 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
290 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
291 # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
292 # from Karsten Sperling.
294 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
298 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
303 skip "not EBCDIC", 4 unless $Is_EBCDIC;
305 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
307 is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
309 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
311 is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
314 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
315 is(ord($a), ord("X"));
317 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
318 is(ord($a), ord("X"));
320 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
321 is($a, "\x{100}\x{100}");
323 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
326 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
327 is($a, "\x{1ff}\x{1fe}");
331 ($a = "R0_001") =~ tr/R_//d;
335 @a = (1,2); map { y/1/./ for $_ } @a;
338 @a = (1,2); map { y/1/./ for $_.'' } @a;
342 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
343 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
347 # Used to fail with "Modification of a read-only value attempted"
351 is($_, 'n', 'pp_trans needs to unshare shared hash keys');
352 is($@, '', ' no error');
356 $x = eval '"1213" =~ tr/1/1/';
357 is($x, 2, 'implicit count on constant');
358 is($@, '', ' no error');
362 eval '$foo[-1] =~ tr/N/N/';
363 is( $@, '', 'implicit count outside array bounds, index negative' );
364 is( scalar @foo, 0, " doesn't extend the array");
366 eval '$foo[1] =~ tr/N/N/';
367 is( $@, '', 'implicit count outside array bounds, index positive' );
368 is( scalar @foo, 0, " doesn't extend the array");
372 eval '$foo{bar} =~ tr/N/N/';
373 is( $@, '', 'implicit count outside hash bounds' );
374 is( scalar keys %foo, 0, " doesn't extend the hash");
377 is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
378 is( ref $x, 'SCALAR', " doesn't stringify its argument" );
380 # rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing
382 fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '');
385 { # [perl #38293] chr(65535) should be allowed in regexes
386 no warnings 'utf8'; # to allow non-characters
388 $s = "\x{d800}\x{ffff}";
390 is($s, "\x{d800}\x{ffff}", "do_trans_simple");
392 $s = "\x{d800}\x{ffff}";
394 is($i, 0, "do_trans_count");
396 $s = "\x{d800}\x{ffff}";
398 is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH");
400 $s = "\x{d800}\x{ffff}";
402 is($s, "AA", "do_trans_complex, COMPLEMENT");
405 $s =~ tr/\x{ffff}/\x{1ffff}/;
406 is($s, "A\x{1ffff}B", "utf8, SEARCHLIST");
408 $s = "\x{fffd}\x{fffe}\x{ffff}";
409 $s =~ tr/\x{fffd}-\x{ffff}/ABC/;
410 is($s, "ABC", "utf8, SEARCHLIST range");
413 $s =~ tr/ABC/\x{ffff}/;
414 is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST");
417 $s =~ tr/ABC/\x{fffd}-\x{ffff}/;
418 is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range");
420 $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}";
421 $i = $s =~ tr/\x{ffff}//;
422 is($i, 2, "utf8, count");
424 $s = "A\x{ffff}\x{ffff}C";
425 $s =~ tr/\x{ffff}/\x{100}/s;
426 is($s, "A\x{100}C", "utf8, SQUASH");
428 $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C";
429 $s =~ tr/\x{fffe}\x{ffff}//s;
430 is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH");
433 $s =~ tr/AB/\x{ffff}/s;
434 is($s, "x\x{ffff}y", "utf8, SQUASH");
437 $s =~ tr/AB/\x{fffe}\x{ffff}/s;
438 is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH");
440 $s = "A\x{ffff}B\x{fffe}C";
441 $s =~ tr/\x{fffe}\x{ffff}/x/c;
442 is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT");
444 $s = "A\x{10000}B\x{2abcd}C";
445 $s =~ tr/\0-\x{ffff}/x/c;
446 is($s, "AxBxC", "utf8, COMPLEMENT range");
448 $s = "A\x{fffe}B\x{ffff}C";
449 $s =~ tr/\x{fffe}\x{ffff}/x/d;
450 is($s, "AxBC", "utf8, DELETE");
452 } # non-characters end
454 { # related to [perl #27940]
457 ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d;
458 is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d");
460 ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d;
461 is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d");
464 ($s) = keys %{{pie => 3}};
465 my $wasro = Internals::SvREADONLY($s);
467 $wasro or local $TODO = "didn't have a COW";
469 ok( Internals::SvREADONLY($s), "count-only tr doesn't deCOW COWs" );