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