t/op/tr.t

   1 # tr.t
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 print "1..70\n";
   9
  10 $_ = "abcdefghijklmnopqrstuvwxyz";
  11
  12 tr/a-z/A-Z/;
  13
  14 print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  15 print "ok 1\n";
  16
  17 tr/A-Z/a-z/;
  18
  19 print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
  20 print "ok 2\n";
  21
  22 tr/b-y/B-Y/;
  23
  24 print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
  25 print "ok 3\n";
  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     print "not " unless $_ eq "i\xcaj";
  37     print "ok 4\n";
  38 }
  39 #
  40
  41 # make sure that tr cancels IOK and NOK
  42 ($x = 12) =~ tr/1/3/;
  43 (my $y = 12) =~ tr/1/3/;
  44 ($f = 1.5) =~ tr/1/3/;
  45 (my $g = 1.5) =~ tr/1/3/;
  46 print "not " unless $x + $y + $f + $g == 71;
  47 print "ok 5\n";
  48
  49 # make sure tr is harmless if not updating  -  see [ID 20000511.005]
  50 $_ = 'fred';
  51 /([a-z]{2})/;
  52 $1 =~ tr/A-Z//;
  53 s/^(\s*)f/$1F/;
  54 print "not " if $_ ne 'Fred';
  55 print "ok 6\n";
  56
  57 # check tr handles UTF8 correctly
  58 ($x = 256.65.258) =~ tr/a/b/;
  59 print "not " if $x ne 256.65.258 or length $x != 3;
  60 print "ok 7\n";
  61 $x =~ tr/A/B/;
  62 if (ord("\t") == 9) { # ASCII
  63     print "not " if $x ne 256.66.258 or length $x != 3;
  64 }
  65 else {
  66     print "not " if $x ne 256.65.258 or length $x != 3;
  67 }
  68 print "ok 8\n";
  69 # EBCDIC variants of the above tests
  70 ($x = 256.193.258) =~ tr/a/b/;
  71 print "not " if $x ne 256.193.258 or length $x != 3;
  72 print "ok 9\n";
  73 $x =~ tr/A/B/;
  74 if (ord("\t") == 9) { # ASCII
  75     print "not " if $x ne 256.193.258 or length $x != 3;
  76 }
  77 else {
  78     print "not " if $x ne 256.194.258 or length $x != 3;
  79 }
  80 print "ok 10\n";
  81
  82 {
  83 # 11 - changing UTF8 characters in a UTF8 string, same length.
  84 my $l = chr(300); my $r = chr(400);
  85 $x = 200.300.400;
  86 $x =~ tr/\x{12c}/\x{190}/;
  87 printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
  88 print "ok 11\n";
  89
  90 # 12 - changing UTF8 characters in UTF8 string, more bytes.
  91 $x = 200.300.400;
  92 $x =~ tr/\x{12c}/\x{be8}/;
  93 printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
  94 print "ok 12\n";
  95
  96 # 13 - introducing UTF8 characters to non-UTF8 string.
  97 $x = 100.125.60;
  98 $x =~ tr/\x{64}/\x{190}/;
  99 printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
 100 print "ok 13\n";
 101
 102 # 14 - removing UTF8 characters from UTF8 string
 103 $x = 400.125.60;
 104 $x =~ tr/\x{190}/\x{64}/;
 105 printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
 106 print "ok 14\n";
 107
 108 # 15 - counting UTF8 chars in UTF8 string
 109 $x = 400.125.60.400;
 110 $y = $x =~ tr/\x{190}/\x{190}/;
 111 print "not " if $y != 2;
 112 print "ok 15\n";
 113
 114 # 16 - counting non-UTF8 chars in UTF8 string
 115 $x = 60.400.125.60.400;
 116 $y = $x =~ tr/\x{3c}/\x{3c}/;
 117 print "not " if $y != 2;
 118 print "ok 16\n";
 119
 120 # 17 - counting UTF8 chars in non-UTF8 string
 121 $x = 200.125.60;
 122 $y = $x =~ tr/\x{190}/\x{190}/;
 123 print "not " if $y != 0;
 124 print "ok 17\n";
 125 }
 126
 127 # 18: test brokenness with tr/a-z-9//;
 128 $_ = "abcdefghijklmnopqrstuvwxyz";
 129 eval "tr/a-z-9/ /";
 130 print (($@ =~ /^Ambiguous range in transliteration operator/)
 131        ? '' : 'not ', "ok 18\n");
 132
 133 # 19-21: Make sure leading and trailing hyphens still work
 134 $_ = "car-rot9";
 135 tr/-a-m/./;
 136 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
 137
 138 $_ = "car-rot9";
 139 tr/a-m-/./;
 140 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
 141
 142 $_ = "car-rot9";
 143 tr/-a-m-/./;
 144 print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
 145
 146 $_ = "abcdefghijklmnop";
 147 tr/ae-hn/./;
 148 print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
 149
 150 $_ = "abcdefghijklmnop";
 151 tr/a-cf-kn-p/./;
 152 print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
 153
 154 $_ = "abcdefghijklmnop";
 155 tr/a-ceg-ikm-o/./;
 156 print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
 157
 158 # 25: Test reversed range check
 159 # 20000705 MJD
 160 eval "tr/m-d/ /";
 161 print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/)
 162        ? '' : 'not ', "ok 25\n");
 163
 164 # 26: test cannot update if read-only
 165 eval '$1 =~ tr/x/y/';
 166 print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
 167        "ok 26\n");
 168
 169 # 27: test can count read-only
 170 'abcdef' =~ /(bcd)/;
 171 print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
 172
 173 # 28: test lhs OK if not updating
 174 print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
 175
 176 # 29: test lhs bad if updating
 177 eval '"123" =~ tr/1/1/';
 178 print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
 179        ? '' : 'not ', "ok 29\n");
 180
 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/;
 187 print "not " unless $a eq v300.197.172.300.197.172;
 188 print "ok 30\n";
 189
 190 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
 191 print "not " unless $a eq v300.197.172.300.197.172;
 192 print "ok 31\n";
 193
 194 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
 195 print "not " unless $a eq v300.197.172.300.197.172;
 196 print "ok 32\n";
 197
 198 ($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
 199 print "not " unless $a eq v300.197.172.300.197.172;
 200 print "ok 33\n";
 201
 202 # Transliterate a byte to a wide character.
 203
 204 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
 205 print "not " unless $a eq v300.301.172.300.301.172;
 206 print "ok 34\n";
 207
 208 # Transliterate a wide character to a byte.
 209
 210 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
 211 print "not " unless $a eq v195.196.172.195.196.172;
 212 print "ok 35\n";
 213
 214 # Transliterate a wide character to a wide character.
 215
 216 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
 217 print "not " unless $a eq v301.196.172.301.196.172;
 218 print "ok 36\n";
 219
 220 # Transliterate both ways.
 221
 222 ($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
 223 print "not " unless $a eq v195.301.172.195.301.172;
 224 print "ok 37\n";
 225
 226 # Transliterate all (four) ways.
 227
 228 ($a = v300.196.172.300.196.172.400.198.144) =~
 229         tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
 230 print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
 231 print "ok 38\n";
 232
 233 # Transliterate and count.
 234
 235 print "not "
 236     unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/)       == 2;
 237 print "ok 39\n";
 238
 239 print "not "
 240     unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
 241 print "ok 40\n";
 242
 243 # Transliterate with complement.
 244
 245 ($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
 246 print "not " unless $a eq v301.196.301.301.196.301;
 247 print "ok 41\n";
 248
 249 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
 250 print "not " unless $a eq v300.197.197.300.197.197;
 251 print "ok 42\n";
 252
 253 # Transliterate with deletion.
 254
 255 ($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
 256 print "not " unless $a eq v300.172.300.172;
 257 print "ok 43\n";
 258
 259 ($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
 260 print "not " unless $a eq v196.172.196.172;
 261 print "ok 44\n";
 262
 263 # Transliterate with squeeze.
 264
 265 ($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
 266 print "not " unless $a eq v197.172.300.300.197.172;
 267 print "ok 45\n";
 268
 269 ($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
 270 print "not " unless $a eq v196.172.301.196.172.172;
 271 print "ok 46\n";
 272
 273 # Tricky cases by Simon Cozens.
 274
 275 ($a = v196.172.200) =~ tr/\x{12c}/a/;
 276 print "not " unless sprintf("%vd", $a) eq '196.172.200';
 277 print "ok 47\n";
 278
 279 ($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
 280 print "not " unless sprintf("%vd", $a) eq '196.172.200';
 281 print "ok 48\n";
 282
 283 ($a = v196.172.200) =~ tr/\x{12c}//d;
 284 print "not " unless sprintf("%vd", $a) eq '196.172.200';
 285 print "ok 49\n";
 286
 287 # UTF8 range tests from Inaba Hiroto
 288
 289 # Not working in EBCDIC as of 12674.
 290 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
 291 print "not " unless $a eq v192.196.172.194.197.172;
 292 print "ok 50\n";
 293
 294 ($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
 295 print "not " unless $a eq v300.300.172.302.301.172;
 296 print "ok 51\n";
 297
 298 # UTF8 range tests from Karsten Sperling (patch #9008 required)
 299
 300 ($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
 301 print "not " unless $a eq "X";
 302 print "ok 52\n";
 303
 304 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
 305 print "not " unless $a eq "X";
 306 print "ok 53\n";
 307
 308 ($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
 309 print "not " unless $a eq "X";
 310 print "ok 54\n";
 311
 312 ($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
 313 print "not " unless $a eq "X";
 314 print "ok 55\n";
 315
 316 # UTF8 range tests from Inaba Hiroto
 317
 318 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
 319 print "not " unless $a eq "X";
 320 print "ok 56\n";
 321
 322 ($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
 323 print "not " unless $a eq "X";
 324 print "ok 57\n";
 325
 326 # Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
 327 # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
 328 # from Karsten Sperling.
 329
 330 # Not working in EBCDIC as of 12674.
 331 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
 332 print "not " unless $c == 8 and $a eq "XXXXXXXX";
 333 print "ok 58\n";
 334
 335 # Not working in EBCDIC as of 12674.
 336 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
 337 print "not " unless $c == 8 and $a eq "XXXXXXXX";
 338 print "ok 59\n";
 339
 340 if (ord('i') == 0x89 & ord('J') == 0xd1) {
 341
 342 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
 343 print "not " unless $c == 2 and $a eq "X\x8a\x8b\x8c\x8d\x8f\x90X";
 344 print "ok 60\n";
 345
 346 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
 347 print "not " unless $c == 2 and $a eq "X\xca\xcb\xcc\xcd\xcf\xd0X";
 348 print "ok 61\n";
 349
 350 } else {
 351   for (60..61) { print "ok $_ # Skip: not EBCDIC\n" }
 352 }
 353
 354 ($a = "\x{100}") =~ tr/\x00-\xff/X/c;
 355 print "not " unless ord($a) == ord("X");
 356 print "ok 62\n";
 357
 358 ($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
 359 print "not " unless ord($a) == ord("X");
 360 print "ok 63\n";
 361
 362 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
 363 print "not " unless $a eq "\x{100}\x{100}";
 364 print "ok 64\n";
 365
 366 ($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
 367 print "not " unless $a eq "\x{100}";
 368 print "ok 65\n";
 369
 370 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
 371 print "not " unless $a eq "\x{1ff}\x{1fe}";
 372 print "ok 66\n";
 373
 374 # From David Dyck
 375 ($a = "R0_001") =~ tr/R_//d;
 376 print "not " if hex($a) != 1;
 377 print "ok 67\n";
 378
 379 # From Inaba Hiroto
 380 @a = (1,2); map { y/1/./ for $_ } @a;
 381 print "not " if "@a" ne ". 2";
 382 print "ok 68\n";
 383
 384 @a = (1,2); map { y/1/./ for $_.'' } @a;
 385 print "not " if "@a" ne "1 2";
 386 print "ok 69\n";
 387
 388 # Additional test for Inaba Hiroto patch (robin@kitsite.com)
 389 ($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
 390 print "not " unless $a eq "XZY";
 391 print "ok 70\n";
 392
 393