1# tr.t 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9plan tests => 99; 10 11my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1); 12 13$_ = "abcdefghijklmnopqrstuvwxyz"; 14 15tr/a-z/A-Z/; 16 17is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc'); 18 19tr/A-Z/a-z/; 20 21is($_, "abcdefghijklmnopqrstuvwxyz", 'lc'); 22 23tr/b-y/B-Y/; 24is($_, "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/; 45is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK'); 46 47 48# perlbug [ID 20000511.005] 49$_ = 'fred'; 50/([a-z]{2})/; 51$1 =~ tr/A-Z//; 52s/^(\s*)f/$1F/; 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 64 65# check tr handles UTF8 correctly 66($x = 256.65.258) =~ tr/a/b/; 67is($x, 256.65.258, 'handles UTF8'); 68is(length $x, 3); 69 70$x =~ tr/A/B/; 71is(length $x, 3); 72if (ord("\t") == 9) { # ASCII 73 is($x, 256.66.258); 74} 75else { 76 is($x, 256.65.258); 77} 78 79# EBCDIC variants of the above tests 80($x = 256.193.258) =~ tr/a/b/; 81is(length $x, 3); 82is($x, 256.193.258); 83 84$x =~ tr/A/B/; 85is(length $x, 3); 86if (ord("\t") == 9) { # ASCII 87 is($x, 256.193.258); 88} 89else { 90 is($x, 256.194.258); 91} 92 93 94{ 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'); 129} 130 131$_ = "abcdefghijklmnopqrstuvwxyz"; 132eval 'tr/a-z-9/ /'; 133like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//'); 134 135# 19-21: Make sure leading and trailing hyphens still work 136$_ = "car-rot9"; 137tr/-a-m/./; 138is($_, '..r.rot9', 'hyphens, leading'); 139 140$_ = "car-rot9"; 141tr/a-m-/./; 142is($_, '..r.rot9', ' trailing'); 143 144$_ = "car-rot9"; 145tr/-a-m-/./; 146is($_, '..r.rot9', ' both'); 147 148$_ = "abcdefghijklmnop"; 149tr/ae-hn/./; 150is($_, '.bcd....ijklm.op'); 151 152$_ = "abcdefghijklmnop"; 153tr/a-cf-kn-p/./; 154is($_, '...de......lm...'); 155 156$_ = "abcdefghijklmnop"; 157tr/a-ceg-ikm-o/./; 158is($_, '...d.f...j.l...p'); 159 160 161# 20000705 MJD 162eval "tr/m-d/ /"; 163like($@, qr/^Invalid range "m-d" in transliteration operator/, 164 'reversed range check'); 165 166eval '$1 =~ tr/x/y/'; 167like($@, qr/^Modification of a read-only value attempted/, 168 'cannot update read-only var'); 169 170'abcdef' =~ /(bcd)/; 171is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count'); 172is($@, '', ' no error'); 173 174'abcdef' =~ /(bcd)/; 175is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count'); 176is($@, '', ' no error'); 177 178is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr'); 179 180eval '"123" =~ tr/1/2/'; 181like($@, qr|^Can't modify constant item in transliteration \(tr///\)|, 182 'LHS bad on updating tr'); 183 184 185# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) 186# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) 187 188# Transliterate a byte to a byte, all four ways. 189 190($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; 191is($a, v300.197.172.300.197.172, 'byte2byte transliteration'); 192 193($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; 194is($a, v300.197.172.300.197.172); 195 196($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; 197is($a, v300.197.172.300.197.172); 198 199($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; 200is($a, v300.197.172.300.197.172); 201 202 203($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; 204is($a, v300.301.172.300.301.172, 'byte2wide transliteration'); 205 206($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; 207is($a, v195.196.172.195.196.172, ' wide2byte'); 208 209($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; 210is($a, v301.196.172.301.196.172, ' wide2wide'); 211 212 213($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; 214is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte'); 215 216 217($a = v300.196.172.300.196.172.400.198.144) =~ 218 tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; 219is($a, v197.301.173.197.301.173.401.198.144, 'all together now!'); 220 221 222is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2, 223 'transliterate and count'); 224 225is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2); 226 227 228($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; 229is($a, v301.196.301.301.196.301, 'translit w/complement'); 230 231($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; 232is($a, v300.197.197.300.197.197); 233 234 235($a = v300.196.172.300.196.172) =~ tr/\xc4//d; 236is($a, v300.172.300.172, 'translit w/deletion'); 237 238($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; 239is($a, v196.172.196.172); 240 241 242($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; 243is($a, v197.172.300.300.197.172, 'translit w/squeeze'); 244 245($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; 246is($a, v196.172.301.196.172.172); 247 248 249# Tricky cases (When Simon Cozens Attacks) 250($a = v196.172.200) =~ tr/\x{12c}/a/; 251is(sprintf("%vd", $a), '196.172.200'); 252 253($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; 254is(sprintf("%vd", $a), '196.172.200'); 255 256($a = v196.172.200) =~ tr/\x{12c}//d; 257is(sprintf("%vd", $a), '196.172.200'); 258 259 260# UTF8 range tests from Inaba Hiroto 261 262# Not working in EBCDIC as of 12674. 263($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; 264is($a, v192.196.172.194.197.172, 'UTF range'); 265 266($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; 267is($a, v300.300.172.302.301.172); 268 269 270# UTF8 range tests from Karsten Sperling (patch #9008 required) 271 272($a = "\x{0100}") =~ tr/\x00-\x{100}/X/; 273is($a, "X"); 274 275($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c; 276is($a, "X"); 277 278($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; 279is($a, "X"); 280 281($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c; 282is($a, "X"); 283 284 285# UTF8 range tests from Inaba Hiroto 286 287($a = "\x{200}") =~ tr/\x00-\x{100}/X/c; 288is($a, "X"); 289 290($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs; 291is($a, "X"); 292 293 294# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters, 295# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them, 296# from Karsten Sperling. 297 298# Not working in EBCDIC as of 12674. 299$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/; 300is($c, 8); 301is($a, "XXXXXXXX"); 302 303# Not working in EBCDIC as of 12674. 304$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/; 305is($c, 8); 306is($a, "XXXXXXXX"); 307 308 309SKIP: { 310 skip "not EBCDIC", 4 unless $Is_EBCDIC; 311 312 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/; 313 is($c, 2); 314 is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X"); 315 316 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/; 317 is($c, 2); 318 is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X"); 319} 320 321($a = "\x{100}") =~ tr/\x00-\xff/X/c; 322is(ord($a), ord("X")); 323 324($a = "\x{100}") =~ tr/\x00-\xff/X/cs; 325is(ord($a), ord("X")); 326 327($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c; 328is($a, "\x{100}\x{100}"); 329 330($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs; 331is($a, "\x{100}"); 332 333$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/; 334is($a, "\x{1ff}\x{1fe}"); 335 336 337# From David Dyck 338($a = "R0_001") =~ tr/R_//d; 339is(hex($a), 1); 340 341# From Inaba Hiroto 342@a = (1,2); map { y/1/./ for $_ } @a; 343is("@a", ". 2"); 344 345@a = (1,2); map { y/1/./ for $_.'' } @a; 346is("@a", "1 2"); 347 348 349# Additional test for Inaba Hiroto patch (robin@kitsite.com) 350($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c; 351is($a, "XZY"); 352 353 354# Used to fail with "Modification of a read-only value attempted" 355%a = (N=>1); 356foreach (keys %a) { 357 eval 'tr/N/n/'; 358 is($_, 'n', 'pp_trans needs to unshare shared hash keys'); 359 is($@, '', ' no error'); 360} 361 362 363$x = eval '"1213" =~ tr/1/1/'; 364is($x, 2, 'implicit count on constant'); 365is($@, '', ' no error'); 366 367 368my @foo = (); 369eval '$foo[-1] =~ tr/N/N/'; 370is( $@, '', 'implicit count outside array bounds, index negative' ); 371is( scalar @foo, 0, " doesn't extend the array"); 372 373eval '$foo[1] =~ tr/N/N/'; 374is( $@, '', 'implicit count outside array bounds, index positive' ); 375is( scalar @foo, 0, " doesn't extend the array"); 376 377 378my %foo = (); 379eval '$foo{bar} =~ tr/N/N/'; 380is( $@, '', 'implicit count outside hash bounds' ); 381is( scalar keys %foo, 0, " doesn't extend the hash"); 382 383$x = \"foo"; 384is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' ); 385is( ref $x, 'SCALAR', " doesn't stringify its argument" ); 386