From: Nicholas Clark <nick@ccl4.org>
Date: Tue, 5 Jan 2010 10:58:06 +0000 (+0000)
Subject: Tie::Hash::NamedCapture::* shouldn't abort if passed bad input [RT #71828]
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1d021cc8647e49fd860b50abddff99a11b306e2e;p=p5sagit%2Fp5-mst-13.2.git

Tie::Hash::NamedCapture::* shouldn't abort if passed bad input [RT #71828]
---

diff --git a/t/re/reg_nc_tie.t b/t/re/reg_nc_tie.t
index 7a79a8e..8af3a67 100644
--- a/t/re/reg_nc_tie.t
+++ b/t/re/reg_nc_tie.t
@@ -8,7 +8,7 @@ BEGIN {
 
 # Do a basic test on all the tied methods of Tie::Hash::NamedCapture
 
-print "1..13\n";
+plan(tests => 21);
 
 # PL_curpm->paren_names can be a null pointer. See that this succeeds anyway.
 'x' =~ /(.)/;
@@ -51,3 +51,18 @@ is(join('|', sort keys %+), "a|b|e", "FIRSTKEY/NEXTKEY");
 # SCALAR
 is(scalar(%+), 3, "SCALAR");
 is(scalar(%-), 3, "SCALAR");
+
+# Abuse all methods with undef as the first argument (RT #71828 and then some):
+
+is(Tie::Hash::NamedCapture::FETCH(undef, undef), undef, 'FETCH with undef');
+eval {Tie::Hash::NamedCapture::STORE(undef, undef, undef)};
+like($@, qr/Modification of a read-only value attempted/, 'STORE with undef');
+eval {Tie::Hash::NamedCapture::DELETE(undef, undef)};
+like($@, , qr/Modification of a read-only value attempted/,
+     'DELETE with undef');
+eval {Tie::Hash::NamedCapture::CLEAR(undef)};
+like($@, qr/Modification of a read-only value attempted/, 'CLEAR with undef');
+is(Tie::Hash::NamedCapture::EXISTS(undef, undef), undef, 'EXISTS with undef');
+is(Tie::Hash::NamedCapture::FIRSTKEY(undef), undef, 'FIRSTKEY with undef');
+is(Tie::Hash::NamedCapture::NEXTKEY(undef, undef), undef, 'NEXTKEY with undef');
+is(Tie::Hash::NamedCapture::SCALAR(undef), undef, 'SCALAR with undef');
diff --git a/universal.c b/universal.c
index 941587d..3a91c5c 100644
--- a/universal.c
+++ b/universal.c
@@ -1368,7 +1368,7 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1398,7 +1398,7 @@ XS(XS_Tie_Hash_NamedCapture_STORE)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx) {
+    if (!rx || !SvROK(ST(0))) {
         if (!PL_localizing)
             Perl_croak(aTHX_ "%s", PL_no_modify);
         else
@@ -1421,7 +1421,7 @@ XS(XS_Tie_Hash_NamedCapture_DELETE)
     if (items != 2)
 	croak_xs_usage(cv, "$key, $flags");
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         Perl_croak(aTHX_ "%s", PL_no_modify);
 
     SP -= items;
@@ -1442,7 +1442,7 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         Perl_croak(aTHX_ "%s", PL_no_modify);
 
     SP -= items;
@@ -1464,7 +1464,7 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1492,7 +1492,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1524,7 +1524,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1555,7 +1555,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;