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