Don’t cache qr magic on references

When a scalar is returned from (??{...}) inside a regexp, it gets com-
piled into a regexp if it is not one already.  Then the regexp is sup-
posed to be cached on that scalar (in magic), so that the same scalar
returned again will not require another compilation.

This has never worked correctly with references, because the value was
being cached against the returned scalar itself, whereas the *refer-
ent* of a returned reference was being checked for qr magic.

Commit 636209429 (recent) attempted to fix the resulting bug, but
ended up exposing another, older bug, that e4bfbed39b (5.18) acciden-
tally (?) fixed.  The stringification of a reference can easily change
without the reference itself being touched.  So set-magic (which
clears the qr cache) is never triggered:

{ package o; use overload '""'=>sub{"abc"} }
$x = bless \$y, "o";
sub foo { warn "abc" =~ /(??{$x})/ }
foo();
bless \$y;
warn "$x";
foo();
__END__

Output:
1 at - line 3.
main=SCALAR(0x7fcbc3027478) at - line 6.
1 at - line 3.

Blessing \$y into main causes it to stringify as
main=SCALAR(0x7fcbc3027478).  So how can "abc" match
/main=SCALAR(0x7fcbc3027478)/?

Skipping the cache for references obviously fixes this.  The cache was
only being stored on refs to overloaded objects, which don’t use the
cache.  The only case in which is was being used was when the over-
loaded object was blessed into a non-overloaded class, and then it
was incorrect.

diff --git a/regexec.c b/regexec.c
index 3a74318..c03179e 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -5174,7 +5174,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
 
                        if (!(SvFLAGS(ret)
                              & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
-                                | SVs_GMG))) {
+                                | SVs_GMG | SVf_ROK))) {
                            /* This isn't a first class regexp. Instead, it's
                               caching a regexp onto an existing, Perl visible
                               scalar.  */

diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index 1503e82..96614d2 100644 (file)
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -22,7 +22,7 @@ BEGIN {
 }
 
 
-plan tests => 523;  # Update this when adding/deleting tests.
+plan tests => 524;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1204,6 +1204,17 @@ sub run_tests {
           '(??{$tied_former_overload}) sees the right $1 in FETCH';
     }
 
+    {
+       my @matchsticks;
+       my $ref = bless \my $o, "o";
+       my $foo = sub { push @matchsticks, scalar "abc" =~ /(??{$ref})/ };
+       &$foo;
+       bless \$o;
+       () = "$ref"; # flush AMAGIC flag on main
+       &$foo;
+       is "@matchsticks", "1 ", 'qr magic is not cached on refs';
+    }
+
 } # End of sub run_tests
 
 1;