op.c - Restrict nested eval/BEGIN blocks to a user controllable maximum

Nested BEGIN blocks can cause us to segfault by exhausting
the C stack. Eg:

    perl -le'sub f { eval "BEGIN { f() }" } f()'

will segfault. This adds a new interpreter var PL_eval_begin_nest_depth
to keep track of how many layer of eval/BEGIN we have seen, and a new
reserved variable called ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} which can be
used to raise or lower the limit. When set to 0 it blocks BEGIN entirely,
which might be useful from time to time.

This fixes https://github.com/Perl/perl5/issues/20176

11 files changed, 220 insertions, 1 deletions

diff --git a/INSTALL b/INSTALL
index 9821602baf..d10b6e8cd0 100644
--- a/INSTALL
+++ b/INSTALL
@@ -528,6 +528,38 @@ C<-Accflags=-DNO_PERL_HASH_ENV>.
 The C<PERL_HASH_SEED_DEBUG> environment variable can be disabled by
 configuring perl with C<-Accflags=-DNO_PERL_HASH_SEED_DEBUG>.
 
+=head3 MISCELLANEOUS CONFIG
+
+Perl uses various defines to control defaults for its behavior. These
+values are chosen to represent "sane" config, but users can override
+these values in their builds if they wish. This is a list of such
+settings.
+
+=over 2
+
+=item PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT
+
+This define is used to control the default maximum number of nested
+eval/BEGIN statements, and in this context require should be
+understood to be a special form of eval so this means require/BEGIN
+and "use" statements as well.
+
+Currently each C<BEGIN> block inside of an C<eval EXPR> or C<require>
+operation will use a fairly high number of frames of the perl internal
+C stack, and this value is used to prevent stack overflows. Normally
+it is defaulted to 1000 but the default can be configured to another
+value, for instance 100, like this
+
+  -Accflags='-DPERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT=100'
+
+
+If you don't know what this is then it is safe to ignore it. Do not
+configure this to 0 or another very low value, it will break a lot of
+code. If you want to set it to a low value use the run time variable
+C<${^MAX_NESTED_EVAL_BEGIN_BLOCKS}> instead.
+
+=back
+
 =head3 SOCKS
 
 Perl can be configured to be 'socksified', that is, to use the SOCKS
diff --git a/embedvar.h b/embedvar.h
index 8517b1a9dc..2f392df58e 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -127,6 +127,7 @@
 #define PL_envgv		(vTHX->Ienvgv)
 #define PL_errgv		(vTHX->Ierrgv)
 #define PL_errors		(vTHX->Ierrors)
+#define PL_eval_begin_nest_depth	(vTHX->Ieval_begin_nest_depth)
 #define PL_eval_root		(vTHX->Ieval_root)
 #define PL_eval_start		(vTHX->Ieval_start)
 #define PL_evalseq		(vTHX->Ievalseq)
diff --git a/intrpvar.h b/intrpvar.h
index fe20baad97..fc3914b1b0 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -787,6 +787,8 @@ PERLVARI(I, phase,	enum perl_phase, PERL_PHASE_CONSTRUCT)
 
 PERLVARI(I, in_load_module, bool, FALSE)	/* to prevent recursions in PerlIO_find_layer */
 
+PERLVARI(I, eval_begin_nest_depth, U32, 0)
+
 PERLVAR(I, unsafe,	bool)
 PERLVAR(I, colorset,	bool)		/* PERL_RE_COLORS env var is in use */
 
diff --git a/op.c b/op.c
index 6e19ef4c18..abe7e8a0ad 100644
--- a/op.c
+++ b/op.c
@@ -10717,11 +10717,73 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
     if (*name == 'B') {
         if (strEQ(name, "BEGIN")) {
             const I32 oldscope = PL_scopestack_ix;
+            SV *max_nest_sv = NULL;
+            IV max_nest_iv;
             dSP;
             (void)CvGV(cv);
             if (floor) LEAVE_SCOPE(floor);
             ENTER;
 
+            /* make sure we don't recurse too deeply into BEGIN blocks
+             * but let the user control it via the new control variable
+             *
+             *   ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
+             *
+             * Note this *looks* code like when max_nest_iv is 1 that it
+             * would block the following code:
+             *
+             * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
+             *
+             * but it does *not*, this code will happily execute when
+             * the nest limit is 1. The reason is revealed in the
+             * execution order. If we could watch $n in this code we
+             * would see the follow order of modifications:
+             *
+             * $n |= 4;
+             * $n |= 2;
+             * $n |= 1;
+             *
+             * This is because nested BEGIN blocks execute in FILO
+             * order, this is because BEGIN blocks are defined to
+             * execute immediately they are closed. So the innermost
+             * block is closed first, and it executes, which would the
+             * eval_begin_nest_depth by 1, it would finish, which would
+             * drop it back to its previous value. This would happen in
+             * turn as each BEGIN was terminated.
+             *
+             * The *only* place these counts matter is when BEGIN in
+             * inside of some kind of eval, either a require or a true
+             * eval. Only in that case would there be any nesting and
+             * would perl try to execute a BEGIN before another had
+             * completed.
+             *
+             * Thus this logic puts an upper limit on module nesting.
+             * Hence the reason we let the user control it, although its
+             * hard to imagine a 1000 level deep module use dependency
+             * even in a very large codebase. The real objective is to
+             * prevent code like this:
+             *
+             * perl -e'sub f { eval "BEGIN { f() }" } f()'
+             *
+             * from segfaulting due to stack exhaustion.
+             *
+             */
+            max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
+            if (!SvOK(max_nest_sv))
+                sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
+            max_nest_iv = SvIV(max_nest_sv);
+            if (max_nest_iv < 0) {
+                max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
+                sv_setiv(max_nest_sv, max_nest_iv);
+            }
+
+            if (PL_eval_begin_nest_depth >= max_nest_iv) {
+                Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
+                             max_nest_iv);
+            }
+            SAVEINT(PL_eval_begin_nest_depth);
+            PL_eval_begin_nest_depth++;
+
             SAVEVPTR(PL_curcop);
             if (PL_curcop == &PL_compiling) {
                 /* Avoid pushing the "global" &PL_compiling onto the
diff --git a/perl.h b/perl.h
index 791262dd3d..7cef91a65b 100644
--- a/perl.h
+++ b/perl.h
@@ -8900,6 +8900,21 @@ END_EXTERN_C
 #define PERL_SRAND_OVERRIDE_NEXT_PARENT() \
     PERL_SRAND_OVERRIDE_NEXT()
 
+/* in something like
+ *
+ * perl -le'sub f { eval "BEGIN{ f() }" }'
+ *
+ * Each iteration chews up 8 stacks frames, and we will eventually SEGV
+ * due to C stack overflow.
+ *
+ * This define provides a maximum limit to prevent the SEGV. Such code is
+ * unusual, so it unlikely we need a very large number here.
+ */
+#ifndef PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT
+#define PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT 1000
+#endif
+/* ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} */
+#define PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS "\015AX_NESTED_EVAL_BEGIN_BLOCKS"
 
 /*
 
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 8fbc37f62a..31f0eede67 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -395,6 +395,22 @@ same as plain L<perlapi/C<Perl_langinfo>>, but with an extra parameter
 that allows the caller to simply and reliably know if the returned
 string is UTF-8.
 
+=item *
+
+We have introduced a limit on the number of nested C<eval EXPR>/C<BEGIN>
+blocks and C<require>/C<BEGIN> (and thus C<use> statements as well) to
+prevent C stack overflows. This variable can also be used to forbid
+C<BEGIN> blocks from executing during C<eval EXPR> compilation. The
+limit defaults to C<1000> but can be overriden by setting the
+C<${^MAX_NESTED_EVAL_BEGIN_BLOCKS}> variable. The default itself can be
+changed at compile time with
+
+    -Accflags='-DPERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT=12345'
+
+Note that this value relates to the size of your C stack and if you
+choose an inappropriately large value Perl may segfault, be conservative
+about what you choose.
+
 =back
 
 =head1 Selected Bug Fixes
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3b6a31f20d..0b784e1fb8 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -6375,6 +6375,19 @@ setting C<${^RE_COMPILE_RECURSION_LIMIT}> to some other value.  This may
 need to be done in a BEGIN block before the regular expression pattern
 is compiled.
 
+=item Too many nested BEGIN blocks, maximum of %d allowed
+
+(F) You have executed code that nests too many BEGIN blocks inside of
+each other, either explicitly as BEGIN{} or implicitly as use statements.
+This limit defaults to a rather high number which should not be exceeded
+in normal circumstances, and triggering likely indicates something is
+very wrong in your code. For instance infinite recursion of eval and
+BEGIN blocks is known to trigger this error.
+
+If you know that you have good reason to exceed the limit you can change
+it by setting C<${^MAX_NESTED_EVAL_BEGIN_BLOCKS}> to a different value from
+the default of 1000.
+
 =item Too many )'s
 
 (A) You've accidentally run your script through B<csh> instead of Perl.
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index fa16cbd69c..b723cbbcb1 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2237,6 +2237,16 @@ context of the current Perl program, any outer lexical variables are
 visible to it, and any package variable settings or subroutine and
 format definitions remain afterwards.
 
+Note that when C<BEGIN {}> blocks are embedded inside of an eval block
+the contents of the block will be executed immediately and before the rest
+of the eval code is executed. You can disable this entirely by
+
+   local ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 0;
+   eval $string;
+
+which will cause any embedded C<BEGIN> blocks in C<$string> to throw an
+exception.
+
 =over 4
 
 =item Under the L<C<"unicode_eval"> feature|feature/The 'unicode_eval' and 'evalbytes' features>
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 3066d54385..e74bf4dae5 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -584,6 +584,54 @@ this variable.
 
 This variable was added in Perl 5.004.
 
+=item ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
+
+This variable determines the maximum number C<eval EXPR>/C<BEGIN> or
+C<require>/C<BEGIN> block nesting that is allowed. This means it also
+controls the maximum nesting of C<use> statements as well.
+
+The default of 1000 should be sufficiently large for normal working
+purposes, and if you must raise it then you should be conservative
+with your choice or you may encounter segfaults from exhaustion of
+the C stack. It seems unlikely that real code has a use depth above
+1000, but we have left this configurable just in case.
+
+When set to C<0> then C<BEGIN> blocks inside of C<eval EXPR> or
+C<require EXPR> are forbidden entirely and will trigger an exception
+which will terminate the compilation and in the case of C<require>
+will throw an exception, or in the case of C<eval> return the error in
+C<$@> as usual.
+
+Consider the code
+
+ perl -le'sub f { eval "BEGIN { f() }"; } f()'
+
+each invocation of C<f()> will consume considerable C stack, and this
+variable is used to cause code like this to die instead of exhausting
+the C stack and triggering a segfault. Needless to say code like this is
+unusual, it is unlikely you will actually need to raise the setting.
+However it may be useful to set it to 0 for a limited time period to
+prevent BEGIN{} blocks from being executed during an C<eval EXPR>.
+
+Note that setting this to 1 would NOT affect code like this:
+
+    BEGIN { $n += 1; BEGIN { $n += 2; BEGIN { $n += 4 } } }
+
+The reason is that BEGIN blocks are executed immediately after they are
+completed, thus the innermost will execute before the ones which contain
+it have even finished compiling, and the depth will not go above 1. In
+fact the above code is equivalent to
+
+    BEGIN { $n+=4 }
+    BEGIN { $n+=2 }
+    BEGIN { $n+=1 }
+
+which makes it obvious why a ${^MAX_EVAL_BEGIN_DEPTH} of 1 would not
+block this code.
+
+Only C<BEGIN>'s executed inside of an C<eval> or C<require> (possibly via
+C<use>) are affected.
+
 =item $OSNAME
 
 =item $^O
diff --git a/sv.c b/sv.c
index 5ee2df90e0..0e55974e31 100644
--- a/sv.c
+++ b/sv.c
@@ -15435,6 +15435,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_savestack_max = -1;
     PL_sig_pending = 0;
     PL_parser = NULL;
+    PL_eval_begin_nest_depth = proto_perl->Ieval_begin_nest_depth;
     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
     Zero(&PL_padname_undef, 1, PADNAME);
     Zero(&PL_padname_const, 1, PADNAME);
diff --git a/t/op/eval.t b/t/op/eval.t
index 8b7a44a75c..9add15f34b 100644
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 140);
+plan(tests => 146);
 
 eval 'pass();';
 
@@ -697,3 +697,22 @@ pass("eval in freed package does not crash");
     eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
     ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit");
 }
+
+{
+    local ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 0;
+    my ($x, $ok);
+    $x = 0;
+    $ok= eval 'BEGIN { $x++ } 1';
+    ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 0 blocks BEGIN blocks entirely');
+    ::like($@,qr/Too many nested BEGIN blocks, maximum of 0 allowed/,
+        'Blocked BEGIN results in expected error');
+    ::is($x,0,'BEGIN really did nothing');
+
+    ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 2;
+    $ok= eval 'sub f { my $n= shift; eval q[BEGIN { $x++; f($n-1) if $n>0 } 1] or die $@ } f(3); 1';
+    ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 2 blocked three nested BEGIN blocks');
+    ::like($@,qr/Too many nested BEGIN blocks, maximum of 2 allowed/,
+        'Blocked BEGIN results in expected error');
+    ::is($x,2,'BEGIN really did nothing');
+
+}