This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix bug with (??{$overload}) regexp caching
authorFather Chrysostomos <sprout@cpan.org>
Sun, 24 Nov 2013 23:55:18 +0000 (15:55 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 24 Nov 2013 23:56:19 +0000 (15:56 -0800)
When a scalar is returned from (??{...}) inside a regexp, it get 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 e4bfbed39b disabled caching for all scalars except references
to overloaded objects.  This is the result of copy the return value
to a new mortal scalar.  The actual returned scalar then remains
untouched.

So the only case in which the cache value was used was incorrect:
namely, when the regexp was cached against a reference to an over-
loaded object, and a later code block returned a reference to that
reference:

$\="\n";
{ package o; use overload '""'=>sub { "abc" } }
$x = bless [],"o";
$y = \$x;
($y_addr = "$y") =~ y/()//d; # REF(0x7fcb9c02ef08) -> REF0x7fcb9c02ef08
print "$x$y";
print "abc$y_addr" =~ /$x$y/;
print "abc$y_addr" =~ /(??{$x})(??{$y})/;  # does not match; should
print "abcabc" =~ /(??{$x})(??{$y})/;      # matches!
print "__END__";
__END__

Output:

abcREF(0x7ff37182ef68)
0x7ff37182ef68

1
__END__

Should be:

abcREF(0x7ff37182ef68)
0x7ff37182ef68
1

__END__

This commit corrects the logic that checks for cached qr magic, effec-
tively disabling the cache altogether.

A forthcoming commit will re├źnable it (if all goes as planned).

regexec.c
t/re/pat_re_eval.t

index 072470d..977613f 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -5109,8 +5109,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
                            sv = SvRV(sv);
                        if (SvTYPE(sv) == SVt_REGEXP)
                            re_sv = (REGEXP*) sv;
                            sv = SvRV(sv);
                        if (SvTYPE(sv) == SVt_REGEXP)
                            re_sv = (REGEXP*) sv;
-                       else if (SvSMAGICAL(sv)) {
-                           MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
+                       else if (SvSMAGICAL(ret)) {
+                           MAGIC *mg = mg_find(ret, PERL_MAGIC_qr);
                            if (mg)
                                re_sv = (REGEXP *) mg->mg_obj;
                        }
                            if (mg)
                                re_sv = (REGEXP *) mg->mg_obj;
                        }
index 14d681a..bcc3ac9 100644 (file)
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
 }
 
 
-plan tests => 520;  # Update this when adding/deleting tests.
+plan tests => 522;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
 
 run_tests() unless caller;
 
@@ -1181,6 +1181,18 @@ sub run_tests {
        ok("a=" =~ qr//, 'qr completely empty pattern');
     }
 
        ok("a=" =~ qr//, 'qr completely empty pattern');
     }
 
+    {
+       { package o; use overload '""'=>sub { "abc" } }
+       my $x = bless [],"o";
+       my $y = \$x;
+       (my $y_addr = "$y") =~ y/()//d; # REF(0x7fcb9c02) -> REF0x7fcb9c02
+       # $y_addr =~ $y should be true, as should $y_addr =~ /(??{$y})/
+       "abc$y_addr" =~ /(??{$x})(??{$y})/;
+       is "$&", "abc$y_addr",
+          '(??{$x}) does not leak cached qr to (??{\$x}) (match)';
+       is scalar "abcabc" =~ /(??{$x})(??{$y})/, "",
+          '(??{$x}) does not leak cached qr to (??{\$x}) (no match)';
+    }
 
 } # End of sub run_tests
 
 
 } # End of sub run_tests