Detect forbidden flow at compiletime of `defer` or `finally`

Using the new `forbid_outofblock_ops()`, many kinds of forbidden control
flow out of a `defer` or `finally` block can be detected statically with
this function by analysing the optree, rather than leaving it until
runtime when the attempt is actually made.

5 files changed, 65 insertions, 79 deletions

diff --git a/op.c b/op.c
index ffb72e1dc7..e8fc3a669f 100644
--- a/op.c
+++ b/op.c
@@ -9674,6 +9674,9 @@ Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
 
     PERL_ARGS_ASSERT_NEWDEFEROP;
 
+    forbid_outofblock_ops(block,
+        (flags & (OPpDEFER_FINALLY << 8)) ? "a \"finally\" block" : "a \"defer\" block");
+
     start = LINKLIST(block);
 
     /* Hide the block inside an OP_NULL with no exection */
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index a1fdf425d2..6c1ea4ee1b 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -66,6 +66,18 @@ C<INCDIR> methods will no longer trigger an exception, and instead will
 be treated the same as unblessed coderefs are, and executed as though
 they were an C<INC> hook.
 
+=head2 Forbidden control flow out of C<defer> or C<finally> now detected at compile-time
+
+It is forbidden to attempt to leave a C<defer> or C<finally> block by means
+of control flow such as C<return> or C<goto>. Previous versions of perl could
+only detect this when actually attempted at runtime.
+
+This version of perl adds compile-time detection for many cases that can be
+statically determined. This may mean that code which compiled successfully on
+a previous version of perl is now reported as a compile-time error with this
+one. This only happens in cases where it would have been an error to actually
+execute the code anyway; the error simply happens at an earlier time.
+
 =head1 Security
 
 XXX Any security-related notices go here.  In particular, any security
diff --git a/t/lib/croak/op b/t/lib/croak/op
index b71682794f..d138e3187f 100644
--- a/t/lib/croak/op
+++ b/t/lib/croak/op
@@ -251,3 +251,52 @@ Type of arg 1 to pop must be array (not private hash) at - line 4, near "%a;"
 Type of arg 1 to shift must be array (not private hash) at - line 5, near "%a;"
 Type of arg 1 to unshift must be array (not private hash) at - line 6, near "1;"
 Execution of - aborted due to compilation errors.
+########
+use feature 'defer';
+no warnings 'experimental::defer';
+defer { return "retval" }
+EXPECT
+Can't "return" out of a "defer" block at - line 3.
+########
+use feature 'defer';
+no warnings 'experimental::defer';
+defer { goto HERE }
+HERE:
+EXPECT
+Can't "goto" out of a "defer" block at - line 3.
+########
+use feature 'defer';
+no warnings 'experimental::defer';
+my $subB = sub {};
+defer { goto &$subB }
+EXPECT
+Can't "goto" out of a "defer" block at - line 4.
+########
+use feature 'defer';
+no warnings 'experimental::defer';
+LOOP: while(1) {
+  defer { last LOOP }
+}
+EXPECT
+Can't "last" out of a "defer" block at - line 4.
+########
+use feature 'try';
+no warnings 'experimental::try';
+try {} catch ($e) {} finally { return "123" }
+EXPECT
+Can't "return" out of a "finally" block at - line 3.
+########
+use feature 'try';
+no warnings 'experimental::try';
+try {} catch ($e) {} finally { goto HERE; }
+HERE:
+EXPECT
+Can't "goto" out of a "finally" block at - line 3.
+########
+use feature 'try';
+no warnings 'experimental::try';
+LOOP: {
+  try {} catch ($e) {} finally { last LOOP; }
+}
+EXPECT
+Can't "last" out of a "finally" block at - line 4.
diff --git a/t/op/defer.t b/t/op/defer.t
index 20acd0c3ea..c651312cb5 100644
--- a/t/op/defer.t
+++ b/t/op/defer.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan 30;
+plan 26;
 
 use feature 'defer';
 no warnings 'experimental::defer';
@@ -254,33 +254,6 @@ no warnings 'experimental::defer';
 {
     my $sub = sub {
         while(1) {
-            defer { return "retval" }
-            last;
-        }
-        return "wrong";
-    };
-
-    my $e = defined eval { $sub->(); 1 } ? undef : $@;
-    like($e, qr/^Can't "return" out of a "defer" block /,
-        'Cannot return out of defer block');
-}
-
-{
-    my $sub = sub {
-        while(1) {
-            defer { goto HERE }
-        }
-        HERE:
-    };
-
-    my $e = defined eval { $sub->(); 1 } ? undef : $@;
-    like($e, qr/^Can't "goto" out of a "defer" block /,
-        'Cannot goto out of defer block');
-}
-
-{
-    my $sub = sub {
-        while(1) {
             goto HERE;
             defer { HERE: 1; }
         }
@@ -292,31 +265,6 @@ no warnings 'experimental::defer';
 }
 
 {
-    my $subA = sub {
-        my $subB = sub {};
-        while(1) {
-            defer { goto &$subB }
-        }
-    };
-
-    my $e = defined eval { $subA->(); 1 } ? undef : $@;
-    like($e, qr/^Can't "goto" out of a "defer" block at /,
-        'Cannot goto &SUB out of a "defer" block');
-}
-
-{
-    my $sub = sub {
-        LOOP: while(1) {
-            defer { last LOOP }
-        }
-    };
-
-    my $e = defined eval { $sub->(); 1 } ? undef : $@;
-    like($e, qr/^Can't "last" out of a "defer" block /,
-        'Cannot last out of defer block');
-}
-
-{
     # strictness failures are only checked at optree finalization time. This
     # is a good way to test if that happens.
     my $ok = eval 'defer { use strict; foo }';
diff --git a/t/op/try.t b/t/op/try.t
index 97f9a0b8f0..79ee66a171 100644
--- a/t/op/try.t
+++ b/t/op/try.t
@@ -326,32 +326,6 @@ no warnings 'experimental::try';
     ok($finally_invoked, 'finally block still invoked for side-effects');
 }
 
-# Complaints about forbidden control flow talk about "finally" blocks, not "defer"
-{
-    my $e;
-
-    $e = defined eval {
-        try {} catch ($e) {} finally { return "123" }
-        1;
-    } ? undef : $@;
-    like($e, qr/^Can't "return" out of a "finally" block /,
-        'Cannot return out of finally block');
-
-    $e = defined eval {
-        try {} catch ($e) {} finally { goto HERE; }
-        HERE: 1;
-    } ? undef : $@;
-    like($e, qr/^Can't "goto" out of a "finally" block /,
-        'Cannot goto out of finally block');
-
-    $e = defined eval {
-        LOOP: { try {} catch ($e) {} finally { last LOOP; } }
-        1;
-    } ? undef : $@;
-    like($e, qr/^Can't "last" out of a "finally" block /,
-        'Cannot last out of finally block');
-}
-
 # Nicer compiletime errors
 {
     my $e;