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.

diff --git a/embedvar.h b/embedvar.h
index 6092318..575b755 100644 (file)
--- 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/intrpvar.h b/intrpvar.h
index 63bc4d1..4243fc8 100644 (file)
--- 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/pod/perldiag.pod b/pod/perldiag.pod
index 2e3496f..b062043 100644 (file)
--- 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/pp_ctl.c b/pp_ctl.c
index 7b8dc5b..2f2a339 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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/t/re/pat.t b/t/re/pat.t
index 36366be..5e863fa 100644 (file)
--- 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 => 821;  # Update this when adding/deleting tests.
+plan tests => 827;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -1830,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;