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