From 636209429f2cba997c650b29335a614f2fdf8c87 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 24 Nov 2013 15:55:18 -0800 Subject: [PATCH] Fix bug with (??{$overload}) regexp caching MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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 | 4 ++-- t/re/pat_re_eval.t | 14 +++++++++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/regexec.c b/regexec.c index 072470d..977613f 100644 --- 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; - 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; } diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t index 14d681a..bcc3ac9 100644 --- a/t/re/pat_re_eval.t +++ b/t/re/pat_re_eval.t @@ -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; @@ -1181,6 +1181,18 @@ sub run_tests { 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 -- 1.8.3.1