interpolation of @- (and @+) in patterns ([perl #27940] comes back)

Message-Id: <20060725001517.3C5D.BQW10602@nifty.com>

p4raw-id: //depot/perl@28620

3 files changed, 50 insertions, 4 deletions

diff --git a/t/op/pat.t b/t/op/pat.t
index 0de38e14df..f0f1b2bbb7 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -7,7 +7,7 @@
 $| = 1;
 
 # please update note at bottom of file when you change this
-print "1..1212\n"; 
+print "1..1231\n"; 
 
 BEGIN {
     chdir 't' if -d 't';
@@ -3546,9 +3546,35 @@ if ($ordA == 193) {
     ok(defined($res) && length($res)==$size,"\$1 is correct size");
 }
 
+{ # related to [perl #27940]
+    ok("\0-A"  =~ /\c@-A/, '@- should not be interpolated in a pattern');
+    ok("\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern');
+    ok("X\@-A"  =~ /X@-A/, '@- should not be interpolated in a pattern');
+    ok("X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern');
+
+    ok("X\0A" =~ /X\c@?A/,  '\c@?');
+    ok("X\0A" =~ /X\c@*A/,  '\c@*');
+    ok("X\0A" =~ /X\c@(A)/, '\c@(');
+    ok("X\0A" =~ /X(\c@)A/, '\c@)');
+    ok("X\0A" =~ /X\c@|ZA/, '\c@|');
+
+    ok("X\@A" =~ /X@?A/,  '@?');
+    ok("X\@A" =~ /X@*A/,  '@*');
+    ok("X\@A" =~ /X@(A)/, '@(');
+    ok("X\@A" =~ /X(@)A/, '@)');
+    ok("X\@A" =~ /X@|ZA/, '@|');
+
+    local $" = ','; # non-whitespace and non-RE-specific
+    ok('abc' =~ /(.)(.)(.)/, 'the last successful match is bogus');
+    ok("A@+B"  =~ /A@{+}B/,  'interpolation of @+ in /@{+}/');
+    ok("A@-B"  =~ /A@{-}B/,  'interpolation of @- in /@{-}/');
+    ok("A@+B"  =~ /A@{+}B/x, 'interpolation of @+ in /@{+}/x');
+    ok("A@-B"  =~ /A@{-}B/x, 'interpolation of @- in /@{-}/x');
+}
+
 # Keep the following test last -- it may crash perl
 
 ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274")
     or print "# Unexpected outcome: should pass or crash perl\n";
 
-# last test 1211
+# last test 1231
diff --git a/t/op/subst.t b/t/op/subst.t
index bd481e47b3..0b02ff93f4 100755
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 131 );
+plan( tests => 133 );
 
 $x = 'foo';
 $_ = "x";
@@ -553,3 +553,13 @@ is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
 }
 
 
+{ # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not
+    my $c;
+
+    ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g;
+    is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g");
+
+    ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g;
+    is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g");
+}
+
diff --git a/t/op/tr.t b/t/op/tr.t
index 796f96a121..c38b208bb5 100755
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 116;
+plan tests => 118;
 
 my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
 
@@ -455,3 +455,13 @@ 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");
+}
+