This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make (??{$tied_ovrld}) see the right $1
authorFather Chrysostomos <sprout@cpan.org>
Mon, 25 Nov 2013 02:12:04 +0000 (18:12 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 25 Nov 2013 03:57:07 +0000 (19:57 -0800)
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
t/re/pat_re_eval.t

index 977613f..3a74318 100644 (file)
--- 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);
                        }
                    }
index 4ec4b07..1503e82 100644 (file)
@@ -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;