From c2123ae380a372d506d1b6938667bd785fd8728b Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Wed, 2 Dec 2009 16:01:10 +0000
Subject: [PATCH] Ensure that pp_qr returns a new regexp SV each time. Resolves
 RT #69852.

Instead of returning a(nother) reference to the (pre-compiled) regexp in the
optree, use reg_temp_copy() to create a copy of it, and return a reference to
that. This resolves issues about Regexp::DESTROY not being called in a timely
fashion (the original bug tracked by RT #69852), as well as bugs related to
blessing regexps, and of assigning to regexps, as described in correspondence
added to the ticket.

It transpires that we also need to undo the SvPVX() sharing when ithreads
cloning a Regexp SV, because mother_re is set to NULL, instead of a cloned
copy of the mother_re. This change might fix bugs with regexps and threads in
certain other situations, but as yet neither tests nor bug reports have
indicated any problems, so it might not actually be an edge case that it's
possible to reach.
---
 MANIFEST                |  1 +
 ext/Devel-Peek/t/Peek.t |  6 +++---
 pp_hot.c                | 11 +++++++----
 regcomp.c               | 15 ++++++++++++++-
 t/op/qr.t               | 41 +++++++++++++++++++++++++++++++++++++++++
 t/re/qr_gc.t            |  4 ----
 6 files changed, 66 insertions(+), 12 deletions(-)
 create mode 100644 t/op/qr.t

diff --git a/MANIFEST b/MANIFEST
index c238b8c..7ed1dfe 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4440,6 +4440,7 @@ t/op/pow.t			See if ** works
 t/op/push.t			See if push and pop work
 t/op/pwent.t			See if getpw*() functions work
 t/op/qq.t			See if qq works
+t/op/qr.t			See if qr works
 t/op/quotemeta.t		See if quotemeta works
 t/op/rand.t			See if rand works
 t/op/range.t			See if .. works
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index aeb36d0..33958b8 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -325,12 +325,12 @@ do_test(15,
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = REGEXP\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(OBJECT,POK,pPOK\\)
     IV = 0
-    PV = $ADDR "\\(\\?-xism:tic\\)"\\\0
+    PV = $ADDR "\\(\\?-xism:tic\\)"
     CUR = 12
-    LEN = \\d+
+    LEN = 0
     STASH = $ADDR\\t"Regexp"');
 } else {
 do_test(15,
diff --git a/pp_hot.c b/pp_hot.c
index 48b57d6..2c2edcd 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1209,10 +1209,13 @@ PP(pp_qr)
     SV * const rv = sv_newmortal();
 
     SvUPGRADE(rv, SVt_IV);
-    /* This RV is about to own a reference to the regexp. (In addition to the
-       reference already owned by the PMOP.  */
-    ReREFCNT_inc(rx);
-    SvRV_set(rv, MUTABLE_SV(rx));
+    /* For a subroutine describing itself as "This is a hacky workaround" I'm
+       loathe to use it here, but it seems to be the right fix. Or close.
+       The key part appears to be that it's essential for pp_qr to return a new
+       object (SV), which implies that there needs to be an effective way to
+       generate a new SV from the existing SV that is pre-compiled in the
+       optree.  */
+    SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
     SvROK_on(rv);
 
     if (pkg) {
diff --git a/regcomp.c b/regcomp.c
index dd03745..337f0c4 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -9699,7 +9699,20 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
     ret->saved_copy = NULL;
 #endif
 
-    ret->mother_re      = NULL;
+    if (ret->mother_re) {
+	if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
+	    /* Our storage points directly to our mother regexp, but that's
+	       1: a buffer in a different thread
+	       2: something we no longer hold a reference on
+	       so we need to copy it locally.  */
+	    /* Note we need to sue SvCUR() on our mother_re, because it, in
+	       turn, may well be pointing to its own mother_re.  */
+	    SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
+				   SvCUR(ret->mother_re)+1));
+	    SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
+	}
+	ret->mother_re      = NULL;
+    }
     ret->gofs = 0;
 }
 #endif /* PERL_IN_XSUB_RE */
diff --git a/t/op/qr.t b/t/op/qr.t
new file mode 100644
index 0000000..acabd28
--- /dev/null
+++ b/t/op/qr.t
@@ -0,0 +1,41 @@
+#!./perl -w
+
+use strict;
+
+require './test.pl';
+
+plan(tests => 12);
+
+sub r {
+    return qr/Good/;
+}
+
+my $a = r();
+isa_ok($a, 'Regexp');
+my $b = r();
+isa_ok($b, 'Regexp');
+
+my $b1 = $b;
+
+isnt($a + 0, $b + 0, 'Not the same object');
+
+bless $b, 'Pie';
+
+isa_ok($b, 'Pie');
+isa_ok($a, 'Regexp');
+isa_ok($b1, 'Pie');
+
+my $c = r();
+like("$c", qr/Good/);
+my $d = r();
+like("$d", qr/Good/);
+
+my $d1 = $d;
+
+isnt($c + 0, $d + 0, 'Not the same object');
+
+$$d = 'Bad';
+
+like("$c", qr/Good/);
+like("$d", qr/Bad/);
+like("$d1", qr/Bad/);
diff --git a/t/re/qr_gc.t b/t/re/qr_gc.t
index db2e96e..ca82f42 100644
--- a/t/re/qr_gc.t
+++ b/t/re/qr_gc.t
@@ -9,10 +9,6 @@ BEGIN {
 
 plan tests => 2;
 
-if ($] >= 5.011) { # doesn't leak on 5.10.x
-    $TODO = "leaking since 32751";
-}
-
 my $destroyed;
 {
     sub Regexp::DESTROY { $destroyed++ }
-- 
1.8.3.1