#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)
/* 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 $< */
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
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;
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) {
/* 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
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;
}
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,
skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
skip_all_without_unicode_tables();
-plan tests => 821; # Update this when adding/deleting tests.
+plan tests => 827; # Update this when adding/deleting tests.
run_tests() unless caller;
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;