In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/4bfb5532d393d56b18d13bc19f70f6f7a64ae781?hp=ae315a0a3c51e68887704d4907bb6a502a6d4e3f>
- Log -----------------------------------------------------------------
commit 4bfb5532d393d56b18d13bc19f70f6f7a64ae781
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Feb 4 22:50:15 2018 -0800
[perl #132799] Fix goto within block within expr
When goto looks for a label, it builds up a list of ops to enter. But
it begins its search a little too far out relative to the ‘goto’.
Hence, the first op gets skipped.
In 6d90e983841, I forbade same cases of inward goto-into-expression to
avoid stack corruption and crashes. I did this by pushing a marker
on to the list of ops to enter, indicating that an error should be
thrown instead.
Because goto starts the search too far up the context stack, it would
sometimes end up looking inside an expression, which would cause the
first op on the entry list to be such a marker, meaning that the next
item, which should have been skipped, would not be.
That could really screw up the context stack for cases like:
my $e = eval { goto label; label: }
because the entry list would be:
<croak-marker> entertry
instead of the previous:
entertry
Hence, entertry (which enters eval{}) would be executed from *within*
the eval, causing the exit of the eval to leave an eval on the context
stack. Crashes ensued.
This commit fixes it by checking whether we have moved past the begin-
ning of the list of entry ops before pushing a croak-marker on to it.
Goto’s implementation is really complex, and always has been. It
could be greatly simplified now thot ops have parent pointers. But
that should wait for another developement cycle.
-----------------------------------------------------------------------
Summary of changes:
pp_ctl.c | 10 ++++++----
t/op/goto.t | 14 +++++++++++++-
2 files changed, 19 insertions(+), 5 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index 4da40e39b3..89eca4b92a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2645,6 +2645,7 @@ PP(pp_redo)
}
#define UNENTERABLE (OP *)1
+#define GOTO_DEPTH 64
STATIC OP *
S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP
**opstack, OP **oplimit)
@@ -2665,11 +2666,12 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN
len, U32 flags, OP **opstac
{
*ops++ = cUNOPo->op_first;
}
- else if (o->op_flags & OPf_KIDS
+ else if (oplimit - opstack < GOTO_DEPTH) {
+ if (o->op_flags & OPf_KIDS
&& cUNOPo->op_first->op_type == OP_PUSHMARK) {
*ops++ = UNENTERABLE;
- }
- else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
+ }
+ else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
&& OP_CLASS(o) != OA_LOGOP
&& o->op_type != OP_LINESEQ
&& o->op_type != OP_SREFGEN
@@ -2678,6 +2680,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len,
U32 flags, OP **opstac
OP * const kid = cUNOPo->op_first;
if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
*ops++ = UNENTERABLE;
+ }
}
if (ops >= oplimit)
Perl_croak(aTHX_ "%s", too_deep);
@@ -2752,7 +2755,6 @@ PP(pp_goto)
OP *retop = NULL;
I32 ix;
PERL_CONTEXT *cx;
-#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
STRLEN label_len = 0;
diff --git a/t/op/goto.t b/t/op/goto.t
index 9b7e5ec2f7..2bd7972945 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
use warnings;
use strict;
-plan tests => 121;
+plan tests => 122;
our $TODO;
my $deprecated = 0;
@@ -858,3 +858,15 @@ is sub { goto z; exit do { z: return "foo" } }->(), 'foo',
'goto into exit';
is sub { goto z; eval do { z: "'foo'" } }->(), 'foo',
'goto into eval';
+
+# [perl #132799]
+# Erroneous inward goto warning, followed by crash.
+# The eval must be in an assignment.
+sub _routine {
+ my $e = eval {
+ goto L2;
+ L2:
+ }
+}
+_routine();
+pass("bug 132799");
--
Perl5 Master Repository
