In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/807d97fa921ab01e56e08aa52dc8bbdc14f85ce6?hp=291c057a714c4bb419e91e8b00039d61390c42f9>
- Log -----------------------------------------------------------------
commit 807d97fa921ab01e56e08aa52dc8bbdc14f85ce6
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Jan 8 08:18:21 2018 -0800
perldelta for #130936
commit 6d90e98384148a470db6f66439a13e5955418298
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jan 7 22:23:03 2018 -0800
[perl #130936] Forbid some cases of inward goto
This commit in general forbids entry into the parameter of a binary or
list operator, to avoid crashes and stack corruption.
In cases like
goto f;
push @array, do { f: }
and
goto f;
$a + do { f: };
it’s not possible to fix this in general. Cases like
goto f;
do { f: } + $a;
(jumping into the first parameter) have never caused problems, but I
went ahead and forbad that usage too, since it would be too compli-
cated to figure out exactly which parameter is being jumped into.
(It’s not impossible; it would just double the amount of code used to
find labels.)
List operators taking just a simple list, such as die(), have never
worked properly, because goto() bypasses the pushmark. They could be
made to work, but that would require extra work to distinguish cases
like push and print that have a first operand (sometimes implicit for
print) of a specific type. I figured it was easier just to forbid
jumping into any list operator. It’s also much easier to document.
commit 88490382efb37ca723204b6b6a540d37b76bdc19
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jan 7 21:13:01 2018 -0800
state.t: Allow to run under miniperl
Useful for debugging.
commit d2d357297a6222ca30cb33902f66bbb2ea76ed91
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Jan 7 20:46:54 2018 -0800
Stop alloc_LOGOP from always setting OPf_KIDS
Commit v5.21.1-125-g3253bf8, which added the function, caused entertry
to get a kid op. Before:
$ perl5.20.1 -MO=Concise -eeval{}
5 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 2 -e:1) v:{ ->3
4 <@> leavetry vK ->5
3 <|> entertry(other->4) v ->6
6 <0> stub v ->4
-e syntax OK
Notice entertry has no K. After:
$ perl5.22.0 -MO=Concise -eeval{}
5 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v:{ ->3
4 <@> leavetry vK ->5
3 <|> entertry(other->4) vK ->6
6 <0> stub v ->4
-e syntax OK
This time it has a K, but it has no kid ops.
This causes problems for a patch I am working on, because one
can no longer depend on cUNOPo->op_first being non-null when
o->op_flags & OPf_KIDS.
alloc_LOGOP should only set the KIDS flag if it actually has kids.
-----------------------------------------------------------------------
Summary of changes:
op.c | 3 ++-
pod/perldelta.pod | 5 ++++-
pod/perldiag.pod | 14 ++++++++++++++
pod/perlfunc.pod | 3 ++-
pp_ctl.c | 37 +++++++++++++++++++++++++++++++------
t/lib/croak/pp_ctl | 12 ++++++++++++
t/op/goto.t | 50 +++++++++++++++++++++++++++++++++++++++++++++++++-
t/op/state.t | 14 ++++++++++++--
8 files changed, 126 insertions(+), 12 deletions(-)
diff --git a/op.c b/op.c
index 8b91f60234..ace79ad14c 100644
--- a/op.c
+++ b/op.c
@@ -1545,7 +1545,8 @@ Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
OpTYPE_set(logop, type);
logop->op_first = first;
logop->op_other = other;
- logop->op_flags = OPf_KIDS;
+ if (first)
+ logop->op_flags = OPf_KIDS;
while (kid && OpHAS_SIBLING(kid))
kid = OpSIBLING(kid);
if (kid)
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 3df2835290..da5fe0b745 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -276,7 +276,10 @@ and New Warnings
=item *
-XXX L<message|perldiag/"message">
+L<Can't "goto" into a binary or list expression|perldiag/"Can't
E<quot>gotoE<quot> into a binary or list expression">
+
+Use of C<goto> to jump into the parameter of a binary or list operator has
+been prohibited, to prevent crashes and stack corruption. [perl #130936]
=back
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 7867871998..0b52fe3853 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1031,6 +1031,20 @@ pipe, Perl can't retrieve its name for later use.
(P) An error peculiar to VMS. Perl asked $GETSYI how big you want your
mailbox buffers to be, and didn't get an answer.
+=item Can't "goto" into a binary or list expression
+
+(F) A "goto" statement was executed to jump into the middle of a binary
+or list expression. You can't get there from here. The reason for this
+restriction is that the interpreter would get confused as to how many
+arguments there are, resulting in stack corruption or crashes. This
+error occurs in cases such as these:
+
+ goto F;
+ print do { F: }; # Can't jump into the arguments to print
+
+ goto G;
+ $x + do { G: $y }; # How is + supposed to get its first operand?
+
=item Can't "goto" into a "given" block
(F) A "goto" statement was executed to jump into the middle of a C<given>
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index c13e533dd6..53a19af531 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3457,7 +3457,8 @@ Use of C<goto LABEL> or C<goto EXPR> to jump into a
construct is
deprecated and will issue a warning. Even then, it may not be used to
go into any construct that requires initialization, such as a
subroutine, a C<foreach> loop, or a C<given>
-block. It also can't be used to go into a
+block. In general, it may not be used to jump into the parameter
+of a binary or list operator. It also can't be used to go into a
construct that is optimized away.
The C<goto &NAME> form is quite different from the other forms of
diff --git a/pp_ctl.c b/pp_ctl.c
index e6d39f289e..6e5f34dbd5 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2644,6 +2644,8 @@ PP(pp_redo)
return redo_op;
}
+#define UNENTERABLE (OP *)1
+
STATIC OP *
S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP
**opstack, OP **oplimit)
{
@@ -2662,9 +2664,22 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN
len, U32 flags, OP **opstac
o->op_type == OP_LEAVEGIVEN)
{
*ops++ = cUNOPo->op_first;
- if (ops >= oplimit)
- Perl_croak(aTHX_ "%s", too_deep);
}
+ else 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]
+ && OP_CLASS(o) != OA_LOGOP
+ && o->op_type != OP_LINESEQ
+ && o->op_type != OP_SREFGEN
+ && o->op_type != OP_RV2CV) {
+ 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);
*ops = 0;
if (o->op_flags & OPf_KIDS) {
OP *kid;
@@ -2695,8 +2710,9 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len,
U32 flags, OP **opstac
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
if (ops == opstack)
*ops++ = kid;
- else if (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE)
+ else if (ops[-1] != UNENTERABLE
+ && (ops[-1]->op_type == OP_NEXTSTATE ||
+ ops[-1]->op_type == OP_DBSTATE))
ops[-1] = kid;
else
*ops++ = kid;
@@ -2716,6 +2732,9 @@ S_check_op_type(pTHX_ OP * const o)
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
/* XXX This comment seems to me like wishful thinking. --sprout */
+ if (o == UNENTERABLE)
+ Perl_croak(aTHX_
+ "Can't \"goto\" into a binary or list expression");
if (o->op_type == OP_ENTERITER)
Perl_croak(aTHX_
"Can't \"goto\" into the middle of a foreach loop");
@@ -3069,7 +3088,10 @@ PP(pp_goto)
}
if (*enterops && enterops[1]) {
- I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ I32 i = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
if (enterops[i])
deprecate("\"goto\" to jump into a construct");
}
@@ -3088,7 +3110,10 @@ PP(pp_goto)
if (*enterops && enterops[1]) {
OP * const oldop = PL_op;
- ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ ix = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
S_check_op_type(aTHX_ PL_op);
diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
index 2943bf7551..f705b65357 100644
--- a/t/lib/croak/pp_ctl
+++ b/t/lib/croak/pp_ctl
@@ -21,6 +21,18 @@ EXPECT
given is experimental at - line 2.
Can't "goto" into a "given" block at - line 2.
########
+# NAME goto into expression
+no warnings 'deprecated';
+eval { goto a; 1 + do { a: } }; warn $@;
+eval { goto b; meth { b: } }; warn $@;
+eval { goto c; map { c: } () }; warn $@;
+eval { goto d; f(do { d: }) }; die $@;
+EXPECT
+Can't "goto" into a binary or list expression at - line 2.
+Can't "goto" into a binary or list expression at - line 3.
+Can't "goto" into a binary or list expression at - line 4.
+Can't "goto" into a binary or list expression at - line 5.
+########
# NAME dump with computed label
no warnings 'deprecated';
my $label = "foo";
diff --git a/t/op/goto.t b/t/op/goto.t
index f2f2a25af0..9b7e5ec2f7 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
use warnings;
use strict;
-plan tests => 100;
+plan tests => 121;
our $TODO;
my $deprecated = 0;
@@ -810,3 +810,51 @@ sub revnumcmp ($$) {
}
is eval { join(":", sort revnumcmp (9,5,1,3,7)) }, "9:7:5:3:1",
"can goto at top level of multicalled sub";
+
+# A bit strange, but goingto these constructs should not cause any stack
+# problems. Let’s test them to make sure that is the case.
+no warnings 'deprecated';
+is \sub :lvalue { goto d; ${*{scalar(do { d: \*foo })}} }->(), \$foo,
+ 'goto into rv2sv, rv2gv and scalar';
+is sub { goto e; $#{; do { e: \@_ } } }->(1..7), 6,
+ 'goto into $#{...}';
+is sub { goto f; prototype \&{; do { f: sub ($) {} } } }->(), '$',
+ 'goto into srefgen, prototype and rv2cv';
+is sub { goto g; ref do { g: [] } }->(), 'ARRAY',
+ 'goto into ref';
+is sub { goto j; defined undef ${; do { j: \(my $foo = "foo") } } }->(),'',
+ 'goto into defined and undef';
+is sub { goto k; study ++${; do { k: \(my $foo = "foo") } } }->(),'1',
+ 'goto into study and preincrement';
+is sub { goto l; ~-!${; do { l: \(my $foo = 0) } }++ }->(),~-1,
+ 'goto into complement, not, negation and postincrement';
+like sub { goto n; sin cos exp log sqrt do { n: 1 } }->(),qr/^0\.51439/,
+ 'goto into sin, cos, exp, log, and sqrt';
+ok sub { goto o; srand do { o: 0 } }->(),
+ 'goto into srand';
+cmp_ok sub { goto p; rand do { p: 1 } }->(), '<', 1,
+ 'goto into rand';
+is sub { goto r; chr ord length int hex oct abs do { r: -15.5 } }->(), 2,
+ 'goto into chr, ord, length, int, hex, oct and abs';
+is sub { goto t; ucfirst lcfirst uc lc do { t: "q" } }->(), 'Q',
+ 'goto into ucfirst, lcfirst, uc and lc';
+{ no strict;
+ is sub { goto u; \@{; quotemeta do { u: "." } } }->(), \@{'\.'},
+ 'goto into rv2av and quotemeta';
+}
+is join(" ",sub { goto v; %{; do { v: +{1..2} } } }->()), '1 2',
+ 'goto into rv2hv';
+is join(" ",sub { goto w; $_ || do { w: "w" } }->()), 'w',
+ 'goto into rhs of or';
+is join(" ",sub { goto x; $_ && do { x: "w" } }->()), 'w',
+ 'goto into rhs of and';
+is join(" ",sub { goto z; $_ ? do { z: "w" } : 0 }->()), 'w',
+ 'goto into first leg of ?:';
+is join(" ",sub { goto z; $_ ? 0 : do { z: "w" } }->()), 'w',
+ 'goto into second leg of ?:';
+is sub { goto z; caller do { z: 0 } }->(), 'main',
+ 'goto into caller';
+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';
diff --git a/t/op/state.t b/t/op/state.t
index 4fe67e13c5..67439be893 100644
--- a/t/op/state.t
+++ b/t/op/state.t
@@ -5,7 +5,6 @@ BEGIN {
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
- skip_all_if_miniperl("miniperl can't load attributes");
}
use strict;
@@ -171,6 +170,10 @@ is stateful_init_hash(), "a,b,c,d,foo,3";
# declarations with attributes
+SKIP: {
+skip "no attributes in miniperl", 3, if is_miniperl;
+
+eval q{
sub stateful_attr {
state $a :shared;
state $b :shared = 3;
@@ -187,10 +190,13 @@ sub stateful_attr {
return join(",", $a, $b, join(":", @c), join(":", @d), join(":", %e),
join(":", map { ($_, $f{$_}) } sort keys %f));
}
+};
is stateful_attr(), "1,4,x,a:b:c:x,e:1,a:b:c:d:e:1";
is stateful_attr(), "2,5,x:x,a:b:c:x:x,e:2,a:b:c:d:e:2";
is stateful_attr(), "3,6,x:x:x,a:b:c:x:x:x,e:3,a:b:c:d:e:3";
+}
+
# Recursion
@@ -388,7 +394,11 @@ foreach my $forbidden (<DATA>) {
chomp $forbidden;
no strict 'vars';
eval $forbidden;
- like $@, qr/Initialization of state variables in list currently
forbidden/, "Currently forbidden: $forbidden";
+ like $@,
+ qr/dynamic loading not available(?x:
+ )|Attempt to reload attributes\.pm aborted(?x:
+ )|Initialization of state variables in list currently forbidden/,
+ "Currently forbidden: $forbidden";
}
# [perl #49522] state variable not available
--
Perl5 Master Repository
