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