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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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' }