Commit ab924ffad0 for perl
commit ab924ffad0b16e6050001b56d4863660defa7afe
Author: Richard Leach <rich+perl@hyphen-dash-hyphen.info>
Date: Sun Sep 13 22:53:24 2026 +0000
Add blku_defer to the context block union and use it in pp_goto
This enables `goto` within a `defer {}` or `finally {}` block when
the block is not the final item within its enclosing scope.
This is intended to fix GH #19240, where this worked:
sub foo {
defer {
goto ham;
ham:
print "ham\n";
}
}
foo();
But this did not:
sub foo {
defer {
goto ham;
ham:
print "ham\n";
}
print "uh oh\n";
}
foo();
diff --git a/cop.h b/cop.h
index b864e4d837..dc36e8aa1e 100644
--- a/cop.h
+++ b/cop.h
@@ -1025,6 +1025,10 @@ struct block_givwhen {
SV *defsv_save; /* the original $_ */
};
+/* defer/finally context */
+struct block_defer {
+ OP *defer_root; /* first op of the deferred block's optree */
+};
/* context common to subroutines, evals and loops */
@@ -1047,6 +1051,7 @@ struct block {
struct block_eval blku_eval;
struct block_loop blku_loop;
struct block_givwhen blku_givwhen;
+ struct block_defer blku_defer;
} blk_u;
};
#define blk_oldsp cx_u.cx_blk.blku_oldsp
@@ -1063,6 +1068,7 @@ struct block {
#define blk_eval cx_u.cx_blk.blk_u.blku_eval
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
+#define blk_defer cx_u.cx_blk.blk_u.blku_defer
#define CX_DEBUG(cx, action) \
DEBUG_l( \
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index f191d3d547..58c0d5f837 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -420,6 +420,10 @@ accuracy may follow within this development cycle.
XXX
+=item *
+
+C<goto> within a defer block should now work more consistently. [GH #19240]
+
=back
=head1 Known Problems
diff --git a/pp_ctl.c b/pp_ctl.c
index c4812907ca..bd8f778481 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3821,7 +3821,12 @@ PP(pp_goto)
continue;
case CXt_BLOCK:
if (ix) {
- gotoprobe = OpSIBLING(cx->blk_oldcop);
+ PERL_CONTEXT *encl = &cxstack[ix - 1];
+ /* CXt_DEFER includes finally{} blocks */
+ if (CxTYPE(encl) == CXt_DEFER)
+ gotoprobe = encl->blk_defer.defer_root;
+ else
+ gotoprobe = OpSIBLING(cx->blk_oldcop);
in_block = TRUE;
} else
gotoprobe = PL_main_root;
@@ -6721,12 +6726,14 @@ PP(pp_break)
static void
invoke_defer_block_(pTHX_ U8 type, void * arg_)
{
- OP *start = (OP *) arg_;
+ OP *start = cLOGOPx(arg_)->op_other;
#ifdef DEBUGGING
I32 was_cxstack_ix = cxstack_ix;
#endif
cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
+ CX_CUR()->blk_defer.defer_root =
+ cUNOPx(cLOGOPx(arg_)->op_first)->op_first;
ENTER;
SAVETMPS;
@@ -6806,9 +6813,9 @@ invoke_finally_block(pTHX_ void * arg_)
PP(pp_pushdefer)
{
if(PL_op->op_private & OPpDEFER_FINALLY)
- SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
+ SAVEDESTRUCTOR_X(invoke_finally_block, PL_op);
else
- SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
+ SAVEDESTRUCTOR_X(invoke_defer_block, PL_op);
return NORMAL;
}
diff --git a/regen/embed.pl b/regen/embed.pl
index c5d5e1210a..7fb14b725b 100755
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -3080,6 +3080,7 @@ my @undocumented_potentially_always_hidden = qw(
# not be directly usable by XS code
my %undocumented_always_visible = map { $_ => 1 } qw(
_
+ blk_defer
blk_eval
blk_format
blk_gimme
diff --git a/t/op/defer.t b/t/op/defer.t
index e027672ab5..31876e83b2 100644
--- a/t/op/defer.t
+++ b/t/op/defer.t
@@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan 34;
+plan 36;
use feature 'defer';
no warnings 'experimental::defer';
@@ -352,3 +352,41 @@ no warnings 'experimental::defer';
};
is($deferred, 1, 'defer in single-expression do block runs when exiting block; GH 20491');
}
+
+# [GH #19240]
+{
+ our $gotostr;
+ sub gotofoo {
+ defer {
+ goto ham;
+ $gotostr .= "peas\n";
+ ham:
+ $gotostr .= "ham\n";
+ }
+ $gotostr .= "uh oh\n";
+ }
+
+ gotofoo();
+ is($gotostr, "uh oh\nham\n", 'goto within defer block, with trailing code present');
+
+ # With a twist: hopefully a +1 context level
+ sub goto2foo {
+ defer {
+ if ($gotostr) {
+ $gotostr .= "pineapple\n";
+ goto ham;
+ $gotostr .= "peas\n";
+ } else {
+ ham:
+ $gotostr .= "poppedecorn\n";
+ }
+ }
+ $gotostr .= "spam\n";
+
+ }
+
+ goto2foo();
+ is($gotostr, "uh oh\nham\nspam\npineapple\npoppedecorn\n",
+ 'goto deep within defer block, with trailing code present');
+
+}
diff --git a/t/op/try.t b/t/op/try.t
index d22a9b677a..1682201707 100644
--- a/t/op/try.t
+++ b/t/op/try.t
@@ -358,4 +358,44 @@ no warnings 'experimental::try';
'Parse error for catch without (VAR)');
}
+# Adapted from GH#19240 as per GH#24825
+{
+ our $gotostr;
+ sub gotofoo {
+ try { }
+ catch ($e) { }
+ finally {
+ goto ham;
+ $gotostr .= "peas\n";
+ ham:
+ $gotostr .= "ham\n";
+ }
+ $gotostr .= "uh oh\n";
+ }
+
+ gotofoo();
+ is($gotostr, "ham\nuh oh\n", 'goto within finally block, with trailing code present');
+
+ # With a twist: hopefully a +1 context level
+ sub goto2foo {
+ try {}
+ catch ($e) { }
+ finally {
+ if ($gotostr) {
+ $gotostr .= "pineapple\n";
+ goto ham;
+ $gotostr .= "peas\n";
+ } else {
+ ham:
+ $gotostr .= "poppedecorn\n";
+ }
+ }
+ $gotostr .= "spam\n";
+ }
+
+ goto2foo();
+ is($gotostr, "ham\nuh oh\npineapple\npoppedecorn\nspam\n",
+ 'goto deep within finally block, with trailing code present');
+}
+
done_testing;