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