In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/df052ff84a4fc5e49545a6877ffa22ba4d4e31db?hp=dc35ab6e9838269debf9973a573bbd31031f3f31>
- Log ----------------------------------------------------------------- commit df052ff84a4fc5e49545a6877ffa22ba4d4e31db Author: Ben Morrow <[email protected]> Date: Wed Oct 21 15:33:55 2009 +0100 Let SvRX(OK) recognise a bare REGEXP. This means that re::is_regexp(${qr/x/}) will now return true. M t/re/re.t M util.c commit f0826785082983bd9b5ba16476c6867f3b390fb9 Author: Ben Morrow <[email protected]> Date: Thu Oct 22 23:17:51 2009 +0200 RT#69616: regexp SVs lose regexpness in assignment It uses reg_temp_copy to copy the REGEXP onto the destination SV without needing to copy the underlying pattern structure. This means changing the prototype of reg_temp_copy, so it can copy onto a passed-in SV, but it isn't API (and probably shouldn't be exported) so I don't think this is a problem. M embed.fnc M embed.h M pp_ctl.c M proto.h M regcomp.c M regexec.c M sv.c M t/op/ref.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- embed.h | 2 +- pp_ctl.c | 2 +- proto.h | 6 +++--- regcomp.c | 9 ++++++--- regexec.c | 2 +- sv.c | 9 ++++++++- t/op/ref.t | 29 ++++++++++++++++++++++++++++- t/re/re.t | 20 +++++++++++++++----- util.c | 11 ++++------- 10 files changed, 68 insertions(+), 24 deletions(-) diff --git a/embed.fnc b/embed.fnc index 634d482..090b243 100644 --- a/embed.fnc +++ b/embed.fnc @@ -825,7 +825,7 @@ Ap |I32 |pregexec |NN REGEXP * const prog|NN char* stringarg \ Ap |void |pregfree |NULLOK REGEXP* r Ap |void |pregfree2 |NN REGEXP *rx : FIXME - is anything in re using this now? -EXp |REGEXP*|reg_temp_copy |NN REGEXP* r +EXp |REGEXP*|reg_temp_copy |NULLOK REGEXP* ret_x|NN REGEXP* rx Ap |void |regfree_internal|NN REGEXP *const rx #if defined(USE_ITHREADS) Ap |void* |regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param diff --git a/embed.h b/embed.h index 8dfbd9c..49a4b15 100644 --- a/embed.h +++ b/embed.h @@ -3089,7 +3089,7 @@ #define pregfree(a) Perl_pregfree(aTHX_ a) #define pregfree2(a) Perl_pregfree2(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) -#define reg_temp_copy(a) Perl_reg_temp_copy(aTHX_ a) +#define reg_temp_copy(a,b) Perl_reg_temp_copy(aTHX_ a,b) #endif #define regfree_internal(a) Perl_regfree_internal(aTHX_ a) #if defined(USE_ITHREADS) diff --git a/pp_ctl.c b/pp_ctl.c index c62ce26..ea066a0 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -122,7 +122,7 @@ PP(pp_regcomp) re = (REGEXP*) sv; } if (re) { - re = reg_temp_copy(re); + re = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); } diff --git a/proto.h b/proto.h index 89b48e6..87588fe 100644 --- a/proto.h +++ b/proto.h @@ -2557,10 +2557,10 @@ PERL_CALLCONV void Perl_pregfree2(pTHX_ REGEXP *rx) #define PERL_ARGS_ASSERT_PREGFREE2 \ assert(rx) -PERL_CALLCONV REGEXP* Perl_reg_temp_copy(pTHX_ REGEXP* r) - __attribute__nonnull__(pTHX_1); +PERL_CALLCONV REGEXP* Perl_reg_temp_copy(pTHX_ REGEXP* ret_x, REGEXP* rx) + __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_REG_TEMP_COPY \ - assert(r) + assert(rx) PERL_CALLCONV void Perl_regfree_internal(pTHX_ REGEXP *const rx) __attribute__nonnull__(pTHX_1); diff --git a/regcomp.c b/regcomp.c index 5a6ca55..6e9fa26 100644 --- a/regcomp.c +++ b/regcomp.c @@ -9442,15 +9442,18 @@ Perl_pregfree2(pTHX_ REGEXP *rx) REGEXP * -Perl_reg_temp_copy (pTHX_ REGEXP *rx) +Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) { - REGEXP *ret_x = (REGEXP*) newSV_type(SVt_REGEXP); - struct regexp *ret = (struct regexp *)SvANY(ret_x); + struct regexp *ret; struct regexp *const r = (struct regexp *)SvANY(rx); register const I32 npar = r->nparens+1; PERL_ARGS_ASSERT_REG_TEMP_COPY; + if (!ret_x) + ret_x = (REGEXP*) newSV_type(SVt_REGEXP); + ret = (struct regexp *)SvANY(ret_x); + (void)ReREFCNT_inc(rx); /* We can take advantage of the existing "copied buffer" mechanism in SVs by pointing directly at the buffer, but flagging that the allocated diff --git a/regexec.c b/regexec.c index e59b501..402ede3 100644 --- a/regexec.c +++ b/regexec.c @@ -3755,7 +3755,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog) assert(rx); } if (rx) { - rx = reg_temp_copy(rx); + rx = reg_temp_copy(NULL, rx); } else { U32 pm_flags = 0; diff --git a/sv.c b/sv.c index 89825c6..a85966b 100644 --- a/sv.c +++ b/sv.c @@ -3891,7 +3891,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } /* Fall through */ #endif - case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3914,6 +3913,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } break; + case SVt_REGEXP: + if (dtype < SVt_REGEXP) + sv_upgrade(dstr, SVt_REGEXP); + break; + /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: @@ -4016,6 +4020,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } } } + else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { + reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); + } else if (sflags & SVp_POK) { bool isSwipe = 0; diff --git a/t/op/ref.t b/t/op/ref.t index a98da6e..aca94a3 100644 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -7,8 +7,9 @@ BEGIN { require 'test.pl'; use strict qw(refs subs); +use re (); -plan(189); +plan(196); # Test glob operations. @@ -124,6 +125,32 @@ $subrefref = \\&mysub2; is ($$subrefref->("GOOD"), "good"); sub mysub2 { lc shift } +# Test REGEXP assignment + +{ + my $x = qr/x/; + my $str = "$x"; # regex stringification may change + + my $y = $$x; + is ($y, $str, "bare REGEXP stringifies correctly"); + ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); + + my $z = \$y; + ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); + is ($z, $str, "new ref to REGEXP stringifies correctly"); + ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); +} +{ + my ($x, $str); + { + my $y = qr/x/; + $str = "$y"; + $x = $$y; + } + is ($x, $str, "REGEXP keeps a ref to its mother_re"); + ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); +} + # Test the ref operator. sub PVBM () { 'foo' } diff --git a/t/re/re.t b/t/re/re.t index 8c1c1f8..87965f2 100644 --- a/t/re/re.t +++ b/t/re/re.t @@ -13,11 +13,21 @@ use re qw(is_regexp regexp_pattern regname regnames regnames_count); { my $qr=qr/foo/pi; - ok(is_regexp($qr),'is_regexp($qr)'); + my $rx = $$qr; + + ok(is_regexp($qr),'is_regexp(REGEXP ref)'); + ok(is_regexp($rx),'is_regexp(REGEXP)'); ok(!is_regexp(''),'is_regexp("")'); - is((regexp_pattern($qr))[0],'foo','regexp_pattern[0]'); - is((regexp_pattern($qr))[1],'ip','regexp_pattern[1]'); - is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern'); + + is((regexp_pattern($qr))[0],'foo','regexp_pattern[0] (ref)'); + is((regexp_pattern($qr))[1],'ip','regexp_pattern[1] (ref)'); + is(regexp_pattern($qr),'(?pi-xsm:foo)','scalar regexp_pattern (ref)'); + + is((regexp_pattern($rx))[0],'foo','regexp_pattern[0] (bare REGEXP)'); + is((regexp_pattern($rx))[1],'ip','regexp_pattern[1] (bare REGEXP)'); + is(regexp_pattern($rx),'(?pi-xsm:foo)', + 'scalar regexp_pattern (bare REGEXP)'); + ok(!regexp_pattern(''),'!regexp_pattern("")'); } @@ -42,5 +52,5 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ is(regnames_count(),3); } # New tests above this line, don't forget to update the test count below! -BEGIN { plan tests => 14 } +BEGIN { plan tests => 18 } # No tests here! diff --git a/util.c b/util.c index b72f263..50675d3 100644 --- a/util.c +++ b/util.c @@ -6054,17 +6054,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) { REGEXP * Perl_get_re_arg(pTHX_ SV *sv) { - SV *tmpsv; if (sv) { if (SvMAGICAL(sv)) mg_get(sv); - if (SvROK(sv) && - (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */ - SvTYPE(tmpsv) == SVt_REGEXP) - { - return (REGEXP*) tmpsv; - } + if (SvROK(sv)) + sv = MUTABLE_SV(SvRV(sv)); + if (SvTYPE(sv) == SVt_REGEXP) + return (REGEXP*) sv; } return NULL; -- Perl5 Master Repository
