1N/A# tr.t
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A require './test.pl';
1N/A}
1N/A
1N/Aplan tests => 99;
1N/A
1N/Amy $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
1N/A
1N/A$_ = "abcdefghijklmnopqrstuvwxyz";
1N/A
1N/Atr/a-z/A-Z/;
1N/A
1N/Ais($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc');
1N/A
1N/Atr/A-Z/a-z/;
1N/A
1N/Ais($_, "abcdefghijklmnopqrstuvwxyz", 'lc');
1N/A
1N/Atr/b-y/B-Y/;
1N/Ais($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc');
1N/A
1N/A
1N/A# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
1N/A# Yes, discontinuities. Regardless, the \xca in the below should stay
1N/A# untouched (and not became \x8a).
1N/A{
1N/A no utf8;
1N/A $_ = "I\xcaJ";
1N/A
1N/A tr/I-J/i-j/;
1N/A
1N/A is($_, "i\xcaj", 'EBCDIC discontinuity');
1N/A}
1N/A#
1N/A
1N/A
1N/A($x = 12) =~ tr/1/3/;
1N/A(my $y = 12) =~ tr/1/3/;
1N/A($f = 1.5) =~ tr/1/3/;
1N/A(my $g = 1.5) =~ tr/1/3/;
1N/Ais($x + $y + $f + $g, 71, 'tr cancels IOK and NOK');
1N/A
1N/A
1N/A# perlbug [ID 20000511.005]
1N/A$_ = 'fred';
1N/A/([a-z]{2})/;
1N/A$1 =~ tr/A-Z//;
1N/As/^(\s*)f/$1F/;
1N/Ais($_, 'Fred', 'harmless if explicitly not updating');
1N/A
1N/A
1N/A# A variant of the above, added in 5.7.2
1N/A$_ = 'fred';
1N/A/([a-z]{2})/;
1N/Aeval '$1 =~ tr/A-Z/A-Z/;';
1N/As/^(\s*)f/$1F/;
1N/Ais($_, 'Fred', 'harmless if implicitly not updating');
1N/Ais($@, '', ' no error');
1N/A
1N/A
1N/A# check tr handles UTF8 correctly
1N/A($x = 256.65.258) =~ tr/a/b/;
1N/Ais($x, 256.65.258, 'handles UTF8');
1N/Ais(length $x, 3);
1N/A
1N/A$x =~ tr/A/B/;
1N/Ais(length $x, 3);
1N/Aif (ord("\t") == 9) { # ASCII
1N/A is($x, 256.66.258);
1N/A}
1N/Aelse {
1N/A is($x, 256.65.258);
1N/A}
1N/A
1N/A# EBCDIC variants of the above tests
1N/A($x = 256.193.258) =~ tr/a/b/;
1N/Ais(length $x, 3);
1N/Ais($x, 256.193.258);
1N/A
1N/A$x =~ tr/A/B/;
1N/Ais(length $x, 3);
1N/Aif (ord("\t") == 9) { # ASCII
1N/A is($x, 256.193.258);
1N/A}
1N/Aelse {
1N/A is($x, 256.194.258);
1N/A}
1N/A
1N/A
1N/A{
1N/A my $l = chr(300); my $r = chr(400);
1N/A $x = 200.300.400;
1N/A $x =~ tr/\x{12c}/\x{190}/;
1N/A is($x, 200.400.400,
1N/A 'changing UTF8 chars in a UTF8 string, same length');
1N/A is(length $x, 3);
1N/A
1N/A $x = 200.300.400;
1N/A $x =~ tr/\x{12c}/\x{be8}/;
1N/A is($x, 200.3048.400, ' more bytes');
1N/A is(length $x, 3);
1N/A
1N/A $x = 100.125.60;
1N/A $x =~ tr/\x{64}/\x{190}/;
1N/A is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string');
1N/A is(length $x, 3);
1N/A
1N/A $x = 400.125.60;
1N/A $x =~ tr/\x{190}/\x{64}/;
1N/A is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string');
1N/A is(length $x, 3);
1N/A
1N/A $x = 400.125.60.400;
1N/A $y = $x =~ tr/\x{190}/\x{190}/;
1N/A is($y, 2, 'Counting UTF8 chars in UTF8 string');
1N/A
1N/A $x = 60.400.125.60.400;
1N/A $y = $x =~ tr/\x{3c}/\x{3c}/;
1N/A is($y, 2, ' non-UTF8 chars in UTF8 string');
1N/A
1N/A # 17 - counting UTF8 chars in non-UTF8 string
1N/A $x = 200.125.60;
1N/A $y = $x =~ tr/\x{190}/\x{190}/;
1N/A is($y, 0, ' UTF8 chars in non-UTFs string');
1N/A}
1N/A
1N/A$_ = "abcdefghijklmnopqrstuvwxyz";
1N/Aeval 'tr/a-z-9/ /';
1N/Alike($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//');
1N/A
1N/A# 19-21: Make sure leading and trailing hyphens still work
1N/A$_ = "car-rot9";
1N/Atr/-a-m/./;
1N/Ais($_, '..r.rot9', 'hyphens, leading');
1N/A
1N/A$_ = "car-rot9";
1N/Atr/a-m-/./;
1N/Ais($_, '..r.rot9', ' trailing');
1N/A
1N/A$_ = "car-rot9";
1N/Atr/-a-m-/./;
1N/Ais($_, '..r.rot9', ' both');
1N/A
1N/A$_ = "abcdefghijklmnop";
1N/Atr/ae-hn/./;
1N/Ais($_, '.bcd....ijklm.op');
1N/A
1N/A$_ = "abcdefghijklmnop";
1N/Atr/a-cf-kn-p/./;
1N/Ais($_, '...de......lm...');
1N/A
1N/A$_ = "abcdefghijklmnop";
1N/Atr/a-ceg-ikm-o/./;
1N/Ais($_, '...d.f...j.l...p');
1N/A
1N/A
1N/A# 20000705 MJD
1N/Aeval "tr/m-d/ /";
1N/Alike($@, qr/^Invalid range "m-d" in transliteration operator/,
1N/A 'reversed range check');
1N/A
1N/Aeval '$1 =~ tr/x/y/';
1N/Alike($@, qr/^Modification of a read-only value attempted/,
1N/A 'cannot update read-only var');
1N/A
1N/A'abcdef' =~ /(bcd)/;
1N/Ais(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count');
1N/Ais($@, '', ' no error');
1N/A
1N/A'abcdef' =~ /(bcd)/;
1N/Ais(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count');
1N/Ais($@, '', ' no error');
1N/A
1N/Ais(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr');
1N/A
1N/Aeval '"123" =~ tr/1/2/';
1N/Alike($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
1N/A 'LHS bad on updating tr');
1N/A
1N/A
1N/A# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
1N/A# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
1N/A
1N/A# Transliterate a byte to a byte, all four ways.
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
1N/Ais($a, v300.197.172.300.197.172, 'byte2byte transliteration');
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
1N/Ais($a, v300.197.172.300.197.172);
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
1N/Ais($a, v300.197.172.300.197.172);
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
1N/Ais($a, v300.197.172.300.197.172);
1N/A
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
1N/Ais($a, v300.301.172.300.301.172, 'byte2wide transliteration');
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
1N/Ais($a, v195.196.172.195.196.172, ' wide2byte');
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
1N/Ais($a, v301.196.172.301.196.172, ' wide2wide');
1N/A
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
1N/Ais($a, v195.301.172.195.301.172, 'byte2wide & wide2byte');
1N/A
1N/A
1N/A($a = v300.196.172.300.196.172.400.198.144) =~
1N/A tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
1N/Ais($a, v197.301.173.197.301.173.401.198.144, 'all together now!');
1N/A
1N/A
1N/Ais((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
1N/A 'transliterate and count');
1N/A
1N/Ais((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
1N/A
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
1N/Ais($a, v301.196.301.301.196.301, 'translit w/complement');
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
1N/Ais($a, v300.197.197.300.197.197);
1N/A
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
1N/Ais($a, v300.172.300.172, 'translit w/deletion');
1N/A
1N/A($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
1N/Ais($a, v196.172.196.172);
1N/A
1N/A
1N/A($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
1N/Ais($a, v197.172.300.300.197.172, 'translit w/squeeze');
1N/A
1N/A($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
1N/Ais($a, v196.172.301.196.172.172);
1N/A
1N/A
1N/A# Tricky cases (When Simon Cozens Attacks)
1N/A($a = v196.172.200) =~ tr/\x{12c}/a/;
1N/Ais(sprintf("%vd", $a), '196.172.200');
1N/A
1N/A($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
1N/Ais(sprintf("%vd", $a), '196.172.200');
1N/A
1N/A($a = v196.172.200) =~ tr/\x{12c}//d;
1N/Ais(sprintf("%vd", $a), '196.172.200');
1N/A
1N/A
1N/A# UTF8 range tests from Inaba Hiroto
1N/A
1N/A# Not working in EBCDIC as of 12674.
1N/A($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
1N/Ais($a, v192.196.172.194.197.172, 'UTF range');
1N/A
1N/A($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
1N/Ais($a, v300.300.172.302.301.172);
1N/A
1N/A
1N/A# UTF8 range tests from Karsten Sperling (patch #9008 required)
1N/A
1N/A($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
1N/Ais($a, "X");
1N/A
1N/A($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
1N/Ais($a, "X");
1N/A
1N/A($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
1N/Ais($a, "X");
1N/A
1N/A($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
1N/Ais($a, "X");
1N/A
1N/A
1N/A# UTF8 range tests from Inaba Hiroto
1N/A
1N/A($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
1N/Ais($a, "X");
1N/A
1N/A($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
1N/Ais($a, "X");
1N/A
1N/A
1N/A# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
1N/A# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
1N/A# from Karsten Sperling.
1N/A
1N/A# Not working in EBCDIC as of 12674.
1N/A$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
1N/Ais($c, 8);
1N/Ais($a, "XXXXXXXX");
1N/A
1N/A# Not working in EBCDIC as of 12674.
1N/A$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
1N/Ais($c, 8);
1N/Ais($a, "XXXXXXXX");
1N/A
1N/A
1N/ASKIP: {
1N/A skip "not EBCDIC", 4 unless $Is_EBCDIC;
1N/A
1N/A $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
1N/A is($c, 2);
1N/A is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
1N/A
1N/A $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
1N/A is($c, 2);
1N/A is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
1N/A}
1N/A
1N/A($a = "\x{100}") =~ tr/\x00-\xff/X/c;
1N/Ais(ord($a), ord("X"));
1N/A
1N/A($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
1N/Ais(ord($a), ord("X"));
1N/A
1N/A($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
1N/Ais($a, "\x{100}\x{100}");
1N/A
1N/A($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
1N/Ais($a, "\x{100}");
1N/A
1N/A$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
1N/Ais($a, "\x{1ff}\x{1fe}");
1N/A
1N/A
1N/A# From David Dyck
1N/A($a = "R0_001") =~ tr/R_//d;
1N/Ais(hex($a), 1);
1N/A
1N/A# From Inaba Hiroto
1N/A@a = (1,2); map { y/1/./ for $_ } @a;
1N/Ais("@a", ". 2");
1N/A
1N/A@a = (1,2); map { y/1/./ for $_.'' } @a;
1N/Ais("@a", "1 2");
1N/A
1N/A
1N/A# Additional test for Inaba Hiroto patch (robin@kitsite.com)
1N/A($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
1N/Ais($a, "XZY");
1N/A
1N/A
1N/A# Used to fail with "Modification of a read-only value attempted"
1N/A%a = (N=>1);
1N/Aforeach (keys %a) {
1N/A eval 'tr/N/n/';
1N/A is($_, 'n', 'pp_trans needs to unshare shared hash keys');
1N/A is($@, '', ' no error');
1N/A}
1N/A
1N/A
1N/A$x = eval '"1213" =~ tr/1/1/';
1N/Ais($x, 2, 'implicit count on constant');
1N/Ais($@, '', ' no error');
1N/A
1N/A
1N/Amy @foo = ();
1N/Aeval '$foo[-1] =~ tr/N/N/';
1N/Ais( $@, '', 'implicit count outside array bounds, index negative' );
1N/Ais( scalar @foo, 0, " doesn't extend the array");
1N/A
1N/Aeval '$foo[1] =~ tr/N/N/';
1N/Ais( $@, '', 'implicit count outside array bounds, index positive' );
1N/Ais( scalar @foo, 0, " doesn't extend the array");
1N/A
1N/A
1N/Amy %foo = ();
1N/Aeval '$foo{bar} =~ tr/N/N/';
1N/Ais( $@, '', 'implicit count outside hash bounds' );
1N/Ais( scalar keys %foo, 0, " doesn't extend the hash");
1N/A
1N/A$x = \"foo";
1N/Ais( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
1N/Ais( ref $x, 'SCALAR', " doesn't stringify its argument" );