t/op/tr.t

   1 # tr.t
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan tests => 118;
  10
  11 my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
  12
  13 $_ = "abcdefghijklmnopqrstuvwxyz";
  14
  15 tr/a-z/A-Z/;
  16
  17 is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ",    'uc');
  18
  19 tr/A-Z/a-z/;
  20
  21 is($_, "abcdefghijklmnopqrstuvwxyz",    'lc');
  22
  23 tr/b-y/B-Y/;
  24 is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz",    'partial uc');
  25
  26
  27 # In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
  28 # Yes, discontinuities.  Regardless, the \xca in the below should stay
  29 # untouched (and not became \x8a).
  30 {
  31     no utf8;
  32     $_ = "I\xcaJ";
  33
  34     tr/I-J/i-j/;
  35
  36     is($_, "i\xcaj",    'EBCDIC discontinuity');
  37 }
  38 #
  39
  40
  41 ($x = 12) =~ tr/1/3/;
  42 (my $y = 12) =~ tr/1/3/;
  43 ($f = 1.5) =~ tr/1/3/;
  44 (my $g = 1.5) =~ tr/1/3/;
  45 is($x + $y + $f + $g, 71,   'tr cancels IOK and NOK');
  46
  47
  48 # perlbug [ID 20000511.005]
  49 $_ = 'fred';
  50 /([a-z]{2})/;
  51 $1 =~ tr/A-Z//;
  52 s/^(\s*)f/$1F/;
  53 is($_, '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})/;
  59 eval '$1 =~ tr/A-Z/A-Z/;';
  60 s/^(\s*)f/$1F/;
  61 is($_, 'Fred',  'harmless if implicitly not updating');
  62 is($@, '',      '    no error');
  63
  64
  65 # check tr handles UTF8 correctly
  66 ($x = 256.65.258) =~ tr/a/b/;
  67 is($x, 256.65.258,  'handles UTF8');
  68 is(length $x, 3);
  69
  70 $x =~ tr/A/B/;
  71 is(length $x, 3);
  72 if (ord("\t") == 9) { # ASCII
  73     is($x, 256.66.258);
  74 }
  75 else {
  76     is($x, 256.65.258);
  77 }
  78
  79 # EBCDIC variants of the above tests
  80 ($x = 256.193.258) =~ tr/a/b/;
  81 is(length $x, 3);
  82 is($x, 256.193.258);
  83
  84 $x =~ tr/A/B/;
  85 is(length $x, 3);
  86 if (ord("\t") == 9) { # ASCII
  87     is($x, 256.193.258);
  88 }
  89 else {
  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";
 132 eval 'tr/a-z-9/ /';
 133 like($@, 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";
 137 tr/-a-m/./;
 138 is($_, '..r.rot9',  'hyphens, leading');
 139
 140 $_ = "car-rot9";
 141 tr/a-m-/./;
 142 is($_, '..r.rot9',  '   trailing');
 143
 144 $_ = "car-rot9";
 145 tr/-a-m-/./;
 146 is($_, '..r.rot9',  '   both');
 147
 148 $_ = "abcdefghijklmnop";
 149 tr/ae-hn/./;
 150 is($_, '.bcd....ijklm.op');
 151
 152 $_ = "abcdefghijklmnop";
 153 tr/a-cf-kn-p/./;
 154 is($_, '...de......lm...');
 155
 156 $_ = "abcdefghijklmnop";
 157 tr/a-ceg-ikm-o/./;
 158 is($_, '...d.f...j.l...p');
 159
 160
 161 # 20000705 MJD
 162 eval "tr/m-d/ /";
 163 like($@, qr/^Invalid range "m-d" in transliteration operator/,
 164               'reversed range check');
 165
 166 eval '$1 =~ tr/x/y/';
 167 like($@, qr/^Modification of a read-only value attempted/,
 168               'cannot update read-only var');
 169
 170 'abcdef' =~ /(bcd)/;
 171 is(eval '$1 =~ tr/abcd//', 3,  'explicit read-only count');
 172 is($@, '',                      '    no error');
 173
 174 'abcdef' =~ /(bcd)/;
 175 is(eval '$1 =~ tr/abcd/abcd/', 3,  'implicit read-only count');
 176 is($@, '',                      '    no error');
 177
 178 is(eval '"123" =~ tr/12//', 2,     'LHS of non-updating tr');
 179
 180 eval '"123" =~ tr/1/2/';
 181 like($@, 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/;
 191 is($a, v300.197.172.300.197.172,    'byte2byte transliteration');
 192
 193 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
 194 is($a, v300.197.172.300.197.172);
 195
 196 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
 197 is($a, v300.197.172.300.197.172);
 198
 199 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
 200 is($a, v300.197.172.300.197.172);
 201
 202
 203 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
 204 is($a, v300.301.172.300.301.172,    'byte2wide transliteration');
 205
 206 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
 207 is($a, v195.196.172.195.196.172,    '   wide2byte');
 208
 209 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
 210 is($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/;
 214 is($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}/;
 219 is($a, v197.301.173.197.301.173.401.198.144,    'all together now!');
 220
 221
 222 is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
 223                                      'transliterate and count');
 224
 225 is((($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;
 229 is($a, v301.196.301.301.196.301,    'translit w/complement');
 230
 231 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
 232 is($a, v300.197.197.300.197.197);
 233
 234
 235 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
 236 is($a, v300.172.300.172,            'translit w/deletion');
 237
 238 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
 239 is($a, v196.172.196.172);
 240
 241
 242 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
 243 is($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;
 246 is($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/;
 251 is(sprintf("%vd", $a), '196.172.200');
 252
 253 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
 254 is(sprintf("%vd", $a), '196.172.200');
 255
 256 ($a = v196.172.200) =~ tr/\x{12c}//d;
 257 is(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/;
 264 is($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}/;
 267 is($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/;
 273 is($a, "X");
 274
 275 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
 276 is($a, "X");
 277
 278 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
 279 is($a, "X");
 280
 281 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
 282 is($a, "X");
 283
 284
 285 # UTF8 range tests from Inaba Hiroto
 286
 287 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
 288 is($a, "X");
 289
 290 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
 291 is($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 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
 299 is($c, 8);
 300 is($a, "XXXXXXXX");
 301
 302 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
 303 is($c, 8);
 304 is($a, "XXXXXXXX");
 305
 306 SKIP: {
 307     skip "not EBCDIC", 4 unless $Is_EBCDIC;
 308
 309     $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
 310     is($c, 2);
 311     is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
 312
 313     $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
 314     is($c, 2);
 315     is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
 316 }
 317
 318 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
 319 is(ord($a), ord("X"));
 320
 321 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
 322 is(ord($a), ord("X"));
 323
 324 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
 325 is($a, "\x{100}\x{100}");
 326
 327 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
 328 is($a, "\x{100}");
 329
 330 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
 331 is($a, "\x{1ff}\x{1fe}");
 332
 333
 334 # From David Dyck
 335 ($a = "R0_001") =~ tr/R_//d;
 336 is(hex($a), 1);
 337
 338 # From Inaba Hiroto
 339 @a = (1,2); map { y/1/./ for $_ } @a;
 340 is("@a", ". 2");
 341
 342 @a = (1,2); map { y/1/./ for $_.'' } @a;
 343 is("@a", "1 2");
 344
 345
 346 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
 347 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
 348 is($a, "XZY");
 349
 350
 351 # Used to fail with "Modification of a read-only value attempted"
 352 %a = (N=>1);
 353 foreach (keys %a) {
 354   eval 'tr/N/n/';
 355   is($_, 'n',   'pp_trans needs to unshare shared hash keys');
 356   is($@, '',    '   no error');
 357 }
 358
 359
 360 $x = eval '"1213" =~ tr/1/1/';
 361 is($x, 2,   'implicit count on constant');
 362 is($@, '',  '   no error');
 363
 364
 365 my @foo = ();
 366 eval '$foo[-1] =~ tr/N/N/';
 367 is( $@, '',         'implicit count outside array bounds, index negative' );
 368 is( scalar @foo, 0, "    doesn't extend the array");
 369
 370 eval '$foo[1] =~ tr/N/N/';
 371 is( $@, '',         'implicit count outside array bounds, index positive' );
 372 is( scalar @foo, 0, "    doesn't extend the array");
 373
 374
 375 my %foo = ();
 376 eval '$foo{bar} =~ tr/N/N/';
 377 is( $@, '',         'implicit count outside hash bounds' );
 378 is( scalar keys %foo, 0,   "    doesn't extend the hash");
 379
 380 $x = \"foo";
 381 is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
 382 is( ref $x, 'SCALAR', "    doesn't stringify its argument" );
 383
 384 # rt.perl.org 36622.  Perl didn't like a y/// at end of file.  No trailing
 385 # newline allowed.
 386 fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '');
 387
 388
 389 { # [perl #38293] chr(65535) should be allowed in regexes
 390 no warnings 'utf8'; # to allow non-characters
 391
 392 $s = "\x{d800}\x{ffff}";
 393 $s =~ tr/\0/A/;
 394 is($s, "\x{d800}\x{ffff}", "do_trans_simple");
 395
 396 $s = "\x{d800}\x{ffff}";
 397 $i = $s =~ tr/\0//;
 398 is($i, 0, "do_trans_count");
 399
 400 $s = "\x{d800}\x{ffff}";
 401 $s =~ tr/\0/A/s;
 402 is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH");
 403
 404 $s = "\x{d800}\x{ffff}";
 405 $s =~ tr/\0/A/c;
 406 is($s, "AA", "do_trans_complex, COMPLEMENT");
 407
 408 $s = "A\x{ffff}B";
 409 $s =~ tr/\x{ffff}/\x{1ffff}/;
 410 is($s, "A\x{1ffff}B", "utf8, SEARCHLIST");
 411
 412 $s = "\x{fffd}\x{fffe}\x{ffff}";
 413 $s =~ tr/\x{fffd}-\x{ffff}/ABC/;
 414 is($s, "ABC", "utf8, SEARCHLIST range");
 415
 416 $s = "ABC";
 417 $s =~ tr/ABC/\x{ffff}/;
 418 is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST");
 419
 420 $s = "ABC";
 421 $s =~ tr/ABC/\x{fffd}-\x{ffff}/;
 422 is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range");
 423
 424 $s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}";
 425 $i = $s =~ tr/\x{ffff}//;
 426 is($i, 2, "utf8, count");
 427
 428 $s = "A\x{ffff}\x{ffff}C";
 429 $s =~ tr/\x{ffff}/\x{100}/s;
 430 is($s, "A\x{100}C", "utf8, SQUASH");
 431
 432 $s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C";
 433 $s =~ tr/\x{fffe}\x{ffff}//s;
 434 is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH");
 435
 436 $s = "xAABBBy";
 437 $s =~ tr/AB/\x{ffff}/s;
 438 is($s, "x\x{ffff}y", "utf8, SQUASH");
 439
 440 $s = "xAABBBy";
 441 $s =~ tr/AB/\x{fffe}\x{ffff}/s;
 442 is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH");
 443
 444 $s = "A\x{ffff}B\x{fffe}C";
 445 $s =~ tr/\x{fffe}\x{ffff}/x/c;
 446 is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT");
 447
 448 $s = "A\x{10000}B\x{2abcd}C";
 449 $s =~ tr/\0-\x{ffff}/x/c;
 450 is($s, "AxBxC", "utf8, COMPLEMENT range");
 451
 452 $s = "A\x{fffe}B\x{ffff}C";
 453 $s =~ tr/\x{fffe}\x{ffff}/x/d;
 454 is($s, "AxBC", "utf8, DELETE");
 455
 456 } # non-characters end
 457
 458 { # related to [perl #27940]
 459     my $c;
 460
 461     ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d;
 462     is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d");
 463
 464     ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d;
 465     is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d");
 466 }
 467