This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
47acd9e310ae7c340885f88d725a5fffae78042e
[perl5.git] / t / op / tr.t
1 # tr.t
2 $|=1;
3
4 BEGIN {
5     chdir 't' if -d 't';
6     require './test.pl';
7     set_up_inc('../lib');
8     if (is_miniperl()) {
9         eval 'require utf8';
10         if ($@) { skip_all("miniperl, no 'utf8'") }
11     }
12 }
13
14 use utf8;
15
16 plan tests => 166;
17
18 # Test this first before we extend the stack with other operations.
19 # This caused an asan failure due to a bad write past the end of the stack.
20 eval { my $x; die  1..127, $x =~ y/// };
21
22 $_ = "abcdefghijklmnopqrstuvwxyz";
23
24 tr/a-z/A-Z/;
25
26 is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ",    'uc');
27
28 tr/A-Z/a-z/;
29
30 is($_, "abcdefghijklmnopqrstuvwxyz",    'lc');
31
32 tr/b-y/B-Y/;
33 is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz",    'partial uc');
34
35 eval 'tr/a/\N{KATAKANA LETTER AINU P}/;';
36 like $@,
37      qr/\\N\{KATAKANA LETTER AINU P} must not be a named sequence in transliteration operator/,
38      "Illegal to tr/// named sequence";
39
40 eval 'tr/\x{101}-\x{100}//;';
41 like $@,
42      qr/Invalid range "\\x\{0101}-\\x\{0100}" in transliteration operator/,
43      "UTF-8 range with min > max";
44
45 SKIP: {   # Test literal range end point special handling
46     unless ($::IS_EBCDIC) {
47         skip "Valid only for EBCDIC", 24;
48     }
49
50     $_ = "\x89";    # is 'i'
51     tr/i-j//d;
52     is($_, "", '"\x89" should match [i-j]');
53     $_ = "\x8A";
54     tr/i-j//d;
55     is($_, "\x8A", '"\x8A" shouldnt match [i-j]');
56     $_ = "\x90";
57     tr/i-j//d;
58     is($_, "\x90", '"\x90" shouldnt match [i-j]');
59     $_ = "\x91";    # is 'j'
60     tr/i-j//d;
61     is($_, "", '"\x91" should match [i-j]');
62
63     $_ = "\x89";
64     tr/i-\N{LATIN SMALL LETTER J}//d;
65     is($_, "", '"\x89" should match [i-\N{LATIN SMALL LETTER J}]');
66     $_ = "\x8A";
67     tr/i-\N{LATIN SMALL LETTER J}//d;
68     is($_, "\x8A", '"\x8A" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
69     $_ = "\x90";
70     tr/i-\N{LATIN SMALL LETTER J}//d;
71     is($_, "\x90", '"\x90" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
72     $_ = "\x91";
73     tr/i-\N{LATIN SMALL LETTER J}//d;
74     is($_, "", '"\x91" should match [i-\N{LATIN SMALL LETTER J}]');
75
76     $_ = "\x89";
77     tr/i-\N{U+6A}//d;
78     is($_, "", '"\x89" should match [i-\N{U+6A}]');
79     $_ = "\x8A";
80     tr/i-\N{U+6A}//d;
81     is($_, "\x8A", '"\x8A" shouldnt match [i-\N{U+6A}]');
82     $_ = "\x90";
83     tr/i-\N{U+6A}//d;
84     is($_, "\x90", '"\x90" shouldnt match [i-\N{U+6A}]');
85     $_ = "\x91";
86     tr/i-\N{U+6A}//d;
87     is($_, "", '"\x91" should match [i-\N{U+6A}]');
88
89     $_ = "\x89";
90     tr/\N{U+69}-\N{U+6A}//d;
91     is($_, "", '"\x89" should match [\N{U+69}-\N{U+6A}]');
92     $_ = "\x8A";
93     tr/\N{U+69}-\N{U+6A}//d;
94     is($_, "\x8A", '"\x8A" shouldnt match [\N{U+69}-\N{U+6A}]');
95     $_ = "\x90";
96     tr/\N{U+69}-\N{U+6A}//d;
97     is($_, "\x90", '"\x90" shouldnt match [\N{U+69}-\N{U+6A}]');
98     $_ = "\x91";
99     tr/\N{U+69}-\N{U+6A}//d;
100     is($_, "", '"\x91" should match [\N{U+69}-\N{U+6A}]');
101
102     $_ = "\x89";
103     tr/i-\x{91}//d;
104     is($_, "", '"\x89" should match [i-\x{91}]');
105     $_ = "\x8A";
106     tr/i-\x{91}//d;
107     is($_, "", '"\x8A" should match [i-\x{91}]');
108     $_ = "\x90";
109     tr/i-\x{91}//d;
110     is($_, "", '"\x90" should match [i-\x{91}]');
111     $_ = "\x91";
112     tr/i-\x{91}//d;
113     is($_, "", '"\x91" should match [i-\x{91}]');
114
115     # Need to use eval, because tries to compile on ASCII platforms even
116     # though the tests are skipped, and fails because 0x89-j is an illegal
117     # range there.
118     $_ = "\x89";
119     eval 'tr/\x{89}-j//d';
120     is($_, "", '"\x89" should match [\x{89}-j]');
121     $_ = "\x8A";
122     eval 'tr/\x{89}-j//d';
123     is($_, "", '"\x8A" should match [\x{89}-j]');
124     $_ = "\x90";
125     eval 'tr/\x{89}-j//d';
126     is($_, "", '"\x90" should match [\x{89}-j]');
127     $_ = "\x91";
128     eval 'tr/\x{89}-j//d';
129     is($_, "", '"\x91" should match [\x{89}-j]');
130 }
131
132
133 # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
134 # Yes, discontinuities.  Regardless, the \xca in the below should stay
135 # untouched (and not became \x8a).
136 {
137     $_ = "I\xcaJ";
138
139     tr/I-J/i-j/;
140
141     is($_, "i\xcaj",    'EBCDIC discontinuity');
142 }
143 #
144
145 ($x = 12) =~ tr/1/3/;
146 (my $y = 12) =~ tr/1/3/;
147 ($f = 1.5) =~ tr/1/3/;
148 (my $g = 1.5) =~ tr/1/3/;
149 is($x + $y + $f + $g, 71,   'tr cancels IOK and NOK');
150
151 # /r
152 $_ = 'adam';
153 is y/dam/ve/rd, 'eve', '/r';
154 is $_, 'adam', '/r leaves param alone';
155 $g = 'ruby';
156 is $g =~ y/bury/repl/r, 'perl', '/r with explicit param';
157 is $g, 'ruby', '/r leaves explicit param alone';
158 is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param';
159 ok !eval '$_ !~ y///r', "!~ y///r is forbidden";
160 like $@, qr\^Using !~ with tr///r doesn't make sense\,
161   "!~ y///r error message";
162 {
163   my $w;
164   my $wc;
165   local $SIG{__WARN__} = sub { $w = shift; ++$wc };
166   local $^W = 1;
167   eval 'y///r; 1';
168   like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)',
169     '/r warns in void context';
170   is $wc, 1, '/r warns just once';
171 }
172
173 # perlbug [ID 20000511.005 (#3237)]
174 $_ = 'fred';
175 /([a-z]{2})/;
176 $1 =~ tr/A-Z//;
177 s/^(\s*)f/$1F/;
178 is($_, 'Fred',  'harmless if explicitly not updating');
179
180
181 # A variant of the above, added in 5.7.2
182 $_ = 'fred';
183 /([a-z]{2})/;
184 eval '$1 =~ tr/A-Z/A-Z/;';
185 s/^(\s*)f/$1F/;
186 is($_, 'Fred',  'harmless if implicitly not updating');
187 is($@, '',      '    no error');
188
189
190 # check tr handles UTF8 correctly
191 ($x = 256.65.258) =~ tr/a/b/;
192 is($x, 256.65.258,  'handles UTF8');
193 is(length $x, 3);
194
195 $x =~ tr/A/B/;
196 is(length $x, 3);
197 if ($::IS_ASCII) { # ASCII
198     is($x, 256.66.258);
199 }
200 else {
201     is($x, 256.65.258);
202 }
203
204 # EBCDIC variants of the above tests
205 ($x = 256.193.258) =~ tr/a/b/;
206 is(length $x, 3);
207 is($x, 256.193.258);
208
209 $x =~ tr/A/B/;
210 is(length $x, 3);
211 if ($::IS_ASCII) { # ASCII
212     is($x, 256.193.258);
213 }
214 else {
215     is($x, 256.194.258);
216 }
217
218
219 {
220     my $l = chr(300); my $r = chr(400);
221     $x = 200.300.400;
222     $x =~ tr/\x{12c}/\x{190}/;
223     is($x, 200.400.400,     
224                         'changing UTF8 chars in a UTF8 string, same length');
225     is(length $x, 3);
226
227     $x = 200.300.400;
228     $x =~ tr/\x{12c}/\x{be8}/;
229     is($x, 200.3048.400,    '    more bytes');
230     is(length $x, 3);
231
232     $x = 100.125.60;
233     $x =~ tr/\x{64}/\x{190}/;
234     is($x, 400.125.60,      'Putting UT8 chars into a non-UTF8 string');
235     is(length $x, 3);
236
237     $x = 400.125.60;
238     $x =~ tr/\x{190}/\x{64}/;
239     is($x, 100.125.60,      'Removing UTF8 chars from UTF8 string');
240     is(length $x, 3);
241
242     $x = 400.125.60.400;
243     $y = $x =~ tr/\x{190}/\x{190}/;
244     is($y, 2,               'Counting UTF8 chars in UTF8 string');
245
246     $x = 60.400.125.60.400;
247     $y = $x =~ tr/\x{3c}/\x{3c}/;
248     is($y, 2,               '         non-UTF8 chars in UTF8 string');
249
250     # 17 - counting UTF8 chars in non-UTF8 string
251     $x = 200.125.60;
252     $y = $x =~ tr/\x{190}/\x{190}/;
253     is($y, 0,               '         UTF8 chars in non-UTFs string');
254 }
255
256 $_ = "abcdefghijklmnopqrstuvwxyz";
257 eval 'tr/a-z-9/ /';
258 like($@, qr/^Ambiguous range in transliteration operator/,  'tr/a-z-9//');
259
260 # 19-21: Make sure leading and trailing hyphens still work
261 $_ = "car-rot9";
262 tr/-a-m/./;
263 is($_, '..r.rot9',  'hyphens, leading');
264
265 $_ = "car-rot9";
266 tr/a-m-/./;
267 is($_, '..r.rot9',  '   trailing');
268
269 $_ = "car-rot9";
270 tr/-a-m-/./;
271 is($_, '..r.rot9',  '   both');
272
273 $_ = "abcdefghijklmnop";
274 tr/ae-hn/./;
275 is($_, '.bcd....ijklm.op');
276
277 $_ = "abcdefghijklmnop";
278 tr/a-cf-kn-p/./;
279 is($_, '...de......lm...');
280
281 $_ = "abcdefghijklmnop";
282 tr/a-ceg-ikm-o/./;
283 is($_, '...d.f...j.l...p');
284
285
286 # 20000705 MJD
287 eval "tr/m-d/ /";
288 like($@, qr/^Invalid range "m-d" in transliteration operator/,
289               'reversed range check');
290
291 'abcdef' =~ /(bcd)/;
292 is(eval '$1 =~ tr/abcd//', 3,  'explicit read-only count');
293 is($@, '',                      '    no error');
294
295 'abcdef' =~ /(bcd)/;
296 is(eval '$1 =~ tr/abcd/abcd/', 3,  'implicit read-only count');
297 is($@, '',                      '    no error');
298
299 is(eval '"123" =~ tr/12//', 2,     'LHS of non-updating tr');
300
301 eval '"123" =~ tr/1/2/';
302 like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
303          'LHS bad on updating tr');
304
305
306 # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
307 # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
308
309 # Transliterate a byte to a byte, all four ways.
310
311 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
312 is($a, v300.197.172.300.197.172,    'byte2byte transliteration');
313
314 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
315 is($a, v300.197.172.300.197.172);
316
317 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
318 is($a, v300.197.172.300.197.172);
319
320 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
321 is($a, v300.197.172.300.197.172);
322
323
324 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
325 is($a, v300.301.172.300.301.172,    'byte2wide transliteration');
326
327 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
328 is($a, v195.196.172.195.196.172,    '   wide2byte');
329
330 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
331 is($a, v301.196.172.301.196.172,    '   wide2wide');
332
333
334 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
335 is($a, v195.301.172.195.301.172,    'byte2wide & wide2byte');
336
337
338 ($a = v300.196.172.300.196.172.400.198.144) =~
339         tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
340 is($a, v197.301.173.197.301.173.401.198.144,    'all together now!');
341
342
343 is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
344                                      'transliterate and count');
345
346 is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
347
348
349 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
350 is($a, v301.196.301.301.196.301,    'translit w/complement');
351
352 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
353 is($a, v300.197.197.300.197.197);
354
355
356 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
357 is($a, v300.172.300.172,            'translit w/deletion');
358
359 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
360 is($a, v196.172.196.172);
361
362
363 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
364 is($a, v197.172.300.300.197.172,    'translit w/squeeze');
365
366 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
367 is($a, v196.172.301.196.172.172);
368
369
370 # Tricky cases (When Simon Cozens Attacks)
371 ($a = v196.172.200) =~ tr/\x{12c}/a/;
372 is(sprintf("%vd", $a), '196.172.200');
373
374 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
375 is(sprintf("%vd", $a), '196.172.200');
376
377 ($a = v196.172.200) =~ tr/\x{12c}//d;
378 is(sprintf("%vd", $a), '196.172.200');
379
380
381 # UTF8 range tests from Inaba Hiroto
382
383 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
384 is($a, v192.196.172.194.197.172,    'UTF range');
385
386 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
387 is($a, v300.300.172.302.301.172);
388
389
390 # UTF8 range tests from Karsten Sperling (patch #9008 required)
391
392 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
393 is($a, "X");
394
395 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
396 is($a, "X");
397
398 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
399 is($a, "X");
400  
401 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
402 is($a, "X");
403
404
405 # UTF8 range tests from Inaba Hiroto
406
407 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
408 is($a, "X");
409
410 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
411 is($a, "X");
412
413 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters (as
414 # well as i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
415 # from Karsten Sperling.
416
417 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
418 is($c, 8);
419 is($a, "XXXXXXXX");
420
421 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
422 is($c, 8);
423 is($a, "XXXXXXXX");
424
425 SKIP: {
426     skip "EBCDIC-centric tests", 4 unless $::IS_EBCDIC;
427
428     $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
429     is($c, 2);
430     is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
431    
432     $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
433     is($c, 2);
434     is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
435 }
436
437 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
438 is(ord($a), ord("X"));
439
440 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
441 is(ord($a), ord("X"));
442
443 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
444 is($a, "\x{100}\x{100}");
445
446 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
447 is($a, "\x{100}");
448
449 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
450 is($a, "\x{1ff}\x{1fe}");
451
452
453 # From David Dyck
454 ($a = "R0_001") =~ tr/R_//d;
455 is(hex($a), 1);
456
457 # From Inaba Hiroto
458 @a = (1,2); map { y/1/./ for $_ } @a;
459 is("@a", ". 2");
460
461 @a = (1,2); map { y/1/./ for $_.'' } @a;
462 is("@a", "1 2");
463
464
465 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
466 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
467 is($a, "XZY");
468
469
470 # Used to fail with "Modification of a read-only value attempted"
471 %a = (N=>1);
472 foreach (keys %a) {
473   eval 'tr/N/n/';
474   is($_, 'n',   'pp_trans needs to unshare shared hash keys');
475   is($@, '',    '   no error');
476 }
477
478
479 $x = eval '"1213" =~ tr/1/1/';
480 is($x, 2,   'implicit count on constant');
481 is($@, '',  '   no error');
482
483
484 my @foo = ();
485 eval '$foo[-1] =~ tr/N/N/';
486 is( $@, '',         'implicit count outside array bounds, index negative' );
487 is( scalar @foo, 0, "    doesn't extend the array");
488
489 eval '$foo[1] =~ tr/N/N/';
490 is( $@, '',         'implicit count outside array bounds, index positive' );
491 is( scalar @foo, 0, "    doesn't extend the array");
492
493
494 my %foo = ();
495 eval '$foo{bar} =~ tr/N/N/';
496 is( $@, '',         'implicit count outside hash bounds' );
497 is( scalar keys %foo, 0,   "    doesn't extend the hash");
498
499 $x = \"foo";
500 is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
501 is( ref $x, 'SCALAR', "    doesn't stringify its argument" );
502
503 # rt.perl.org 36622.  Perl didn't like a y/// at end of file.  No trailing
504 # newline allowed.
505 fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '', {}, 'RT #36622 y/// at end of file');
506
507
508 { # [perl #38293] chr(65535) should be allowed in regexes
509 no warnings 'utf8'; # to allow non-characters
510
511 $s = "\x{d800}\x{ffff}";
512 $s =~ tr/\0/A/;
513 is($s, "\x{d800}\x{ffff}", "do_trans_simple");
514
515 $s = "\x{d800}\x{ffff}";
516 $i = $s =~ tr/\0//;
517 is($i, 0, "do_trans_count");
518
519 $s = "\x{d800}\x{ffff}";
520 $s =~ tr/\0/A/s;
521 is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH");
522
523 $s = "\x{d800}\x{ffff}";
524 $s =~ tr/\0/A/c;
525 is($s, "AA", "do_trans_complex, COMPLEMENT");
526
527 $s = "A\x{ffff}B";
528 $s =~ tr/\x{ffff}/\x{1ffff}/;
529 is($s, "A\x{1ffff}B", "utf8, SEARCHLIST");
530
531 $s = "\x{fffd}\x{fffe}\x{ffff}";
532 $s =~ tr/\x{fffd}-\x{ffff}/ABC/;
533 is($s, "ABC", "utf8, SEARCHLIST range");
534
535 $s = "ABC";
536 $s =~ tr/ABC/\x{ffff}/;
537 is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST");
538
539 $s = "ABC";
540 $s =~ tr/ABC/\x{fffd}-\x{ffff}/;
541 is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range");
542
543 $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}";
544 $i = $s =~ tr/\x{ffff}//;
545 is($i, 2, "utf8, count");
546
547 $s = "A\x{ffff}\x{ffff}C";
548 $s =~ tr/\x{ffff}/\x{100}/s;
549 is($s, "A\x{100}C", "utf8, SQUASH");
550
551 $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C";
552 $s =~ tr/\x{fffe}\x{ffff}//s;
553 is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH");
554
555 $s = "xAABBBy";
556 $s =~ tr/AB/\x{ffff}/s;
557 is($s, "x\x{ffff}y", "utf8, SQUASH");
558
559 $s = "xAABBBy";
560 $s =~ tr/AB/\x{fffe}\x{ffff}/s;
561 is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH");
562
563 $s = "A\x{ffff}B\x{fffe}C";
564 $s =~ tr/\x{fffe}\x{ffff}/x/c;
565 is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT");
566
567 $s = "A\x{10000}B\x{2abcd}C";
568 $s =~ tr/\0-\x{ffff}/x/c;
569 is($s, "AxBxC", "utf8, COMPLEMENT range");
570
571 $s = "A\x{fffe}B\x{ffff}C";
572 $s =~ tr/\x{fffe}\x{ffff}/x/d;
573 is($s, "AxBC", "utf8, DELETE");
574
575 } # non-characters end
576
577 { # related to [perl #27940]
578     my $c;
579
580     ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d;
581     is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d");
582
583     ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d;
584     is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d");
585 }
586
587 ($s) = keys %{{pie => 3}};
588 SKIP: {
589     if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 }
590     my $wasro = XS::APItest::SvIsCOW($s);
591     ok $wasro, "have a COW";
592     $s =~ tr/i//;
593     ok( XS::APItest::SvIsCOW($s),
594        "count-only tr doesn't deCOW COWs" );
595 }
596
597 # [ RT #61520 ]
598 #
599 # under threads, unicode tr within a cloned closure would SEGV or assert
600 # fail, since the pointer in the pad to the swash was getting zeroed out
601 # in the proto-CV
602
603 {
604     my $x = "\x{142}";
605     sub {
606         $x =~ tr[\x{142}][\x{143}];
607     }->();
608     is($x,"\x{143}", "utf8 + closure");
609 }
610
611 # Freeing of trans ops prior to pmtrans() [perl #102858].
612 eval q{ $a ~= tr/a/b/; };
613 ok 1;
614 SKIP: {
615     no warnings "deprecated";
616     skip "no encoding", 1 unless eval { require encoding; 1 };
617     eval q{ use encoding "utf8"; $a ~= tr/a/b/; };
618     ok 1;
619 }
620
621 { # [perl #113584]
622
623     my $x = "Perlα";
624     $x =~ tr/αα/βγ/;
625     { no warnings 'utf8'; print "# $x\n"; } # No note() to avoid wide warning.
626     is($x, "Perlβ", "Only first of multiple transliterations is used");
627 }
628
629 # tr/a/b/ should fail even on zero-length read-only strings
630 use constant nullrocow => (keys%{{""=>undef}})[0];
631 for ("", nullrocow) {
632     eval { $_ =~ y/a/b/ };
633     like $@, qr/^Modification of a read-only value attempted at /,
634         'tr/a/b/ fails on zero-length ro string';
635 }
636
637 # Whether they're permitted or not, non-modifying tr/// should not write
638 # to read-only values, even with funky flags.
639 { # [perl #123759]
640         eval q{ ('a' =~ /./) =~ tr///d };
641         ok(1, "tr///d on PL_Yes does not assert");
642         eval q{ ('a' =~ /./) =~ tr/a-z/a-z/d };
643         ok(1, "tr/a-z/a-z/d on PL_Yes does not assert");
644         eval q{ ('a' =~ /./) =~ tr///s };
645         ok(1, "tr///s on PL_Yes does not assert");
646         eval q{ *x =~ tr///d };
647         ok(1, "tr///d on glob does not assert");
648 }
649
650 { # [perl #128734
651     my $string = chr utf8::unicode_to_native(0x00e0);
652     $string =~ tr/\N{U+00e0}/A/;
653     is($string, "A", 'tr// of \N{U+...} works for upper-Latin1');
654     my $string = chr utf8::unicode_to_native(0x00e1);
655     $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/;
656     is($string, "A", 'tr// of \N{name} works for upper-Latin1');
657 }
658
659 1;