mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-27 01:44:43 +00:00
Code Issues Packages Projects Releases Wiki Activity

Permit internal OP_GOTO when forbidding out-of-block ops

Browse Source
This commit is contained in:
Paul "LeoNerd" Evans 2023-03-04 17:13:54 +00:00 committed by Paul Evans
parent 3740cf6d26
commit 2da014bc9f
3 changed files with 79 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
op.c
View File

@ -5147,7 +5147,37 @@ enum {
FORBID_LOOPEX_DEFAULT = (1<<0),
};
static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, const char *blockname)
static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels)
{
switch(o->op_type) {
case OP_NEXTSTATE:
case OP_DBSTATE:
{
STRLEN label_len;
U32 label_flags;
const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags);
if(!label_pv)
break;
SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags);
SAVEFREESV(labelsv);
sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0)));
break;
}
}
if(!(o->op_flags & OPf_KIDS))
return;
OP *kid = cUNOPo->op_first;
while(kid) {
walk_ops_find_labels(aTHX_ kid, gotolabels);
kid = OpSIBLING(kid);
}
}
static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname)
{
bool is_loop = FALSE;
SV *labelsv = NULL;
@ -5162,8 +5192,20 @@ static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, const ch
goto forbid;
case OP_GOTO:
/* TODO: This might be safe, depending on the target */
goto forbid;
{
/* OPf_STACKED means either dynamically computed label or `goto &sub` */
if(o->op_flags & OPf_STACKED)
goto forbid;
SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv),
cPVOPo->op_private & OPpPV_IS_UTF8);
SAVEFREESV(target);
if(hv_fetch_ent(permittedgotos, target, FALSE, 0))
break;
goto forbid;
}
case OP_NEXT:
case OP_LAST:
@ -5224,7 +5266,7 @@ forbid:
OP *kid = cUNOPo->op_first;
while(kid) {
walk_ops_forbid(aTHX_ kid, flags, permittedloops, blockname);
walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname);
kid = OpSIBLING(kid);
if(is_loop) {
@ -5280,7 +5322,12 @@ Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname)
HV *looplabels = newHV();
SAVEFREESV((SV *)looplabels);
walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, blockname);
HV *gotolabels = newHV();
SAVEFREESV((SV *)gotolabels);
walk_ops_find_labels(aTHX_ o, gotolabels);
walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname);
LEAVE;
}

15
t/class/field.t
View File

@ -282,4 +282,19 @@ no warnings 'experimental::class';
'Values for missing');
}
# field initialiser expressions permit `goto` in do {} blocks
{
class Test13 {
field $forwards = do { goto HERE; HERE: 1 };
field $backwards = do { my $x; HERE: ; goto HERE if !$x++; 2 };
method values { return ($forwards, $backwards) }
}
ok(eq_array(
[Test13->new->values],
[1, 2],
'Values for goto inside do {} blocks in field initialisers'));
}
done_testing;

13
t/op/defer.t
View File

@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
plan 26;
plan 28;
use feature 'defer';
no warnings 'experimental::defer';
@ -251,6 +251,17 @@ no warnings 'experimental::defer';
like($e, qr/^Oopsie \d\n/, 'defer block can throw exception during exception unwind');
}
# goto
{
ok(defined eval 'sub { defer { goto HERE; HERE: 1; } }',
'goto forwards within defer {} is permitted') or
diag("Failure was $@");
ok(defined eval 'sub { defer { HERE: 1; goto HERE; } }',
'goto backwards within defer {} is permitted') or
diag("Failure was $@");
}
{
my $sub = sub {
while(1) {