From: Ben Morrow <ben@morrow.me.uk>
Date: Thu, 22 Oct 2009 21:17:51 +0000 (+0200)
Subject: RT#69616: regexp SVs lose regexpness in assignment
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0826785082983bd9b5ba16476c6867f3b390fb9;p=p5sagit%2Fp5-mst-13.2.git

RT#69616: regexp SVs lose regexpness in assignment

It uses reg_temp_copy to copy the REGEXP onto the destination SV without
needing to copy the underlying pattern structure. This means changing
the prototype of reg_temp_copy, so it can copy onto a passed-in SV, but
it isn't API (and probably shouldn't be exported) so I don't think this
is a problem.
---

diff --git a/embed.fnc b/embed.fnc
index 634d482..090b243 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -825,7 +825,7 @@ Ap	|I32	|pregexec	|NN REGEXP * const prog|NN char* stringarg \
 Ap	|void	|pregfree	|NULLOK REGEXP* r
 Ap	|void	|pregfree2	|NN REGEXP *rx
 : FIXME - is anything in re using this now?
-EXp	|REGEXP*|reg_temp_copy	|NN REGEXP* r
+EXp	|REGEXP*|reg_temp_copy	|NULLOK REGEXP* ret_x|NN REGEXP* rx
 Ap	|void	|regfree_internal|NN REGEXP *const rx
 #if defined(USE_ITHREADS)
 Ap	|void*	|regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param
diff --git a/embed.h b/embed.h
index 8dfbd9c..49a4b15 100644
--- a/embed.h
+++ b/embed.h
@@ -3089,7 +3089,7 @@
 #define pregfree(a)		Perl_pregfree(aTHX_ a)
 #define pregfree2(a)		Perl_pregfree2(aTHX_ a)
 #if defined(PERL_CORE) || defined(PERL_EXT)
-#define reg_temp_copy(a)	Perl_reg_temp_copy(aTHX_ a)
+#define reg_temp_copy(a,b)	Perl_reg_temp_copy(aTHX_ a,b)
 #endif
 #define regfree_internal(a)	Perl_regfree_internal(aTHX_ a)
 #if defined(USE_ITHREADS)
diff --git a/pp_ctl.c b/pp_ctl.c
index c62ce26..ea066a0 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -122,7 +122,7 @@ PP(pp_regcomp)
 	    re = (REGEXP*) sv;
     }
     if (re) {
-	re = reg_temp_copy(re);
+	re = reg_temp_copy(NULL, re);
 	ReREFCNT_dec(PM_GETRE(pm));
 	PM_SETRE(pm, re);
     }
diff --git a/proto.h b/proto.h
index 89b48e6..87588fe 100644
--- a/proto.h
+++ b/proto.h
@@ -2557,10 +2557,10 @@ PERL_CALLCONV void	Perl_pregfree2(pTHX_ REGEXP *rx)
 #define PERL_ARGS_ASSERT_PREGFREE2	\
 	assert(rx)
 
-PERL_CALLCONV REGEXP*	Perl_reg_temp_copy(pTHX_ REGEXP* r)
-			__attribute__nonnull__(pTHX_1);
+PERL_CALLCONV REGEXP*	Perl_reg_temp_copy(pTHX_ REGEXP* ret_x, REGEXP* rx)
+			__attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_REG_TEMP_COPY	\
-	assert(r)
+	assert(rx)
 
 PERL_CALLCONV void	Perl_regfree_internal(pTHX_ REGEXP *const rx)
 			__attribute__nonnull__(pTHX_1);
diff --git a/regcomp.c b/regcomp.c
index 5a6ca55..6e9fa26 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -9442,15 +9442,18 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
     
     
 REGEXP *
-Perl_reg_temp_copy (pTHX_ REGEXP *rx)
+Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
 {
-    REGEXP *ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
-    struct regexp *ret = (struct regexp *)SvANY(ret_x);
+    struct regexp *ret;
     struct regexp *const r = (struct regexp *)SvANY(rx);
     register const I32 npar = r->nparens+1;
 
     PERL_ARGS_ASSERT_REG_TEMP_COPY;
 
+    if (!ret_x)
+	ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
+    ret = (struct regexp *)SvANY(ret_x);
+    
     (void)ReREFCNT_inc(rx);
     /* We can take advantage of the existing "copied buffer" mechanism in SVs
        by pointing directly at the buffer, but flagging that the allocated
diff --git a/regexec.c b/regexec.c
index e59b501..402ede3 100644
--- a/regexec.c
+++ b/regexec.c
@@ -3755,7 +3755,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 			assert(rx);
 		    }
 		    if (rx) {
-			rx = reg_temp_copy(rx);
+			rx = reg_temp_copy(NULL, rx);
 		    }
 		    else {
 			U32 pm_flags = 0;
diff --git a/sv.c b/sv.c
index 89825c6..a85966b 100644
--- a/sv.c
+++ b/sv.c
@@ -3891,7 +3891,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 	}
 	/* Fall through */
 #endif
-    case SVt_REGEXP:
     case SVt_PV:
 	if (dtype < SVt_PV)
 	    sv_upgrade(dstr, SVt_PV);
@@ -3914,6 +3913,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 	}
 	break;
 
+    case SVt_REGEXP:
+	if (dtype < SVt_REGEXP)
+	    sv_upgrade(dstr, SVt_REGEXP);
+	break;
+
 	/* case SVt_BIND: */
     case SVt_PVLV:
     case SVt_PVGV:
@@ -4016,6 +4020,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 	    }
 	}
     }
+    else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+	reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
+    }
     else if (sflags & SVp_POK) {
         bool isSwipe = 0;
 
diff --git a/t/op/ref.t b/t/op/ref.t
index a98da6e..aca94a3 100644
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -7,8 +7,9 @@ BEGIN {
 
 require 'test.pl';
 use strict qw(refs subs);
+use re ();
 
-plan(189);
+plan(196);
 
 # Test glob operations.
 
@@ -124,6 +125,32 @@ $subrefref = \\&mysub2;
 is ($$subrefref->("GOOD"), "good");
 sub mysub2 { lc shift }
 
+# Test REGEXP assignment
+
+{
+    my $x = qr/x/;
+    my $str = "$x"; # regex stringification may change
+
+    my $y = $$x;
+    is ($y, $str, "bare REGEXP stringifies correctly");
+    ok (eval { "x" =~ $y }, "bare REGEXP matches correctly");
+    
+    my $z = \$y;
+    ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp");
+    is ($z, $str, "new ref to REGEXP stringifies correctly");
+    ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly");
+}
+{
+    my ($x, $str);
+    {
+        my $y = qr/x/;
+        $str = "$y";
+        $x = $$y;
+    }
+    is ($x, $str, "REGEXP keeps a ref to its mother_re");
+    ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches");
+}
+
 # Test the ref operator.
 
 sub PVBM () { 'foo' }