# tr.t
-
-use utf8;
+$|=1;
BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
+ if (is_miniperl()) {
+ eval 'require utf8';
+ if ($@) { skip_all("miniperl, no 'utf8'") }
+ }
}
-plan tests => 138;
+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.
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]');
+}
+
# 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/;
}
#
-
($x = 12) =~ tr/1/3/;
(my $y = 12) =~ tr/1/3/;
($f = 1.5) =~ tr/1/3/;
is $wc, 1, '/r warns just once';
}
-# perlbug [ID 20000511.005]
+# perlbug [ID 20000511.005 (#3237)]
$_ = 'fred';
/([a-z]{2})/;
$1 =~ tr/A-Z//;
# UTF8 range tests from Inaba Hiroto
-# Not working in EBCDIC as of 12674.
($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
is($a, v192.196.172.194.197.172, 'UTF range');
is($a, "XXXXXXXX");
SKIP: {
- skip "not EBCDIC", 4 unless $::IS_EBCDIC;
+ skip "EBCDIC-centric tests", 4 unless $::IS_EBCDIC;
$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
is($c, 2);
# 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/], '');
+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
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