Perl_op_sibling_splice(0 remove dead code
[perl.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 => 300;
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 tr/a-a/AB/;
36 is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYz",    'single char range a-a');
37
38 eval 'tr/a/\N{KATAKANA LETTER AINU P}/;';
39 like $@,
40      qr/\\N\{KATAKANA LETTER AINU P\} must not be a named sequence in transliteration operator/,
41      "Illegal to tr/// named sequence";
42
43 eval 'tr/\x{101}-\x{100}//;';
44 like $@,
45      qr/Invalid range "\\x\{0101\}-\\x\{0100\}" in transliteration operator/,
46      "UTF-8 range with min > max";
47
48
49 # Test /c and variants, with all the search and replace chars being
50 # non-utf8, but with both non-utf8 and utf8 strings.
51
52 {
53     my $all255            = join '', map chr, 0..0xff;
54     my $all255_twice      = join '', map chr, map { ($_, $_) } 0..0xff;
55     my $all255_plus       = join '', map chr, 0..0x11f;
56     my $all255_twice_plus = join '', map chr, map { ($_, $_) } 0..0x11f;
57     my ($c, $s);
58
59
60     # length(replacement) == 0
61     # non-utf8 string
62
63     $s = $all255;
64     $c = $s =~ tr/\x40-\xbf//c;
65     is $s, $all255, "/c   ==0";
66     is $c, 0x80, "/c   ==0  count";
67
68     $s = $all255;
69     $c = $s =~ tr/\x40-\xbf//cd;
70     is $s, join('', map chr, 0x40..0xbf), "/cd  ==0";
71     is $c, 0x80, "/cd  ==0  count";
72
73     $s = $all255_twice;
74     $c = $s =~ tr/\x40-\xbf//cs;
75     is $s, join('', map chr,
76                 0x00..0x3f,
77                 (map  { ($_, $_) } 0x40..0xbf),
78                 0xc0..0xff,
79             ),
80         "/cs  ==0";
81     is $c, 0x100, "/cs  ==0  count";
82
83     $s = $all255_twice;
84     $c = $s =~ tr/\x40-\xbf//csd;
85     is $s, join('', map chr, (map  { ($_, $_) } 0x40..0xbf)), "/csd ==0";
86     is $c, 0x100, "/csd ==0  count";
87
88
89     # length(search) > length(replacement)
90     # non-utf8 string
91
92     $s = $all255;
93     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/c;
94     is $s, join('', map chr,
95                 0x80..0xbf,
96                 0x40..0xbf,
97                 0x00..0x2f,
98                 ((0x2f) x 16),
99             ),
100         "/c   >";
101     is $c, 0x80, "/c   >  count";
102
103     $s = $all255;
104     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cd;
105     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f),
106         "/cd  >";
107     is $c, 0x80, "/cd  >  count";
108
109     $s = $all255_twice;
110     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cs;
111     is $s, join('', map chr,
112                 0x80..0xbf,
113                 (map  { ($_, $_) } 0x40..0xbf),
114                 0x00..0x2f,
115             ),
116         "/cs  >";
117     is $c, 0x100, "/cs  >  count";
118
119     $s = $all255_twice;
120     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/csd;
121     is $s, join('', map chr,
122                 0x80..0xbf,
123                 (map  { ($_, $_) } 0x40..0xbf),
124                 0x00..0x2f,
125             ),
126         "/csd >";
127     is $c, 0x100, "/csd >  count";
128
129
130     # length(search) == length(replacement)
131     # non-utf8 string
132
133     $s = $all255;
134     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/c;
135     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/c   ==";
136     is $c, 0x80, "/c   == count";
137
138     $s = $all255;
139     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cd;
140     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/cd  ==";
141     is $c, 0x80, "/cd  == count";
142
143     $s = $all255_twice;
144     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cs;
145     is $s, join('', map chr,
146                 0x80..0xbf,
147                 (map  { ($_, $_) } 0x40..0xbf),
148                 0x00..0x3f,
149             ),
150         "/cs  ==";
151     is $c, 0x100, "/cs  == count";
152
153     $s = $all255_twice;
154     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/csd;
155     is $s, join('', map chr,
156                 0x80..0xbf,
157                 (map  { ($_, $_) } 0x40..0xbf),
158                 0x00..0x3f,
159             ),
160         "/csd ==";
161     is $c, 0x100, "/csd == count";
162
163     # length(search) == length(replacement) - 1
164     # non-utf8 string
165
166
167     $s = $all255;
168     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/c;
169     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
170         "/c   =-";
171     is $c, 0x70, "/c   =-  count";
172
173     $s = $all255;
174     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/cd;
175     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
176         "/cd  =-";
177     is $c, 0x70, "/cd  =-  count";
178
179     $s = $all255_twice;
180     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/cs;
181     is $s, join('', map chr,
182                 0x80..0xbf,
183                 (map  { ($_, $_) } 0x40..0xbf),
184                 0x00..0x2f,
185                 (map  { ($_, $_) } 0xf0..0xff),
186             ),
187         "/cs  =-";
188     is $c, 0xe0, "/cs  =-  count";
189
190     $s = $all255_twice;
191     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/csd;
192     is $s, join('', map chr,
193                 0x80..0xbf,
194                 (map  { ($_, $_) } 0x40..0xbf),
195                 0x00..0x2f,
196                 (map  { ($_, $_) } 0xf0..0xff),
197             ),
198         "/csd =-";
199     is $c, 0xe0, "/csd =-  count";
200
201     # length(search) < length(replacement)
202     # non-utf8 string
203
204     $s = $all255;
205     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/c;
206     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
207         "/c   <";
208     is $c, 0x70, "/c   <  count";
209
210     $s = $all255;
211     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cd;
212     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
213         "/cd  <";
214     is $c, 0x70, "/cd  <  count";
215
216     $s = $all255_twice;
217     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cs;
218     is $s, join('', map chr,
219                 0x80..0xbf,
220                 (map  { ($_, $_) } 0x40..0xbf),
221                 0x00..0x2f,
222                 (map  { ($_, $_) } 0xf0..0xff),
223             ),
224         "/cs  <";
225     is $c, 0xe0, "/cs  <  count";
226
227     $s = $all255_twice;
228     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/csd;
229     is $s, join('', map chr,
230                 0x80..0xbf,
231                 (map  { ($_, $_) } 0x40..0xbf),
232                 0x00..0x2f,
233                 (map  { ($_, $_) } 0xf0..0xff),
234             ),
235         "/csd <";
236     is $c, 0xe0, "/csd <  count";
237
238
239     # length(replacement) == 0
240     # with some >= 0x100 utf8 chars in the string to be modified
241
242     $s = $all255_plus;
243     $c = $s =~ tr/\x40-\xbf//c;
244     is $s, $all255_plus, "/c   ==0U";
245     is $c, 0xa0, "/c   ==0U  count";
246
247     $s = $all255_plus;
248     $c = $s =~ tr/\x40-\xbf//cd;
249     is $s, join('', map chr, 0x40..0xbf), "/cd  ==0U";
250     is $c, 0xa0, "/cd  ==0U  count";
251
252     $s = $all255_twice_plus;
253     $c = $s =~ tr/\x40-\xbf//cs;
254     is $s, join('', map chr,
255                 0x00..0x3f,
256                 (map  { ($_, $_) } 0x40..0xbf),
257                 0xc0..0x11f,
258             ),
259         "/cs  ==0U";
260     is $c, 0x140, "/cs  ==0U  count";
261
262     $s = $all255_twice_plus;
263     $c = $s =~ tr/\x40-\xbf//csd;
264     is $s, join('', map chr, (map  { ($_, $_) } 0x40..0xbf)), "/csd ==0U";
265     is $c, 0x140, "/csd ==0U  count";
266
267     # length(search) > length(replacement)
268     # with some >= 0x100 utf8 chars in the string to be modified
269
270     $s = $all255_plus;
271     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/c;
272     is $s, join('', map chr,
273                 0x80..0xbf,
274                 0x40..0xbf,
275                 0x00..0x2f,
276                 ((0x2f) x 48),
277             ),
278         "/c   >U";
279     is $c, 0xa0, "/c   >U count";
280
281     $s = $all255_plus;
282     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cd;
283     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f),
284         "/cd  >U";
285     is $c, 0xa0, "/cd  >U count";
286
287     $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
288     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cs;
289     is $s, join('', map chr,
290                 0x80..0xbf,
291                 (map  { ($_, $_) } 0x40..0xbf),
292                 0x00..0x2f,
293                 0xbf,
294                 0x2f,
295             ),
296         "/cs  >U";
297     is $c, 0x144, "/cs  >U count";
298
299     $s = $all255_twice_plus;
300     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/csd;
301     is $s, join('', map chr,
302                 0x80..0xbf,
303                 (map  { ($_, $_) } 0x40..0xbf),
304                 0x00..0x2f,
305             ),
306         "/csd >U";
307     is $c, 0x140, "/csd >U count";
308
309     # length(search) == length(replacement)
310     # with some >= 0x100 utf8 chars in the string to be modified
311
312     $s = $all255_plus;
313     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/c;
314     is $s, join('', map chr,
315                 0x80..0xbf,
316                 0x40..0xbf,
317                 0x00..0x3f,
318                 ((0x3f) x 32),
319             ),
320         "/c   ==U";
321     is $c, 0xa0, "/c   ==U count";
322
323     $s = $all255_plus;
324     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cd;
325     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/cd ==U";
326     is $c, 0xa0, "/cd  ==U count";
327
328     $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
329     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cs;
330     is $s, join('', map chr,
331                 0x80..0xbf,
332                 (map  { ($_, $_) } 0x40..0xbf),
333                 0x00..0x3f,
334                 0xbf,
335                 0x3f,
336             ),
337         "/cs  ==U";
338     is $c, 0x144, "/cs  ==U count";
339
340     $s = $all255_twice_plus;
341     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/csd;
342     is $s, join('', map chr,
343                 0x80..0xbf,
344                 (map  { ($_, $_) } 0x40..0xbf),
345                 0x00..0x3f,
346             ),
347         "/csd ==U";
348     is $c, 0x140, "/csd ==U count";
349
350
351     # length(search) == length(replacement) - 1
352     # with some >= 0x100 utf8 chars in the string to be modified
353
354     $s = $all255_plus;
355     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/c;
356     is $s, join('', map chr,
357                 0x80..0xbf,
358                 0x40..0xbf,
359                 0x00..0x40,
360                 ((0x40) x 31),
361             ),
362         "/c   =-U";
363     is $c, 0xa0, "/c   =-U count";
364
365     $s = $all255_plus;
366     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/cd;
367     is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x40), "/cd =-U";
368     is $c, 0xa0, "/cd  =-U count";
369
370     $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
371     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/cs;
372     is $s, join('', map chr,
373                 0x80..0xbf,
374                 (map  { ($_, $_) } 0x40..0xbf),
375                 0x00..0x40,
376                 0xbf,
377                 0x40,
378             ),
379         "/cs  =-U";
380     is $c, 0x144, "/cs  =-U count";
381
382     $s = $all255_twice_plus;
383     $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/csd;
384     is $s, join('', map chr,
385                 0x80..0xbf,
386                 (map  { ($_, $_) } 0x40..0xbf),
387                 0x00..0x40,
388             ),
389         "/csd =-U";
390     is $c, 0x140, "/csd =-U count";
391
392
393
394     # length(search) < length(replacement),
395     # with some >= 0x100 utf8 chars in the string to be modified
396
397     $s = $all255_plus;
398     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/c;
399     is $s, join('', map chr,
400                     0x80..0xbf,
401                     0x40..0xbf,
402                     0x00..0x2f,
403                     0xf0..0xff,
404                     0x30..0x3f,
405                     ((0x3f)x 16),
406                 ),
407         "/c   <U";
408     is $c, 0x90, "/c   <U count";
409
410     $s = $all255_plus;
411     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cd;
412     is $s, join('', map chr,
413                 0x80..0xbf,
414                 0x40..0xbf,
415                 0x00..0x2f,
416                 0xf0..0xff,
417                 0x30..0x3f,
418                 ),
419             "/cd  <U";
420     is $c, 0x90, "/cd  <U count";
421
422     $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
423     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cs;
424     is $s, join('', map chr,
425                 0x80..0xbf,
426                 (map  { ($_, $_) } 0x40..0xbf),
427                 0x00..0x2f,
428                 (map  { ($_, $_) } 0xf0..0xff),
429                 0x30..0x3f,
430                 0xbf,
431                 0x3f,
432             ),
433         "/cs  <U";
434     is $c, 0x124, "/cs  <U count";
435
436     $s = $all255_twice_plus;
437     $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/csd;
438     is $s, join('', map chr, 0x80..0xbf,
439                 (map  { ($_, $_) } 0x40..0xbf),
440                 0x00..0x2f,
441                 (map  { ($_, $_) } 0xf0..0xff),
442                 0x30..0x3f,
443             ),
444         "/csd <U";
445     is $c, 0x120, "/csd <U count";
446 }
447
448 {
449     # RT #132608
450     # the 'extra length' for tr///c was stored as a short, so if the
451     # replacement string had more than 0x7fff chars not paired with
452     # search chars, bad things could happen
453
454     my ($c, $e, $s);
455
456     $s = "\x{9000}\x{9001}\x{9002}";
457     $e =    "\$c = \$s =~ tr/\\x00-\\xff/"
458           . ("ABCDEFGHIJKLMNO" x (0xa000 / 15))
459           . "/c; 1; ";
460     eval $e or die $@;
461     is $s, "IJK", "RT #132608 len=0xa000";
462     is $c, 3, "RT #132608 len=0xa000 count";
463
464     $s = "\x{9003}\x{9004}\x{9005}";
465     $e =    "\$c = \$s =~ tr/\\x00-\\xff/"
466           . ("ABCDEFGHIJKLMNO" x (0x12000 / 15))
467           . "/c; 1; ";
468     eval $e or die $@;
469     is $s, "LMN", "RT #132608 len=0x12000";
470     is $c, 3, "RT #132608 len=0x12000 count";
471 }
472
473
474 SKIP: {   # Test literal range end point special handling
475     unless ($::IS_EBCDIC) {
476         skip "Valid only for EBCDIC", 24;
477     }
478
479     $_ = "\x89";    # is 'i'
480     tr/i-j//d;
481     is($_, "", '"\x89" should match [i-j]');
482     $_ = "\x8A";
483     tr/i-j//d;
484     is($_, "\x8A", '"\x8A" shouldnt match [i-j]');
485     $_ = "\x90";
486     tr/i-j//d;
487     is($_, "\x90", '"\x90" shouldnt match [i-j]');
488     $_ = "\x91";    # is 'j'
489     tr/i-j//d;
490     is($_, "", '"\x91" should match [i-j]');
491
492     $_ = "\x89";
493     tr/i-\N{LATIN SMALL LETTER J}//d;
494     is($_, "", '"\x89" should match [i-\N{LATIN SMALL LETTER J}]');
495     $_ = "\x8A";
496     tr/i-\N{LATIN SMALL LETTER J}//d;
497     is($_, "\x8A", '"\x8A" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
498     $_ = "\x90";
499     tr/i-\N{LATIN SMALL LETTER J}//d;
500     is($_, "\x90", '"\x90" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
501     $_ = "\x91";
502     tr/i-\N{LATIN SMALL LETTER J}//d;
503     is($_, "", '"\x91" should match [i-\N{LATIN SMALL LETTER J}]');
504
505     $_ = "\x89";
506     tr/i-\N{U+6A}//d;
507     is($_, "", '"\x89" should match [i-\N{U+6A}]');
508     $_ = "\x8A";
509     tr/i-\N{U+6A}//d;
510     is($_, "\x8A", '"\x8A" shouldnt match [i-\N{U+6A}]');
511     $_ = "\x90";
512     tr/i-\N{U+6A}//d;
513     is($_, "\x90", '"\x90" shouldnt match [i-\N{U+6A}]');
514     $_ = "\x91";
515     tr/i-\N{U+6A}//d;
516     is($_, "", '"\x91" should match [i-\N{U+6A}]');
517
518     $_ = "\x89";
519     tr/\N{U+69}-\N{U+6A}//d;
520     is($_, "", '"\x89" should match [\N{U+69}-\N{U+6A}]');
521     $_ = "\x8A";
522     tr/\N{U+69}-\N{U+6A}//d;
523     is($_, "\x8A", '"\x8A" shouldnt match [\N{U+69}-\N{U+6A}]');
524     $_ = "\x90";
525     tr/\N{U+69}-\N{U+6A}//d;
526     is($_, "\x90", '"\x90" shouldnt match [\N{U+69}-\N{U+6A}]');
527     $_ = "\x91";
528     tr/\N{U+69}-\N{U+6A}//d;
529     is($_, "", '"\x91" should match [\N{U+69}-\N{U+6A}]');
530
531     $_ = "\x89";
532     tr/i-\x{91}//d;
533     is($_, "", '"\x89" should match [i-\x{91}]');
534     $_ = "\x8A";
535     tr/i-\x{91}//d;
536     is($_, "", '"\x8A" should match [i-\x{91}]');
537     $_ = "\x90";
538     tr/i-\x{91}//d;
539     is($_, "", '"\x90" should match [i-\x{91}]');
540     $_ = "\x91";
541     tr/i-\x{91}//d;
542     is($_, "", '"\x91" should match [i-\x{91}]');
543
544     # Need to use eval, because tries to compile on ASCII platforms even
545     # though the tests are skipped, and fails because 0x89-j is an illegal
546     # range there.
547     $_ = "\x89";
548     eval 'tr/\x{89}-j//d';
549     is($_, "", '"\x89" should match [\x{89}-j]');
550     $_ = "\x8A";
551     eval 'tr/\x{89}-j//d';
552     is($_, "", '"\x8A" should match [\x{89}-j]');
553     $_ = "\x90";
554     eval 'tr/\x{89}-j//d';
555     is($_, "", '"\x90" should match [\x{89}-j]');
556     $_ = "\x91";
557     eval 'tr/\x{89}-j//d';
558     is($_, "", '"\x91" should match [\x{89}-j]');
559 }
560
561
562 # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
563 # Yes, discontinuities.  Regardless, the \xca in the below should stay
564 # untouched (and not became \x8a).
565 {
566     $_ = "I\xcaJ";
567
568     tr/I-J/i-j/;
569
570     is($_, "i\xcaj",    'EBCDIC discontinuity');
571 }
572 #
573
574 ($x = 12) =~ tr/1/3/;
575 (my $y = 12) =~ tr/1/3/;
576 ($f = 1.5) =~ tr/1/3/;
577 (my $g = 1.5) =~ tr/1/3/;
578 is($x + $y + $f + $g, 71,   'tr cancels IOK and NOK');
579
580 # /r
581 $_ = 'adam';
582 is y/dam/ve/rd, 'eve', '/r';
583 is $_, 'adam', '/r leaves param alone';
584 $g = 'ruby';
585 is $g =~ y/bury/repl/r, 'perl', '/r with explicit param';
586 is $g, 'ruby', '/r leaves explicit param alone';
587 is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param';
588 ok !eval '$_ !~ y///r', "!~ y///r is forbidden";
589 like $@, qr\^Using !~ with tr///r doesn't make sense\,
590   "!~ y///r error message";
591 {
592   my $w;
593   my $wc;
594   local $SIG{__WARN__} = sub { $w = shift; ++$wc };
595   local $^W = 1;
596   eval 'y///r; 1';
597   like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)',
598     '/r warns in void context';
599   is $wc, 1, '/r warns just once';
600 }
601
602 # perlbug [ID 20000511.005 (#3237)]
603 $_ = 'fred';
604 /([a-z]{2})/;
605 $1 =~ tr/A-Z//;
606 s/^(\s*)f/$1F/;
607 is($_, 'Fred',  'harmless if explicitly not updating');
608
609
610 # A variant of the above, added in 5.7.2
611 $_ = 'fred';
612 /([a-z]{2})/;
613 eval '$1 =~ tr/A-Z/A-Z/;';
614 s/^(\s*)f/$1F/;
615 is($_, 'Fred',  'harmless if implicitly not updating');
616 is($@, '',      '    no error');
617
618
619 # check tr handles UTF8 correctly
620 ($x = 256.65.258) =~ tr/a/b/;
621 is($x, 256.65.258,  'handles UTF8');
622 is(length $x, 3);
623
624 $x =~ tr/A/B/;
625 is(length $x, 3);
626 if ($::IS_ASCII) { # ASCII
627     is($x, 256.66.258);
628 }
629 else {
630     is($x, 256.65.258);
631 }
632
633 # EBCDIC variants of the above tests
634 ($x = 256.193.258) =~ tr/a/b/;
635 is(length $x, 3);
636 is($x, 256.193.258);
637
638 $x =~ tr/A/B/;
639 is(length $x, 3);
640 if ($::IS_ASCII) { # ASCII
641     is($x, 256.193.258);
642 }
643 else {
644     is($x, 256.194.258);
645 }
646
647
648 {
649     my $l = chr(300); my $r = chr(400);
650     $x = 200.300.400;
651     $x =~ tr/\x{12c}/\x{190}/;
652     is($x, 200.400.400,     
653                         'changing UTF8 chars in a UTF8 string, same length');
654     is(length $x, 3);
655
656     $x = 200.300.400;
657     $x =~ tr/\x{12c}/\x{be8}/;
658     is($x, 200.3048.400,    '    more bytes');
659     is(length $x, 3);
660
661     $x = 100.125.60;
662     $x =~ tr/\x{64}/\x{190}/;
663     is($x, 400.125.60,      'Putting UT8 chars into a non-UTF8 string');
664     is(length $x, 3);
665
666     $x = 400.125.60;
667     $x =~ tr/\x{190}/\x{64}/;
668     is($x, 100.125.60,      'Removing UTF8 chars from UTF8 string');
669     is(length $x, 3);
670
671     $x = 400.125.60.400;
672     $y = $x =~ tr/\x{190}/\x{190}/;
673     is($y, 2,               'Counting UTF8 chars in UTF8 string');
674
675     $x = 60.400.125.60.400;
676     $y = $x =~ tr/\x{3c}/\x{3c}/;
677     is($y, 2,               '         non-UTF8 chars in UTF8 string');
678
679     # 17 - counting UTF8 chars in non-UTF8 string
680     $x = 200.125.60;
681     $y = $x =~ tr/\x{190}/\x{190}/;
682     is($y, 0,               '         UTF8 chars in non-UTFs string');
683 }
684
685 $_ = "abcdefghijklmnopqrstuvwxyz";
686 eval 'tr/a-z-9/ /';
687 like($@, qr/^Ambiguous range in transliteration operator/,  'tr/a-z-9//');
688
689 # 19-21: Make sure leading and trailing hyphens still work
690 $_ = "car-rot9";
691 tr/-a-m/./;
692 is($_, '..r.rot9',  'hyphens, leading');
693
694 $_ = "car-rot9";
695 tr/a-m-/./;
696 is($_, '..r.rot9',  '   trailing');
697
698 $_ = "car-rot9";
699 tr/-a-m-/./;
700 is($_, '..r.rot9',  '   both');
701
702 $_ = "abcdefghijklmnop";
703 tr/ae-hn/./;
704 is($_, '.bcd....ijklm.op');
705
706 $_ = "abcdefghijklmnop";
707 tr/a-cf-kn-p/./;
708 is($_, '...de......lm...');
709
710 $_ = "abcdefghijklmnop";
711 tr/a-ceg-ikm-o/./;
712 is($_, '...d.f...j.l...p');
713
714
715 # 20000705 MJD
716 eval "tr/m-d/ /";
717 like($@, qr/^Invalid range "m-d" in transliteration operator/,
718               'reversed range check');
719
720 'abcdef' =~ /(bcd)/;
721 is(eval '$1 =~ tr/abcd//', 3,  'explicit read-only count');
722 is($@, '',                      '    no error');
723
724 'abcdef' =~ /(bcd)/;
725 is(eval '$1 =~ tr/abcd/abcd/', 3,  'implicit read-only count');
726 is($@, '',                      '    no error');
727
728 is(eval '"123" =~ tr/12//', 2,     'LHS of non-updating tr');
729
730 eval '"123" =~ tr/1/2/';
731 like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
732          'LHS bad on updating tr');
733
734
735 # v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
736 # v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
737
738 # Transliterate a byte to a byte, all four ways.
739
740 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
741 is($a, v300.197.172.300.197.172,    'byte2byte transliteration');
742
743 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
744 is($a, v300.197.172.300.197.172);
745
746 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
747 is($a, v300.197.172.300.197.172);
748
749 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
750 is($a, v300.197.172.300.197.172);
751
752
753 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
754 is($a, v300.301.172.300.301.172,    'byte2wide transliteration');
755
756 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
757 is($a, v195.196.172.195.196.172,    '   wide2byte');
758
759 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
760 is($a, v301.196.172.301.196.172,    '   wide2wide');
761
762
763 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
764 is($a, v195.301.172.195.301.172,    'byte2wide & wide2byte');
765
766
767 ($a = v300.196.172.300.196.172.400.198.144) =~
768         tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
769 is($a, v197.301.173.197.301.173.401.198.144,    'all together now!');
770
771
772 is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
773                                      'transliterate and count');
774
775 is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
776
777
778 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
779 is($a, v301.196.301.301.196.301,    'translit w/complement');
780
781 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
782 is($a, v300.197.197.300.197.197);
783
784
785 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
786 is($a, v300.172.300.172,            'translit w/deletion');
787
788 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
789 is($a, v196.172.196.172);
790
791
792 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
793 is($a, v197.172.300.300.197.172,    'translit w/squeeze');
794
795 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
796 is($a, v196.172.301.196.172.172);
797
798
799 # Tricky cases (When Simon Cozens Attacks)
800 ($a = v196.172.200) =~ tr/\x{12c}/a/;
801 is(sprintf("%vd", $a), '196.172.200');
802
803 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
804 is(sprintf("%vd", $a), '196.172.200');
805
806 ($a = v196.172.200) =~ tr/\x{12c}//d;
807 is(sprintf("%vd", $a), '196.172.200');
808
809
810 # UTF8 range tests from Inaba Hiroto
811
812 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
813 is($a, v192.196.172.194.197.172,    'UTF range');
814
815 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
816 is($a, v300.300.172.302.301.172);
817
818
819 # UTF8 range tests from Karsten Sperling (patch #9008 required)
820
821 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
822 is($a, "X");
823
824 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
825 is($a, "X");
826
827 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
828 is($a, "X");
829  
830 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
831 is($a, "X");
832
833
834 # UTF8 range tests from Inaba Hiroto
835
836 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
837 is($a, "X");
838
839 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
840 is($a, "X");
841
842 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters (as
843 # well as i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
844 # from Karsten Sperling.
845
846 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
847 is($c, 8);
848 is($a, "XXXXXXXX");
849
850 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
851 is($c, 8);
852 is($a, "XXXXXXXX");
853
854 SKIP: {
855     skip "EBCDIC-centric tests", 4 unless $::IS_EBCDIC;
856
857     $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
858     is($c, 2);
859     is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
860    
861     $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
862     is($c, 2);
863     is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
864 }
865
866 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
867 is(ord($a), ord("X"));
868
869 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
870 is(ord($a), ord("X"));
871
872 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
873 is($a, "\x{100}\x{100}");
874
875 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
876 is($a, "\x{100}");
877
878 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
879 is($a, "\x{1ff}\x{1fe}");
880
881
882 # From David Dyck
883 ($a = "R0_001") =~ tr/R_//d;
884 is(hex($a), 1);
885
886 # From Inaba Hiroto
887 @a = (1,2); map { y/1/./ for $_ } @a;
888 is("@a", ". 2");
889
890 @a = (1,2); map { y/1/./ for $_.'' } @a;
891 is("@a", "1 2");
892
893
894 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
895 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
896 is($a, "XZY");
897
898
899 # Used to fail with "Modification of a read-only value attempted"
900 %a = (N=>1);
901 foreach (keys %a) {
902   eval 'tr/N/n/';
903   is($_, 'n',   'pp_trans needs to unshare shared hash keys');
904   is($@, '',    '   no error');
905 }
906
907
908 $x = eval '"1213" =~ tr/1/1/';
909 is($x, 2,   'implicit count on constant');
910 is($@, '',  '   no error');
911
912
913 my @foo = ();
914 eval '$foo[-1] =~ tr/N/N/';
915 is( $@, '',         'implicit count outside array bounds, index negative' );
916 is( scalar @foo, 0, "    doesn't extend the array");
917
918 eval '$foo[1] =~ tr/N/N/';
919 is( $@, '',         'implicit count outside array bounds, index positive' );
920 is( scalar @foo, 0, "    doesn't extend the array");
921
922
923 my %foo = ();
924 eval '$foo{bar} =~ tr/N/N/';
925 is( $@, '',         'implicit count outside hash bounds' );
926 is( scalar keys %foo, 0,   "    doesn't extend the hash");
927
928 $x = \"foo";
929 is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
930 is( ref $x, 'SCALAR', "    doesn't stringify its argument" );
931
932 # rt.perl.org 36622.  Perl didn't like a y/// at end of file.  No trailing
933 # newline allowed.
934 fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '', {}, 'RT #36622 y/// at end of file');
935
936
937 { # [perl #38293] chr(65535) should be allowed in regexes
938 no warnings 'utf8'; # to allow non-characters
939
940 $s = "\x{d800}\x{ffff}";
941 $s =~ tr/\0/A/;
942 is($s, "\x{d800}\x{ffff}", "do_trans_simple");
943
944 $s = "\x{d800}\x{ffff}";
945 $i = $s =~ tr/\0//;
946 is($i, 0, "do_trans_count");
947
948 $s = "\x{d800}\x{ffff}";
949 $s =~ tr/\0/A/s;
950 is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH");
951
952 $s = "\x{d800}\x{ffff}";
953 $s =~ tr/\0/A/c;
954 is($s, "AA", "do_trans_complex, COMPLEMENT");
955
956 $s = "A\x{ffff}B";
957 $s =~ tr/\x{ffff}/\x{1ffff}/;
958 is($s, "A\x{1ffff}B", "utf8, SEARCHLIST");
959
960 $s = "\x{fffd}\x{fffe}\x{ffff}";
961 $s =~ tr/\x{fffd}-\x{ffff}/ABC/;
962 is($s, "ABC", "utf8, SEARCHLIST range");
963
964 $s = "ABC";
965 $s =~ tr/ABC/\x{ffff}/;
966 is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST");
967
968 $s = "ABC";
969 $s =~ tr/ABC/\x{fffd}-\x{ffff}/;
970 is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range");
971
972 $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}";
973 $i = $s =~ tr/\x{ffff}//;
974 is($i, 2, "utf8, count");
975
976 $s = "A\x{ffff}\x{ffff}C";
977 $s =~ tr/\x{ffff}/\x{100}/s;
978 is($s, "A\x{100}C", "utf8, SQUASH");
979
980 $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C";
981 $s =~ tr/\x{fffe}\x{ffff}//s;
982 is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH");
983
984 $s = "xAABBBy";
985 $s =~ tr/AB/\x{ffff}/s;
986 is($s, "x\x{ffff}y", "utf8, SQUASH");
987
988 $s = "xAABBBy";
989 $s =~ tr/AB/\x{fffe}\x{ffff}/s;
990 is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH");
991
992 $s = "A\x{ffff}B\x{fffe}C";
993 $s =~ tr/\x{fffe}\x{ffff}/x/c;
994 is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT");
995
996 $s = "A\x{10000}B\x{2abcd}C";
997 $s =~ tr/\0-\x{ffff}/x/c;
998 is($s, "AxBxC", "utf8, COMPLEMENT range");
999
1000 $s = "A\x{fffe}B\x{ffff}C";
1001 $s =~ tr/\x{fffe}\x{ffff}/x/d;
1002 is($s, "AxBC", "utf8, DELETE");
1003
1004 } # non-characters end
1005
1006 { # related to [perl #27940]
1007     my $c;
1008
1009     ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d;
1010     is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d");
1011
1012     ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d;
1013     is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d");
1014 }
1015
1016 ($s) = keys %{{pie => 3}};
1017 SKIP: {
1018     if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 }
1019     my $wasro = XS::APItest::SvIsCOW($s);
1020     ok $wasro, "have a COW";
1021     $s =~ tr/i//;
1022     ok( XS::APItest::SvIsCOW($s),
1023        "count-only tr doesn't deCOW COWs" );
1024 }
1025
1026 # [ RT #61520 ]
1027 #
1028 # under threads, unicode tr within a cloned closure would SEGV or assert
1029 # fail, since the pointer in the pad to the swash was getting zeroed out
1030 # in the proto-CV
1031
1032 {
1033     my $x = "\x{142}";
1034     sub {
1035         $x =~ tr[\x{142}][\x{143}];
1036     }->();
1037     is($x,"\x{143}", "utf8 + closure");
1038 }
1039
1040 # Freeing of trans ops prior to pmtrans() [perl #102858].
1041 eval q{ $a ~= tr/a/b/; };
1042 ok 1;
1043 SKIP: {
1044     no warnings "deprecated";
1045     skip "no encoding", 1 unless eval { require encoding; 1 };
1046     eval q{ use encoding "utf8"; $a ~= tr/a/b/; };
1047     ok 1;
1048 }
1049
1050 { # [perl #113584]
1051
1052     my $x = "Perlα";
1053     $x =~ tr/αα/βγ/;
1054     { no warnings 'utf8'; print "# $x\n"; } # No note() to avoid wide warning.
1055     is($x, "Perlβ", "Only first of multiple transliterations is used");
1056 }
1057
1058 # tr/a/b/ should fail even on zero-length read-only strings
1059 use constant nullrocow => (keys%{{""=>undef}})[0];
1060 for ("", nullrocow) {
1061     eval { $_ =~ y/a/b/ };
1062     like $@, qr/^Modification of a read-only value attempted at /,
1063         'tr/a/b/ fails on zero-length ro string';
1064 }
1065
1066 # Whether they're permitted or not, non-modifying tr/// should not write
1067 # to read-only values, even with funky flags.
1068 { # [perl #123759]
1069         eval q{ ('a' =~ /./) =~ tr///d };
1070         ok(1, "tr///d on PL_Yes does not assert");
1071         eval q{ ('a' =~ /./) =~ tr/a-z/a-z/d };
1072         ok(1, "tr/a-z/a-z/d on PL_Yes does not assert");
1073         eval q{ ('a' =~ /./) =~ tr///s };
1074         ok(1, "tr///s on PL_Yes does not assert");
1075         eval q{ *x =~ tr///d };
1076         ok(1, "tr///d on glob does not assert");
1077 }
1078
1079 { # [perl #128734
1080     my $string = chr utf8::unicode_to_native(0x00e0);
1081     $string =~ tr/\N{U+00e0}/A/;
1082     is($string, "A", 'tr// of \N{U+...} works for upper-Latin1');
1083     my $string = chr utf8::unicode_to_native(0x00e1);
1084     $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/;
1085     is($string, "A", 'tr// of \N{name} works for upper-Latin1');
1086 }
1087
1088 # RT #130198
1089 # a tr/// that is cho(m)ped, possibly with an array as arg
1090
1091 {
1092     use warnings;
1093
1094     my ($s, @a);
1095
1096     my $warn;
1097     local $SIG{__WARN__ } = sub { $warn .= "@_" };
1098
1099     for my $c (qw(chop chomp)) {
1100         for my $bind ('', '$s =~ ', '@a =~ ') {
1101             for my $arg2 (qw(a b)) {
1102                 for my $r ('', 'r') {
1103                     $warn = '';
1104                     # tr/a/b/ modifies its LHS, so if the LHS is an
1105                     # array, this should die. The special cases of tr/a/a/
1106                     # and tr/a/b/r don't modify their LHS, so instead
1107                     # we croak because cho(m)p is trying to modify it.
1108                     #
1109                     my $exp =
1110                         ($r eq '' && $arg2 eq 'b' && $bind =~ /\@a/)
1111                             ? qr/Can't modify private array in transliteration/
1112                             : qr{Can't modify transliteration \(tr///\) in $c};
1113
1114                     my $expr = "$c(${bind}tr/a/$arg2/$r);";
1115                     eval $expr;
1116                     like $@, $exp, "RT #130198 eval: $expr";
1117
1118                     $exp =
1119                         $bind =~ /\@a/
1120                          ? qr{^Applying transliteration \(tr///\) to \@a will act on scalar\(\@a\)}
1121                          : qr/^$/;
1122                     like $warn, $exp, "RT #130198 warn: $expr";
1123                 }
1124             }
1125         }
1126     }
1127
1128
1129 }
1130
1131 {   # [perl #130656] This bug happens when the tr is split across lines, so
1132     # that the first line causes it to go into UTF-8, and the 2nd is only
1133     # things like \x
1134     my $x = "\x{E235}";
1135     $x =~ tr
1136     [\x{E234}-\x{E342}\x{E5B5}-\x{E5DF}]
1137     [\x{E5CD}-\x{E5DF}\x{EA80}-\x{EAFA}\x{EB0E}-\x{EB8E}\x{EAFB}-\x{EB0D}\x{E5B5}-\x{E5CC}];
1138
1139     is $x, "\x{E5CE}", '[perl #130656]';
1140 }
1141
1142 1;