# tr.t
+$|=1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
+ if (is_miniperl()) {
+ eval 'require utf8';
+ if ($@) { skip_all("miniperl, no 'utf8'") }
+ }
}
-print "1..70\n";
+use utf8;
+
+plan tests => 215;
+
+# Test this first before we extend the stack with other operations.
+# This caused an asan failure due to a bad write past the end of the stack.
+eval { my $x; die 1..127, $x =~ y/// };
$_ = "abcdefghijklmnopqrstuvwxyz";
tr/a-z/A-Z/;
-print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-print "ok 1\n";
+is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc');
tr/A-Z/a-z/;
-print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
-print "ok 2\n";
+is($_, "abcdefghijklmnopqrstuvwxyz", 'lc');
tr/b-y/B-Y/;
+is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc');
+
+tr/a-a/AB/;
+is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYz", 'single char range a-a');
+
+eval 'tr/a/\N{KATAKANA LETTER AINU P}/;';
+like $@,
+ qr/\\N\{KATAKANA LETTER AINU P\} must not be a named sequence in transliteration operator/,
+ "Illegal to tr/// named sequence";
+
+eval 'tr/\x{101}-\x{100}//;';
+like $@,
+ qr/Invalid range "\\x\{0101\}-\\x\{0100\}" in transliteration operator/,
+ "UTF-8 range with min > max";
+
+SKIP: { # Test literal range end point special handling
+ unless ($::IS_EBCDIC) {
+ skip "Valid only for EBCDIC", 24;
+ }
+
+ $_ = "\x89"; # is 'i'
+ tr/i-j//d;
+ is($_, "", '"\x89" should match [i-j]');
+ $_ = "\x8A";
+ tr/i-j//d;
+ is($_, "\x8A", '"\x8A" shouldnt match [i-j]');
+ $_ = "\x90";
+ tr/i-j//d;
+ is($_, "\x90", '"\x90" shouldnt match [i-j]');
+ $_ = "\x91"; # is 'j'
+ tr/i-j//d;
+ is($_, "", '"\x91" should match [i-j]');
+
+ $_ = "\x89";
+ tr/i-\N{LATIN SMALL LETTER J}//d;
+ is($_, "", '"\x89" should match [i-\N{LATIN SMALL LETTER J}]');
+ $_ = "\x8A";
+ tr/i-\N{LATIN SMALL LETTER J}//d;
+ is($_, "\x8A", '"\x8A" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
+ $_ = "\x90";
+ tr/i-\N{LATIN SMALL LETTER J}//d;
+ is($_, "\x90", '"\x90" shouldnt match [i-\N{LATIN SMALL LETTER J}]');
+ $_ = "\x91";
+ tr/i-\N{LATIN SMALL LETTER J}//d;
+ is($_, "", '"\x91" should match [i-\N{LATIN SMALL LETTER J}]');
+
+ $_ = "\x89";
+ tr/i-\N{U+6A}//d;
+ is($_, "", '"\x89" should match [i-\N{U+6A}]');
+ $_ = "\x8A";
+ tr/i-\N{U+6A}//d;
+ is($_, "\x8A", '"\x8A" shouldnt match [i-\N{U+6A}]');
+ $_ = "\x90";
+ tr/i-\N{U+6A}//d;
+ is($_, "\x90", '"\x90" shouldnt match [i-\N{U+6A}]');
+ $_ = "\x91";
+ tr/i-\N{U+6A}//d;
+ is($_, "", '"\x91" should match [i-\N{U+6A}]');
+
+ $_ = "\x89";
+ tr/\N{U+69}-\N{U+6A}//d;
+ is($_, "", '"\x89" should match [\N{U+69}-\N{U+6A}]');
+ $_ = "\x8A";
+ tr/\N{U+69}-\N{U+6A}//d;
+ is($_, "\x8A", '"\x8A" shouldnt match [\N{U+69}-\N{U+6A}]');
+ $_ = "\x90";
+ tr/\N{U+69}-\N{U+6A}//d;
+ is($_, "\x90", '"\x90" shouldnt match [\N{U+69}-\N{U+6A}]');
+ $_ = "\x91";
+ tr/\N{U+69}-\N{U+6A}//d;
+ is($_, "", '"\x91" should match [\N{U+69}-\N{U+6A}]');
+
+ $_ = "\x89";
+ tr/i-\x{91}//d;
+ is($_, "", '"\x89" should match [i-\x{91}]');
+ $_ = "\x8A";
+ tr/i-\x{91}//d;
+ is($_, "", '"\x8A" should match [i-\x{91}]');
+ $_ = "\x90";
+ tr/i-\x{91}//d;
+ is($_, "", '"\x90" should match [i-\x{91}]');
+ $_ = "\x91";
+ tr/i-\x{91}//d;
+ is($_, "", '"\x91" should match [i-\x{91}]');
+
+ # Need to use eval, because tries to compile on ASCII platforms even
+ # though the tests are skipped, and fails because 0x89-j is an illegal
+ # range there.
+ $_ = "\x89";
+ eval 'tr/\x{89}-j//d';
+ is($_, "", '"\x89" should match [\x{89}-j]');
+ $_ = "\x8A";
+ eval 'tr/\x{89}-j//d';
+ is($_, "", '"\x8A" should match [\x{89}-j]');
+ $_ = "\x90";
+ eval 'tr/\x{89}-j//d';
+ is($_, "", '"\x90" should match [\x{89}-j]');
+ $_ = "\x91";
+ eval 'tr/\x{89}-j//d';
+ is($_, "", '"\x91" should match [\x{89}-j]');
+}
-print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
-print "ok 3\n";
# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
# Yes, discontinuities. Regardless, the \xca in the below should stay
# untouched (and not became \x8a).
{
- no utf8;
$_ = "I\xcaJ";
tr/I-J/i-j/;
- print "not " unless $_ eq "i\xcaj";
- print "ok 4\n";
+ is($_, "i\xcaj", 'EBCDIC discontinuity');
}
#
-# make sure that tr cancels IOK and NOK
($x = 12) =~ tr/1/3/;
(my $y = 12) =~ tr/1/3/;
($f = 1.5) =~ tr/1/3/;
(my $g = 1.5) =~ tr/1/3/;
-print "not " unless $x + $y + $f + $g > 70.9;
-print "ok 5\n";
+is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK');
+
+# /r
+$_ = 'adam';
+is y/dam/ve/rd, 'eve', '/r';
+is $_, 'adam', '/r leaves param alone';
+$g = 'ruby';
+is $g =~ y/bury/repl/r, 'perl', '/r with explicit param';
+is $g, 'ruby', '/r leaves explicit param alone';
+is "aaa" =~ y\a\b\r, 'bbb', '/r with constant param';
+ok !eval '$_ !~ y///r', "!~ y///r is forbidden";
+like $@, qr\^Using !~ with tr///r doesn't make sense\,
+ "!~ y///r error message";
+{
+ my $w;
+ my $wc;
+ local $SIG{__WARN__} = sub { $w = shift; ++$wc };
+ local $^W = 1;
+ eval 'y///r; 1';
+ like $w, qr '^Useless use of non-destructive transliteration \(tr///r\)',
+ '/r warns in void context';
+ is $wc, 1, '/r warns just once';
+}
-# make sure tr is harmless if not updating - see [ID 20000511.005]
+# perlbug [ID 20000511.005 (#3237)]
$_ = 'fred';
/([a-z]{2})/;
$1 =~ tr/A-Z//;
s/^(\s*)f/$1F/;
-print "not " if $_ ne 'Fred';
-print "ok 6\n";
+is($_, 'Fred', 'harmless if explicitly not updating');
+
+
+# A variant of the above, added in 5.7.2
+$_ = 'fred';
+/([a-z]{2})/;
+eval '$1 =~ tr/A-Z/A-Z/;';
+s/^(\s*)f/$1F/;
+is($_, 'Fred', 'harmless if implicitly not updating');
+is($@, '', ' no error');
+
# check tr handles UTF8 correctly
($x = 256.65.258) =~ tr/a/b/;
-print "not " if $x ne 256.65.258 or length $x != 3;
-print "ok 7\n";
+is($x, 256.65.258, 'handles UTF8');
+is(length $x, 3);
+
$x =~ tr/A/B/;
-if (ord("\t") == 9) { # ASCII
- print "not " if $x ne 256.66.258 or length $x != 3;
+is(length $x, 3);
+if ($::IS_ASCII) { # ASCII
+ is($x, 256.66.258);
}
else {
- print "not " if $x ne 256.65.258 or length $x != 3;
+ is($x, 256.65.258);
}
-print "ok 8\n";
+
# EBCDIC variants of the above tests
($x = 256.193.258) =~ tr/a/b/;
-print "not " if $x ne 256.193.258 or length $x != 3;
-print "ok 9\n";
+is(length $x, 3);
+is($x, 256.193.258);
+
$x =~ tr/A/B/;
-if (ord("\t") == 9) { # ASCII
- print "not " if $x ne 256.193.258 or length $x != 3;
+is(length $x, 3);
+if ($::IS_ASCII) { # ASCII
+ is($x, 256.193.258);
}
else {
- print "not " if $x ne 256.194.258 or length $x != 3;
+ is($x, 256.194.258);
}
-print "ok 10\n";
+
{
-if (ord("\t") == 9) { # ASCII
- use utf8;
-}
-# 11 - changing UTF8 characters in a UTF8 string, same length.
-my $l = chr(300); my $r = chr(400);
-$x = 200.300.400;
-$x =~ tr/\x{12c}/\x{190}/;
-printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
-print "ok 11\n";
-
-# 12 - changing UTF8 characters in UTF8 string, more bytes.
-$x = 200.300.400;
-$x =~ tr/\x{12c}/\x{be8}/;
-printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
-print "ok 12\n";
-
-# 13 - introducing UTF8 characters to non-UTF8 string.
-$x = 100.125.60;
-$x =~ tr/\x{64}/\x{190}/;
-printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
-print "ok 13\n";
-
-# 14 - removing UTF8 characters from UTF8 string
-$x = 400.125.60;
-$x =~ tr/\x{190}/\x{64}/;
-printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
-print "ok 14\n";
-
-# 15 - counting UTF8 chars in UTF8 string
-$x = 400.125.60.400;
-$y = $x =~ tr/\x{190}/\x{190}/;
-print "not " if $y != 2;
-print "ok 15\n";
-
-# 16 - counting non-UTF8 chars in UTF8 string
-$x = 60.400.125.60.400;
-$y = $x =~ tr/\x{3c}/\x{3c}/;
-print "not " if $y != 2;
-print "ok 16\n";
-
-# 17 - counting UTF8 chars in non-UTF8 string
-$x = 200.125.60;
-$y = $x =~ tr/\x{190}/\x{190}/;
-print "not " if $y != 0;
-print "ok 17\n";
+ my $l = chr(300); my $r = chr(400);
+ $x = 200.300.400;
+ $x =~ tr/\x{12c}/\x{190}/;
+ is($x, 200.400.400,
+ 'changing UTF8 chars in a UTF8 string, same length');
+ is(length $x, 3);
+
+ $x = 200.300.400;
+ $x =~ tr/\x{12c}/\x{be8}/;
+ is($x, 200.3048.400, ' more bytes');
+ is(length $x, 3);
+
+ $x = 100.125.60;
+ $x =~ tr/\x{64}/\x{190}/;
+ is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string');
+ is(length $x, 3);
+
+ $x = 400.125.60;
+ $x =~ tr/\x{190}/\x{64}/;
+ is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string');
+ is(length $x, 3);
+
+ $x = 400.125.60.400;
+ $y = $x =~ tr/\x{190}/\x{190}/;
+ is($y, 2, 'Counting UTF8 chars in UTF8 string');
+
+ $x = 60.400.125.60.400;
+ $y = $x =~ tr/\x{3c}/\x{3c}/;
+ is($y, 2, ' non-UTF8 chars in UTF8 string');
+
+ # 17 - counting UTF8 chars in non-UTF8 string
+ $x = 200.125.60;
+ $y = $x =~ tr/\x{190}/\x{190}/;
+ is($y, 0, ' UTF8 chars in non-UTFs string');
}
-# 18: test brokenness with tr/a-z-9//;
$_ = "abcdefghijklmnopqrstuvwxyz";
-eval "tr/a-z-9/ /";
-print (($@ =~ /^Ambiguous range in transliteration operator/)
- ? '' : 'not ', "ok 18\n");
+eval 'tr/a-z-9/ /';
+like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//');
# 19-21: Make sure leading and trailing hyphens still work
$_ = "car-rot9";
tr/-a-m/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
+is($_, '..r.rot9', 'hyphens, leading');
$_ = "car-rot9";
tr/a-m-/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n");
+is($_, '..r.rot9', ' trailing');
$_ = "car-rot9";
tr/-a-m-/./;
-print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n");
+is($_, '..r.rot9', ' both');
$_ = "abcdefghijklmnop";
tr/ae-hn/./;
-print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n");
+is($_, '.bcd....ijklm.op');
$_ = "abcdefghijklmnop";
tr/a-cf-kn-p/./;
-print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n");
+is($_, '...de......lm...');
$_ = "abcdefghijklmnop";
tr/a-ceg-ikm-o/./;
-print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n");
+is($_, '...d.f...j.l...p');
+
-# 25: Test reversed range check
# 20000705 MJD
eval "tr/m-d/ /";
-print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/)
- ? '' : 'not ', "ok 25\n");
+like($@, qr/^Invalid range "m-d" in transliteration operator/,
+ 'reversed range check');
-# 26: test cannot update if read-only
-eval '$1 =~ tr/x/y/';
-print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
- "ok 26\n");
+'abcdef' =~ /(bcd)/;
+is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count');
+is($@, '', ' no error');
-# 27: test can count read-only
'abcdef' =~ /(bcd)/;
-print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n");
+is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count');
+is($@, '', ' no error');
-# 28: test lhs OK if not updating
-print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n");
+is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr');
+
+eval '"123" =~ tr/1/2/';
+like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
+ 'LHS bad on updating tr');
-# 29: test lhs bad if updating
-eval '"123" =~ tr/1/1/';
-print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
- ? '' : 'not ', "ok 29\n");
# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
# Transliterate a byte to a byte, all four ways.
($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 30\n";
+is($a, v300.197.172.300.197.172, 'byte2byte transliteration');
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 31\n";
+is($a, v300.197.172.300.197.172);
($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 32\n";
+is($a, v300.197.172.300.197.172);
($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
-print "not " unless $a eq v300.197.172.300.197.172;
-print "ok 33\n";
+is($a, v300.197.172.300.197.172);
-# Transliterate a byte to a wide character.
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
-print "not " unless $a eq v300.301.172.300.301.172;
-print "ok 34\n";
-
-# Transliterate a wide character to a byte.
+is($a, v300.301.172.300.301.172, 'byte2wide transliteration');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
-print "not " unless $a eq v195.196.172.195.196.172;
-print "ok 35\n";
-
-# Transliterate a wide character to a wide character.
+is($a, v195.196.172.195.196.172, ' wide2byte');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
-print "not " unless $a eq v301.196.172.301.196.172;
-print "ok 36\n";
+is($a, v301.196.172.301.196.172, ' wide2wide');
-# Transliterate both ways.
($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
-print "not " unless $a eq v195.301.172.195.301.172;
-print "ok 37\n";
+is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte');
-# Transliterate all (four) ways.
($a = v300.196.172.300.196.172.400.198.144) =~
tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
-print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
-print "ok 38\n";
+is($a, v197.301.173.197.301.173.401.198.144, 'all together now!');
-# Transliterate and count.
-print "not "
- unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2;
-print "ok 39\n";
+is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
+ 'transliterate and count');
-print "not "
- unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
-print "ok 40\n";
+is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
-# Transliterate with complement.
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
-print "not " unless $a eq v301.196.301.301.196.301;
-print "ok 41\n";
+is($a, v301.196.301.301.196.301, 'translit w/complement');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
-print "not " unless $a eq v300.197.197.300.197.197;
-print "ok 42\n";
+is($a, v300.197.197.300.197.197);
-# Transliterate with deletion.
($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
-print "not " unless $a eq v300.172.300.172;
-print "ok 43\n";
+is($a, v300.172.300.172, 'translit w/deletion');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
-print "not " unless $a eq v196.172.196.172;
-print "ok 44\n";
+is($a, v196.172.196.172);
-# Transliterate with squeeze.
($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
-print "not " unless $a eq v197.172.300.300.197.172;
-print "ok 45\n";
+is($a, v197.172.300.300.197.172, 'translit w/squeeze');
($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
-print "not " unless $a eq v196.172.301.196.172.172;
-print "ok 46\n";
+is($a, v196.172.301.196.172.172);
-# Tricky cases by Simon Cozens.
+# Tricky cases (When Simon Cozens Attacks)
($a = v196.172.200) =~ tr/\x{12c}/a/;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 47\n";
+is(sprintf("%vd", $a), '196.172.200');
($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 48\n";
+is(sprintf("%vd", $a), '196.172.200');
($a = v196.172.200) =~ tr/\x{12c}//d;
-print "not " unless sprintf("%vd", $a) eq '196.172.200';
-print "ok 49\n";
+is(sprintf("%vd", $a), '196.172.200');
+
# UTF8 range tests from Inaba Hiroto
($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
-print "not " unless $a eq v192.196.172.194.197.172;
-print "ok 50\n";
+is($a, v192.196.172.194.197.172, 'UTF range');
($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
-print "not " unless $a eq v300.300.172.302.301.172;
-print "ok 51\n";
+is($a, v300.300.172.302.301.172);
+
# UTF8 range tests from Karsten Sperling (patch #9008 required)
($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
-print "not " unless $a eq "X";
-print "ok 52\n";
+is($a, "X");
($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
-print "not " unless $a eq "X";
-print "ok 53\n";
+is($a, "X");
($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
-print "not " unless $a eq "X";
-print "ok 54\n";
+is($a, "X");
($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
-print "not " unless $a eq "X";
-print "ok 55\n";
+is($a, "X");
+
# UTF8 range tests from Inaba Hiroto
($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
-print "not " unless $a eq "X";
-print "ok 56\n";
+is($a, "X");
($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
-print "not " unless $a eq "X";
-print "ok 57\n";
+is($a, "X");
-# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
-# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
+# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters (as
+# well as i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
# from Karsten Sperling.
$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
-print "not " unless $c == 8 and $a eq "XXXXXXXX";
-print "ok 58\n";
-
+is($c, 8);
+is($a, "XXXXXXXX");
+
$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
-print "not " unless $c == 8 and $a eq "XXXXXXXX";
-print "ok 59\n";
-
-if (ord('i') == 0x89 & ord('J') == 0xd1) {
+is($c, 8);
+is($a, "XXXXXXXX");
-$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
-print "not " unless $c == 2 and $a eq "X\x8a\x8b\x8c\x8d\x8f\x90X";
-print "ok 60\n";
-
-$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
-print "not " unless $c == 2 and $a eq "X\xca\xcb\xcc\xcd\xcf\xd0X";
-print "ok 61\n";
+SKIP: {
+ skip "EBCDIC-centric tests", 4 unless $::IS_EBCDIC;
-} else {
- for (60..61) { print "ok $_ # Skip: not EBCDIC\n" }
+ $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
+ is($c, 2);
+ is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
+
+ $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
+ is($c, 2);
+ is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
}
($a = "\x{100}") =~ tr/\x00-\xff/X/c;
-print "not " unless ord($a) == ord("X");
-print "ok 62\n";
+is(ord($a), ord("X"));
($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
-print "not " unless ord($a) == ord("X");
-print "ok 63\n";
+is(ord($a), ord("X"));
($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
-print "not " unless $a eq "\x{100}\x{100}";
-print "ok 64\n";
+is($a, "\x{100}\x{100}");
($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
-print "not " unless $a eq "\x{100}";
-print "ok 65\n";
+is($a, "\x{100}");
$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
-print "not " unless $a eq "\x{1ff}\x{1fe}";
-print "ok 66\n";
+is($a, "\x{1ff}\x{1fe}");
+
# From David Dyck
($a = "R0_001") =~ tr/R_//d;
-print "not " if hex($a) != 1;
-print "ok 67\n";
+is(hex($a), 1);
# From Inaba Hiroto
@a = (1,2); map { y/1/./ for $_ } @a;
-print "not " if "@a" ne ". 2";
-print "ok 68\n";
+is("@a", ". 2");
@a = (1,2); map { y/1/./ for $_.'' } @a;
-print "not " if "@a" ne "1 2";
-print "ok 69\n";
+is("@a", "1 2");
+
# Additional test for Inaba Hiroto patch (robin@kitsite.com)
($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
-print "not " unless $a eq "XZY";
-print "ok 70\n";
+is($a, "XZY");
+
+
+# Used to fail with "Modification of a read-only value attempted"
+%a = (N=>1);
+foreach (keys %a) {
+ eval 'tr/N/n/';
+ is($_, 'n', 'pp_trans needs to unshare shared hash keys');
+ is($@, '', ' no error');
+}
+
+
+$x = eval '"1213" =~ tr/1/1/';
+is($x, 2, 'implicit count on constant');
+is($@, '', ' no error');
+
+
+my @foo = ();
+eval '$foo[-1] =~ tr/N/N/';
+is( $@, '', 'implicit count outside array bounds, index negative' );
+is( scalar @foo, 0, " doesn't extend the array");
+
+eval '$foo[1] =~ tr/N/N/';
+is( $@, '', 'implicit count outside array bounds, index positive' );
+is( scalar @foo, 0, " doesn't extend the array");
+
+
+my %foo = ();
+eval '$foo{bar} =~ tr/N/N/';
+is( $@, '', 'implicit count outside hash bounds' );
+is( scalar keys %foo, 0, " doesn't extend the hash");
+
+$x = \"foo";
+is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
+is( ref $x, 'SCALAR', " doesn't stringify its argument" );
+
+# rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing
+# newline allowed.
+fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '', {}, 'RT #36622 y/// at end of file');
+
+
+{ # [perl #38293] chr(65535) should be allowed in regexes
+no warnings 'utf8'; # to allow non-characters
+
+$s = "\x{d800}\x{ffff}";
+$s =~ tr/\0/A/;
+is($s, "\x{d800}\x{ffff}", "do_trans_simple");
+
+$s = "\x{d800}\x{ffff}";
+$i = $s =~ tr/\0//;
+is($i, 0, "do_trans_count");
+
+$s = "\x{d800}\x{ffff}";
+$s =~ tr/\0/A/s;
+is($s, "\x{d800}\x{ffff}", "do_trans_complex, SQUASH");
+
+$s = "\x{d800}\x{ffff}";
+$s =~ tr/\0/A/c;
+is($s, "AA", "do_trans_complex, COMPLEMENT");
+
+$s = "A\x{ffff}B";
+$s =~ tr/\x{ffff}/\x{1ffff}/;
+is($s, "A\x{1ffff}B", "utf8, SEARCHLIST");
+
+$s = "\x{fffd}\x{fffe}\x{ffff}";
+$s =~ tr/\x{fffd}-\x{ffff}/ABC/;
+is($s, "ABC", "utf8, SEARCHLIST range");
+
+$s = "ABC";
+$s =~ tr/ABC/\x{ffff}/;
+is($s, "\x{ffff}"x3, "utf8, REPLACEMENTLIST");
+
+$s = "ABC";
+$s =~ tr/ABC/\x{fffd}-\x{ffff}/;
+is($s, "\x{fffd}\x{fffe}\x{ffff}", "utf8, REPLACEMENTLIST range");
+
+$s = "A\x{ffff}B\x{100}\0\x{fffe}\x{ffff}";
+$i = $s =~ tr/\x{ffff}//;
+is($i, 2, "utf8, count");
+
+$s = "A\x{ffff}\x{ffff}C";
+$s =~ tr/\x{ffff}/\x{100}/s;
+is($s, "A\x{100}C", "utf8, SQUASH");
+
+$s = "A\x{ffff}\x{ffff}\x{fffe}\x{fffe}\x{fffe}C";
+$s =~ tr/\x{fffe}\x{ffff}//s;
+is($s, "A\x{ffff}\x{fffe}C", "utf8, SQUASH");
+
+$s = "xAABBBy";
+$s =~ tr/AB/\x{ffff}/s;
+is($s, "x\x{ffff}y", "utf8, SQUASH");
+
+$s = "xAABBBy";
+$s =~ tr/AB/\x{fffe}\x{ffff}/s;
+is($s, "x\x{fffe}\x{ffff}y", "utf8, SQUASH");
+
+$s = "A\x{ffff}B\x{fffe}C";
+$s =~ tr/\x{fffe}\x{ffff}/x/c;
+is($s, "x\x{ffff}x\x{fffe}x", "utf8, COMPLEMENT");
+
+$s = "A\x{10000}B\x{2abcd}C";
+$s =~ tr/\0-\x{ffff}/x/c;
+is($s, "AxBxC", "utf8, COMPLEMENT range");
+
+$s = "A\x{fffe}B\x{ffff}C";
+$s =~ tr/\x{fffe}\x{ffff}/x/d;
+is($s, "AxBC", "utf8, DELETE");
+
+} # non-characters end
+
+{ # related to [perl #27940]
+ my $c;
+
+ ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ tr/\c@-\c_//d;
+ is($c, "\x20\x30\x40\x50\x60", "tr/\\c\@-\\c_//d");
+
+ ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ tr/\x00-\x1f//d;
+ is($c, "\x20\x30\x40\x50\x60", "tr/\\x00-\\x1f//d");
+}
+
+($s) = keys %{{pie => 3}};
+SKIP: {
+ if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 }
+ my $wasro = XS::APItest::SvIsCOW($s);
+ ok $wasro, "have a COW";
+ $s =~ tr/i//;
+ ok( XS::APItest::SvIsCOW($s),
+ "count-only tr doesn't deCOW COWs" );
+}
+
+# [ RT #61520 ]
+#
+# under threads, unicode tr within a cloned closure would SEGV or assert
+# fail, since the pointer in the pad to the swash was getting zeroed out
+# in the proto-CV
+
+{
+ my $x = "\x{142}";
+ sub {
+ $x =~ tr[\x{142}][\x{143}];
+ }->();
+ is($x,"\x{143}", "utf8 + closure");
+}
+
+# Freeing of trans ops prior to pmtrans() [perl #102858].
+eval q{ $a ~= tr/a/b/; };
+ok 1;
+SKIP: {
+ no warnings "deprecated";
+ skip "no encoding", 1 unless eval { require encoding; 1 };
+ eval q{ use encoding "utf8"; $a ~= tr/a/b/; };
+ ok 1;
+}
+
+{ # [perl #113584]
+
+ my $x = "Perlα";
+ $x =~ tr/αα/βγ/;
+ { no warnings 'utf8'; print "# $x\n"; } # No note() to avoid wide warning.
+ is($x, "Perlβ", "Only first of multiple transliterations is used");
+}
+
+# tr/a/b/ should fail even on zero-length read-only strings
+use constant nullrocow => (keys%{{""=>undef}})[0];
+for ("", nullrocow) {
+ eval { $_ =~ y/a/b/ };
+ like $@, qr/^Modification of a read-only value attempted at /,
+ 'tr/a/b/ fails on zero-length ro string';
+}
+
+# Whether they're permitted or not, non-modifying tr/// should not write
+# to read-only values, even with funky flags.
+{ # [perl #123759]
+ eval q{ ('a' =~ /./) =~ tr///d };
+ ok(1, "tr///d on PL_Yes does not assert");
+ eval q{ ('a' =~ /./) =~ tr/a-z/a-z/d };
+ ok(1, "tr/a-z/a-z/d on PL_Yes does not assert");
+ eval q{ ('a' =~ /./) =~ tr///s };
+ ok(1, "tr///s on PL_Yes does not assert");
+ eval q{ *x =~ tr///d };
+ ok(1, "tr///d on glob does not assert");
+}
+
+{ # [perl #128734
+ my $string = chr utf8::unicode_to_native(0x00e0);
+ $string =~ tr/\N{U+00e0}/A/;
+ is($string, "A", 'tr// of \N{U+...} works for upper-Latin1');
+ my $string = chr utf8::unicode_to_native(0x00e1);
+ $string =~ tr/\N{LATIN SMALL LETTER A WITH ACUTE}/A/;
+ is($string, "A", 'tr// of \N{name} works for upper-Latin1');
+}
+
+# RT #130198
+# a tr/// that is cho(m)ped, possibly with an array as arg
+
+{
+ use warnings;
+
+ my ($s, @a);
+
+ my $warn;
+ local $SIG{__WARN__ } = sub { $warn .= "@_" };
+
+ for my $c (qw(chop chomp)) {
+ for my $bind ('', '$s =~ ', '@a =~ ') {
+ for my $arg2 (qw(a b)) {
+ for my $r ('', 'r') {
+ $warn = '';
+ # tr/a/b/ modifies its LHS, so if the LHS is an
+ # array, this should die. The special cases of tr/a/a/
+ # and tr/a/b/r don't modify their LHS, so instead
+ # we croak because cho(m)p is trying to modify it.
+ #
+ my $exp =
+ ($r eq '' && $arg2 eq 'b' && $bind =~ /\@a/)
+ ? qr/Can't modify private array in transliteration/
+ : qr{Can't modify transliteration \(tr///\) in $c};
+
+ my $expr = "$c(${bind}tr/a/$arg2/$r);";
+ eval $expr;
+ like $@, $exp, "RT #130198 eval: $expr";
+
+ $exp =
+ $bind =~ /\@a/
+ ? qr{^Applying transliteration \(tr///\) to \@a will act on scalar\(\@a\)}
+ : qr/^$/;
+ like $warn, $exp, "RT #130198 warn: $expr";
+ }
+ }
+ }
+ }
+
+
+}
+1;
https://perl5.git.perl.org / perl5.git / blobdiff