This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
rework perl #129903 - inf recursion from use of empty pattern in regex codeblock
authorYves Orton <demerphq@gmail.com>
Mon, 31 Oct 2016 19:22:37 +0000 (20:22 +0100)
committerYves Orton <demerphq@gmail.com>
Tue, 1 Nov 2016 12:29:48 +0000 (13:29 +0100)
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.

embedvar.h
intrpvar.h
pod/perldiag.pod
pp_ctl.c
pp_hot.c
regexec.c
t/re/pat.t

index 6092318..575b755 100644 (file)
 #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)
index 63bc4d1..4243fc8 100644 (file)
@@ -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 $< */
index 2e3496f..b062043 100644 (file)
@@ -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
 
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;
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
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,
index 36366be..5e863fa 100644 (file)
@@ -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;