In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/5585e758ec847fcd75936b77096edf5234d6e0c0?hp=b634eb441c2bbbdbcd8dbcbbc4097658c7439a1f>
- Log ----------------------------------------------------------------- commit 5585e758ec847fcd75936b77096edf5234d6e0c0 Author: Yves Orton <[email protected]> Date: Mon Oct 31 20:22:37 2016 +0100 rework perl #129903 - inf recursion from use of empty pattern in regex codeblock FC didn't like my previous patch for this issue, so here is the one he likes better. With tests and etc. :-) The basic problem is that code like this: /(?{ s!!! })/ can trigger infinite recursion on the C stack (not the normal perl stack) when the last successful pattern in scope is itself. Since the C stack overflows this manifests as an untrappable error/segfault, which then kills perl. We avoid the segfault by simply forbidding the use of the empty pattern when it would resolve to the currently executing pattern. I imagine with a bit of effort someone can trigger the original SEGV, unlike my original fix which forbade use of the empty pattern in a regex code block. So if someone actually reports such a bug we might have to revert to the older approach of prohibiting this. M embedvar.h M intrpvar.h M pod/perldiag.pod M pp_ctl.c M pp_hot.c M regexec.c M t/re/pat.t commit 27deb0cf05ad74bec9ea0da3d1b6405346a66401 Author: Yves Orton <[email protected]> Date: Mon Oct 31 22:44:31 2016 +0100 new feature @{^CAPTURE} (and %{^CAPTURE} and %{^CAPTURE_ALL}) @{^CAPTURE} exposes the capture buffers of the last match as an array. So $1 is ${^CAPTURE}[0]. %{^CAPTURE} is the equivalent to %+ (ie named captures) %{^CAPTURE_ALL} is the equivalent to %- (ie all named captures). M gv.c M mg.c M pod/perlguts.pod M pod/perlvar.pod M sv.c M t/re/pat.t ----------------------------------------------------------------------- Summary of changes: embedvar.h | 1 + gv.c | 46 +++++++++++++++++++++++----------- intrpvar.h | 1 + mg.c | 37 ++++++++++++++++++--------- pod/perldiag.pod | 8 +++--- pod/perlguts.pod | 5 ++-- pod/perlvar.pod | 39 ++++++++++++++++++++++++++--- pp_ctl.c | 22 ++++++++++------ pp_hot.c | 39 +++++++++++++++++++---------- regexec.c | 4 ++- sv.c | 9 +++++-- t/re/pat.t | 76 ++++++++++++++++++++++++++++++++++++++++++++++++-------- 12 files changed, 217 insertions(+), 70 deletions(-) diff --git a/embedvar.h b/embedvar.h index 6092318..575b755 100644 --- a/embedvar.h +++ b/embedvar.h @@ -109,6 +109,7 @@ #define PL_curcopdb (vTHX->Icurcopdb) #define PL_curpad (vTHX->Icurpad) #define PL_curpm (vTHX->Icurpm) +#define PL_curpm_under (vTHX->Icurpm_under) #define PL_curstack (vTHX->Icurstack) #define PL_curstackinfo (vTHX->Icurstackinfo) #define PL_curstash (vTHX->Icurstash) diff --git a/gv.c b/gv.c index 1cf0d8d..2dfb364 100644 --- a/gv.c +++ b/gv.c @@ -1975,6 +1975,22 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '\003': /* $^CHILD_ERROR_NATIVE */ if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) goto magicalize; + /* @{^CAPTURE} %{^CAPTURE} */ + if (memEQs(name, len, "\003APTURE")) { + AV* const av = GvAVn(gv); + UV uv= *name; + + sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + SvREADONLY_on(av); + + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); + + } else /* %{^CAPTURE_ALL} */ + if (memEQs(name, len, "\003APTURE_ALL")) { + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); + } break; case '\005': /* $^ENCODING */ if (memEQs(name, len, "\005NCODING")) @@ -2118,22 +2134,24 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, break; case '-': /* $-, %-, @- */ case '+': /* $+, %+, @+ */ - GvMULTI_on(gv); /* no used once warnings here */ - { - AV* const av = GvAVn(gv); - SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; - - sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - if (avc) - SvREADONLY_on(GvSVn(gv)); - SvREADONLY_on(av); - - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0); + GvMULTI_on(gv); /* no used once warnings here */ + { /* $- $+ */ + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + if (*name == '+') + SvREADONLY_on(GvSVn(gv)); + } + { /* %- %+ */ + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0); + } + { /* @- @+ */ + AV* const av = GvAVn(gv); + const UV uv = (UV)*name; + sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + SvREADONLY_on(av); + } break; - } case '*': /* $* */ case '#': /* $# */ if (sv_type == SVt_PV) diff --git a/intrpvar.h b/intrpvar.h index 63bc4d1..4243fc8 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -73,6 +73,7 @@ PERLVAR(I, multideref_pc, UNOP_AUX_item *) /* Fields used by magic variables such as $@, $/ and so on */ PERLVAR(I, curpm, PMOP *) /* what to do \ interps in REs from */ +PERLVAR(I, curpm_under, PMOP *) /* what to do \ interps in REs from */ PERLVAR(I, tainting, bool) /* doing taint checks */ PERLVARI(I, tainted, bool, FALSE) /* using variables controlled by $< */ diff --git a/mg.c b/mg.c index 238d847..a0ee39d 100644 --- a/mg.c +++ b/mg.c @@ -471,9 +471,7 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) sv_magic(nsv, (type == PERL_MAGIC_tied) ? SvTIED_obj(sv, mg) - : (type == PERL_MAGIC_regdata && mg->mg_obj) - ? sv - : mg->mg_obj, + : mg->mg_obj, toLOWER(type), key, klen); count++; } @@ -619,12 +617,13 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); + REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - if (mg->mg_obj) { /* @+ */ + UV uv= (UV)mg->mg_obj; + if (uv == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); - } else { /* @- */ + } else { /* @- @^CAPTURE @{^CAPTURE} */ I32 paren = RX_LASTPAREN(rx); /* return the last filled */ @@ -632,8 +631,14 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) && (RX_OFFS(rx)[paren].start == -1 || RX_OFFS(rx)[paren].end == -1) ) paren--; - return (U32)paren; - } + if (uv == '-') { + /* @- */ + return (U32)paren; + } else { + /* @^CAPTURE @{^CAPTURE} */ + return paren >= 0 ? (U32)(paren-1) : (U32)-1; + } + } } } @@ -648,9 +653,12 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); + REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - const I32 paren = mg->mg_len; + const UV uv= (UV)mg->mg_obj; + /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ + const I32 paren = mg->mg_len + + (uv == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -660,10 +668,15 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) (t = RX_OFFS(rx)[paren].end) != -1) { SSize_t i; - if (mg->mg_obj) /* @+ */ + + if (uv == '+') /* @+ */ i = t; - else /* @- */ + else if (uv == '-') /* @- */ i = s; + else { /* @^CAPTURE @{^CAPTURE} */ + CALLREG_NUMBUF_FETCH(rx,paren,sv); + return 0; + } if (RX_MATCH_UTF8(rx)) { const char * const b = RX_SUBBEG(rx); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 2e3496f..b062043 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -6916,12 +6916,12 @@ separated by commas, not just aligned on a line. it may skip items, or visit items more than once. Consider using C<keys()> instead of C<each()>. -=item Use of the empty pattern inside of a regex code block is forbidden +=item Infinite recursion via empty pattern (F) You tried to use the empty pattern inside of a regex code block, -for instance C</(?{ s!!! })/>. Currently for implementation reasons -this is forbidden. Generally you can rewrite code that uses the empty -pattern with the appropriate use of C<qr//>. +for instance C</(?{ s!!! })/>, which resulted in re-executing +the same pattern, which is an infinite loop which is broken by +throwing an exception. =item Use of := for an empty attribute list is not allowed diff --git a/pod/perlguts.pod b/pod/perlguts.pod index a6aba00..7f72d65 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1087,8 +1087,9 @@ referring to 'U' magic rather than C<PERL_MAGIC_uvar> for example. The C<obj> argument is stored in the C<mg_obj> field of the C<MAGIC> structure. If it is not the same as the C<sv> argument, the reference count of the C<obj> object is incremented. If it is the same, or if -the C<how> argument is C<PERL_MAGIC_arylen>, or if it is a NULL pointer, -then C<obj> is merely stored, without the reference count being incremented. +the C<how> argument is C<PERL_MAGIC_arylen>, C<PERL_MAGIC_regdatum>, +C<PERL_MAGIC_regdata>, or if it is a NULL pointer, then C<obj> is merely +stored, without the reference count being incremented. See also C<sv_magicext> in L<perlapi> for a more flexible way to add magic to an SV. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 35351b7..467e56f 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -895,16 +895,40 @@ find uses of these problematic match variables in your code. =over 8 =item $<I<digits>> ($1, $2, ...) -X<$1> X<$2> X<$3> +X<$1> X<$2> X<$3> X<$I<digits>> Contains the subpattern from the corresponding set of capturing parentheses from the last successful pattern match, not counting patterns matched in nested blocks that have been exited already. +Note there is a distinction between a capture buffer which matches +the empty string a capture buffer which is optional. Eg, C<(x?)> and +C<(x)?> The latter may be undef, the former not. + These variables are read-only and dynamically-scoped. Mnemonic: like \digits. +=item @{^CAPTURE} +X<@{^CAPTURE}> X<@^CAPTURE> + +An array which contains the capture buffers, if any, of the last +successful pattern match, not counting patterns matched +in nested blocks that have been exited already. + +Note that the 0 index of @{^CAPTURE} is equivalent to $1, the 1 index +is equivalent to $2, etc. + + if ("foal"=~/(.)(.)(.)(.)/) { + print join "-", @{^CAPTURE}; + } + +should output "f-o-a-l". + +See also L</$I<digits>>, L</%{^CAPTURE}> and L</%{^CAPTURE_ALL}>. + +This variable was added in 5.25.7 + =item $MATCH =item $& @@ -1063,10 +1087,12 @@ examples given for the C<@-> variable. This variable was added in Perl v5.6.0. +=item %{^CAPTURE} + =item %LAST_PAREN_MATCH =item %+ -X<%+> X<%LAST_PAREN_MATCH> +X<%+> X<%LAST_PAREN_MATCH> X<%{^CAPTURE}> Similar to C<@+>, the C<%+> hash allows access to the named capture buffers, should they exist, in the last successful match in the @@ -1088,7 +1114,8 @@ iterative access to them via C<each> may have unpredictable results. Likewise, if the last successful match changes, then the results may be surprising. -This variable was added in Perl v5.10.0. +This variable was added in Perl v5.10.0. The C<%{^CAPTURE}> alias was +added in 5.25.7. This variable is read-only and dynamically-scoped. @@ -1136,6 +1163,9 @@ After a match against some variable C<$var>: This variable was added in Perl v5.6.0. +=item %{^CAPTURE_ALL} +X<%{^CAPTURE_ALL}> + =item %- X<%-> @@ -1180,7 +1210,8 @@ iterative access to them via C<each> may have unpredictable results. Likewise, if the last successful match changes, then the results may be surprising. -This variable was added in Perl v5.10.0. +This variable was added in Perl v5.10.0. The C<%{^CAPTURE_ALL}> alias was +added in 5.25.7. This variable is read-only and dynamically-scoped. diff --git a/pp_ctl.c b/pp_ctl.c index 7b8dc5b..2f2a339 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -159,16 +159,24 @@ PP(pp_regcomp) RX_TAINT_on(new_re); } + /* handle the empty pattern */ + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) { + if (PL_curpm == PL_reg_curpm) { + if (PL_curpm_under) { + if (PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); + } else { + pm = PL_curpm_under; + } + } + } else { + pm = PL_curpm; + } + } + #if !defined(USE_ITHREADS) /* can't change the optree at runtime either */ /* PMf_KEEP is handled differently under threads to avoid these problems */ - /* Handle empty pattern */ - if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) { - if (PL_curpm == PL_reg_curpm) - Perl_croak(aTHX_ "Use of the empty pattern inside of " - "a regex code block is forbidden"); - pm = PL_curpm; - } if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ cLOGOP->op_first->op_next = PL_op->op_next; diff --git a/pp_hot.c b/pp_hot.c index cb36cc5..068b902 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1959,14 +1959,20 @@ PP(pp_match) goto nope; } - /* empty pattern special-cased to use last successful pattern if - possible, except for qr// */ - if (!ReANY(rx)->mother_re && !RX_PRELEN(rx) && PL_curpm) { - if (PL_curpm == PL_reg_curpm) - Perl_croak(aTHX_ "Use of the empty pattern inside of " - "a regex code block is forbidden"); - pm = PL_curpm; - rx = PM_GETRE(pm); + /* handle the empty pattern */ + if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) { + if (PL_curpm == PL_reg_curpm) { + if (PL_curpm_under) { + if (PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); + } else { + pm = PL_curpm_under; + } + } + } else { + pm = PL_curpm; + } + rx = PM_GETRE(pm); } if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) { @@ -3162,11 +3168,18 @@ PP(pp_subst) /* handle the empty pattern */ if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) { - if (PL_curpm == PL_reg_curpm) - Perl_croak(aTHX_ "Use of the empty pattern inside of " - "a regex code block is forbidden"); - pm = PL_curpm; - rx = PM_GETRE(pm); + if (PL_curpm == PL_reg_curpm) { + if (PL_curpm_under) { + if (PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); + } else { + pm = PL_curpm_under; + } + } + } else { + pm = PL_curpm; + } + rx = PM_GETRE(pm); } #ifdef PERL_SAWAMPERSAND diff --git a/regexec.c b/regexec.c index aca490e..6c5ce9f 100644 --- a/regexec.c +++ b/regexec.c @@ -6963,7 +6963,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) PL_op = oop; PL_curcop = ocurcop; regcp_restore(rex, runops_cp, &maxopenparen); - PL_curpm = PL_reg_curpm; + PL_curpm_under = PL_curpm; + PL_curpm = PL_reg_curpm; if (logical != 2) break; @@ -9532,6 +9533,7 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) } SET_reg_curpm(reginfo->prog); eval_state->curpm = PL_curpm; + PL_curpm_under = PL_curpm; PL_curpm = PL_reg_curpm; if (RXp_MATCH_COPIED(rex)) { /* Here is a serious problem: we cannot rewrite subbeg, diff --git a/sv.c b/sv.c index d3cb3c2..b2403e3 100644 --- a/sv.c +++ b/sv.c @@ -5657,7 +5657,9 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || - how == PERL_MAGIC_symtab || + how == PERL_MAGIC_regdata || + how == PERL_MAGIC_regdatum || + how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv @@ -13372,7 +13374,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) ? SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param)) : sv_dup_inc(nmg->mg_obj, param) - : sv_dup(nmg->mg_obj, param); + : (nmg->mg_type == PERL_MAGIC_regdatum || + nmg->mg_type == PERL_MAGIC_regdata) + ? nmg->mg_obj + : sv_dup(nmg->mg_obj, param); if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { if (nmg->mg_len > 0) { diff --git a/t/re/pat.t b/t/re/pat.t index 6a71122..5e863fa 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -23,7 +23,7 @@ BEGIN { skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader; skip_all_without_unicode_tables(); -plan tests => 802; # Update this when adding/deleting tests. +plan tests => 827; # Update this when adding/deleting tests. run_tests() unless caller; @@ -638,9 +638,11 @@ sub run_tests { } { - my $message = '@- and @+ tests'; + my $message = '@- and @+ and @{^CAPTURE} tests'; - /a(?=.$)/; + $_= "ace"; + /c(?=.$)/; + is($#{^CAPTURE}, -1, $message); is($#+, 0, $message); is($#-, 0, $message); is($+ [0], 2, $message); @@ -648,66 +650,87 @@ sub run_tests { ok(!defined $+ [1] && !defined $- [1] && !defined $+ [2] && !defined $- [2], $message); - /a(a)(a)/; + /a(c)(e)/; + is($#{^CAPTURE}, 1, $message); # one less than $#- is($#+, 2, $message); is($#-, 2, $message); is($+ [0], 3, $message); is($- [0], 0, $message); + is(${^CAPTURE}[0], "c", $message); is($+ [1], 2, $message); is($- [1], 1, $message); + is(${^CAPTURE}[1], "e", $message); is($+ [2], 3, $message); is($- [2], 2, $message); ok(!defined $+ [3] && !defined $- [3] && + !defined ${^CAPTURE}[2] && !defined ${^CAPTURE}[3] && !defined $+ [4] && !defined $- [4], $message); # Exists has a special check for @-/@+ - bug 45147 ok(exists $-[0], $message); ok(exists $+[0], $message); + ok(exists ${^CAPTURE}[0], $message); + ok(exists ${^CAPTURE}[1], $message); ok(exists $-[2], $message); ok(exists $+[2], $message); + ok(!exists ${^CAPTURE}[2], $message); ok(!exists $-[3], $message); ok(!exists $+[3], $message); + ok(exists ${^CAPTURE}[-1], $message); + ok(exists ${^CAPTURE}[-2], $message); ok(exists $-[-1], $message); ok(exists $+[-1], $message); ok(exists $-[-3], $message); ok(exists $+[-3], $message); ok(!exists $-[-4], $message); ok(!exists $+[-4], $message); + ok(!exists ${^CAPTURE}[-3], $message); - /.(a)(b)?(a)/; + + /.(c)(b)?(e)/; + is($#{^CAPTURE}, 2, $message); # one less than $#- is($#+, 3, $message); is($#-, 3, $message); + is(${^CAPTURE}[0], "c", $message); + is(${^CAPTURE}[2], "e", $message . "[$1 $3]"); is($+ [1], 2, $message); is($- [1], 1, $message); is($+ [3], 3, $message); is($- [3], 2, $message); ok(!defined $+ [2] && !defined $- [2] && - !defined $+ [4] && !defined $- [4], $message); + !defined $+ [4] && !defined $- [4] && + !defined ${^CAPTURE}[1], $message); - /.(a)/; + /.(c)/; + is($#{^CAPTURE}, 0, $message); # one less than $#- is($#+, 1, $message); is($#-, 1, $message); + is(${^CAPTURE}[0], "c", $message); is($+ [0], 2, $message); is($- [0], 0, $message); is($+ [1], 2, $message); is($- [1], 1, $message); ok(!defined $+ [2] && !defined $- [2] && - !defined $+ [3] && !defined $- [3], $message); + !defined $+ [3] && !defined $- [3] && + !defined ${^CAPTURE}[1], $message); - /.(a)(ba*)?/; + /.(c)(ba*)?/; + is($#{^CAPTURE}, 0, $message); # one less than $#- is($#+, 2, $message); is($#-, 1, $message); # Check that values donât stick " "=~/()()()(.)(..)/; - my($m,$p) = (\$-[5], \$+[5]); - () = "$$_" for $m, $p; # FETCH (or eqv.) + my($m,$p,$q) = (\$-[5], \$+[5], \${^CAPTURE}[4]); + () = "$$_" for $m, $p, $q; # FETCH (or eqv.) " " =~ /()/; is $$m, undef, 'values do not stick to @- elements'; is $$p, undef, 'values do not stick to @+ elements'; + is $$q, undef, 'values do not stick to @{^CAPTURE} elements'; } foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', + '${^CAPTURE}[0] = 13', '@- = qw (foo bar)', '$^N = 42') { is(eval $_, undef); like($@, qr/^Modification of a read-only value attempted/, @@ -1807,6 +1830,37 @@ EOP utf8::upgrade($str); ok( $str =~ m{^(a|a\x{b6})$}, "fix [perl #129950] - utf8 case" ); } + { + my $got= run_perl( switches => [ '-l' ], prog => <<'EOF_CODE' ); + my $died= !eval { + $_=qq(ab); + print; + my $p=qr/(?{ s!!x! })/; + /$p/; + print; + /a/; + /$p/; + print; + /b/; + /$p/; + print; + //; + 1; + }; + $error = $died ? ($@ || qq(Zombie)) : qq(none); + print $died ? qq(died) : qq(lived); + print qq(Error: $@); +EOF_CODE + my @got= split /\n/, $got; + is($got[0],"ab","empty pattern in regex codeblock: got expected start string"); + is($got[1],"xab", + "empty pattern in regex codeblock: first subst with no last-match worked right"); + is($got[2],"xxb","empty pattern in regex codeblock: second subst worked right"); + is($got[3],"xxx","empty pattern in regex codeblock: third subst worked right"); + is($got[4],"died","empty pattern in regex codeblock: died as expected"); + like($got[5],qr/Error: Infinite recursion via empty pattern/, + "empty pattern in regex codeblock: produced the right exception message" ); + } } # End of sub run_tests 1; -- Perl5 Master Repository
