From 2685dc2d9a9865ac92971890d053145da562c094 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 24 Nov 2013 18:12:04 -0800
Subject: [PATCH] Make (??{$tied_ovrld}) see the right $1
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

I can return $1 from a regexp code block and it refers to the last
match *within* the block:

"aab" =~ /(a)((??{"b" =~ m|(.)|; $1}))/;
print "[$1 $2]\n";

Output:
[a b]

Even via a tied variable’s FETCH method:

sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"}
sub ReEvalTieTest::FETCH { "$1" }
tie my $t, "ReEvalTieTest";
"aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/;
print "[$1 $2]\n";

Output:
[a b]

But not if I assign a reference to an overloaded object to the tied
variable first:

sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"}
sub ReEvalTieTest::STORE{}
sub ReEvalTieTest::FETCH { "$1" }
tie my $t, "ReEvalTieTest";
{ package o; use overload '""'=>sub { "abc" } }
$t = bless [], "o";
"aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/;
print "[$1 $2]\n";

Output:
[a a]

$1 now refers to the outer pattern, not the inner pattern.

The code that handles the return value of code blocks was not check-
ing get-magic before overloading.

This commit fixes it to do that.
---
 regexec.c          |  7 +++++--
 t/re/pat_re_eval.t | 13 ++++++++++++-
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/regexec.c b/regexec.c
index 977613f..3a74318 100644
--- a/regexec.c
+++ b/regexec.c
@@ -5103,6 +5103,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
 		else {                   /*  /(??{})  */
 		    /*  if its overloaded, let the regex compiler handle
 		     *  it; otherwise extract regex, or stringify  */
+		    const bool gmg = cBOOL(SvGMAGICAL(ret));
+		    if (gmg)
+			ret = sv_mortalcopy(ret);
 		    if (!SvAMAGIC(ret)) {
 			SV *sv = ret;
 			if (SvROK(sv))
@@ -5115,9 +5118,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
 				re_sv = (REGEXP *) mg->mg_obj;
 			}
 
-			/* force any magic, undef warnings here */
+			/* force any undef warnings here */
 			if (!re_sv) {
-			    ret = sv_mortalcopy(ret);
+			    if (!gmg) ret = sv_mortalcopy(ret);
 			    (void) SvPV_force_nolen(ret);
 			}
 		    }
diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index 4ec4b07..1503e82 100644
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
-plan tests => 522;  # Update this when adding/deleting tests.
+plan tests => 523;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1193,6 +1193,17 @@ sub run_tests {
 	   '(??{$x}) does not leak cached qr to (??{\$x}) (no match)';
     }
 
+    {
+	sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"}
+	sub ReEvalTieTest::STORE{}
+	sub ReEvalTieTest::FETCH { "$1" }
+	tie my $t, "ReEvalTieTest";
+	$t = bless [], "o";
+	"aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/;
+	is "[$1 $2]", "[a b]",
+	   '(??{$tied_former_overload}) sees the right $1 in FETCH';
+    }
+
 } # End of sub run_tests
 
 1;
-- 
2.7.4