diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 6 | ||||
| -rw-r--r-- | pp_hot.c | 11 | ||||
| -rw-r--r-- | regcomp.c | 15 | ||||
| -rw-r--r-- | t/op/qr.t | 41 | ||||
| -rw-r--r-- | t/re/qr_gc.t | 4 |
6 files changed, 66 insertions, 12 deletions
@@ -4440,6 +4440,7 @@ t/op/pow.t See if ** works t/op/push.t See if push and pop work t/op/pwent.t See if getpw*() functions work t/op/qq.t See if qq works +t/op/qr.t See if qr works t/op/quotemeta.t See if quotemeta works t/op/rand.t See if rand works t/op/range.t See if .. works diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index aeb36d074d..33958b81d8 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -325,12 +325,12 @@ do_test(15, FLAGS = \\(ROK\\) RV = $ADDR SV = REGEXP\\($ADDR\\) at $ADDR - REFCNT = 2 + REFCNT = 1 FLAGS = \\(OBJECT,POK,pPOK\\) IV = 0 - PV = $ADDR "\\(\\?-xism:tic\\)"\\\0 + PV = $ADDR "\\(\\?-xism:tic\\)" CUR = 12 - LEN = \\d+ + LEN = 0 STASH = $ADDR\\t"Regexp"'); } else { do_test(15, @@ -1209,10 +1209,13 @@ PP(pp_qr) SV * const rv = sv_newmortal(); SvUPGRADE(rv, SVt_IV); - /* This RV is about to own a reference to the regexp. (In addition to the - reference already owned by the PMOP. */ - ReREFCNT_inc(rx); - SvRV_set(rv, MUTABLE_SV(rx)); + /* For a subroutine describing itself as "This is a hacky workaround" I'm + loathe to use it here, but it seems to be the right fix. Or close. + The key part appears to be that it's essential for pp_qr to return a new + object (SV), which implies that there needs to be an effective way to + generate a new SV from the existing SV that is pre-compiled in the + optree. */ + SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx))); SvROK_on(rv); if (pkg) { @@ -9699,7 +9699,20 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) ret->saved_copy = NULL; #endif - ret->mother_re = NULL; + if (ret->mother_re) { + if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) { + /* Our storage points directly to our mother regexp, but that's + 1: a buffer in a different thread + 2: something we no longer hold a reference on + so we need to copy it locally. */ + /* Note we need to sue SvCUR() on our mother_re, because it, in + turn, may well be pointing to its own mother_re. */ + SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re), + SvCUR(ret->mother_re)+1)); + SvLEN_set(dstr, SvCUR(ret->mother_re)+1); + } + ret->mother_re = NULL; + } ret->gofs = 0; } #endif /* PERL_IN_XSUB_RE */ diff --git a/t/op/qr.t b/t/op/qr.t new file mode 100644 index 0000000000..acabd28af7 --- /dev/null +++ b/t/op/qr.t @@ -0,0 +1,41 @@ +#!./perl -w + +use strict; + +require './test.pl'; + +plan(tests => 12); + +sub r { + return qr/Good/; +} + +my $a = r(); +isa_ok($a, 'Regexp'); +my $b = r(); +isa_ok($b, 'Regexp'); + +my $b1 = $b; + +isnt($a + 0, $b + 0, 'Not the same object'); + +bless $b, 'Pie'; + +isa_ok($b, 'Pie'); +isa_ok($a, 'Regexp'); +isa_ok($b1, 'Pie'); + +my $c = r(); +like("$c", qr/Good/); +my $d = r(); +like("$d", qr/Good/); + +my $d1 = $d; + +isnt($c + 0, $d + 0, 'Not the same object'); + +$$d = 'Bad'; + +like("$c", qr/Good/); +like("$d", qr/Bad/); +like("$d1", qr/Bad/); diff --git a/t/re/qr_gc.t b/t/re/qr_gc.t index db2e96ed2c..ca82f420ef 100644 --- a/t/re/qr_gc.t +++ b/t/re/qr_gc.t @@ -9,10 +9,6 @@ BEGIN { plan tests => 2; -if ($] >= 5.011) { # doesn't leak on 5.10.x - $TODO = "leaking since 32751"; -} - my $destroyed; { sub Regexp::DESTROY { $destroyed++ } |