Ensure that forbidden control flow messages about finally blocks say "finally" and not "defer"

1 files changed, 36 insertions, 7 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 8f13f895d3..44289bbd68 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2481,6 +2481,11 @@ PP(pp_leavesublv)
     return retop;
 }
 
+static const char *S_defer_blockname(PERL_CONTEXT *cx)
+{
+    return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
+}
+
 
 PP(pp_return)
 {
@@ -2494,7 +2499,10 @@ PP(pp_return)
         /* Check for  defer { return; } */
         for(i = cxstack_ix; i > cxix; i--) {
             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
-                Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "return");
+                /* diag_listed_as: Can't "%s" out of a "defer" block */
+                /* diag_listed_as: Can't "%s" out of a "finally" block */
+                Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+                        "return", S_defer_blockname(&cxstack[i]));
         }
         if (cxix < 0) {
             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
@@ -2640,7 +2648,10 @@ S_unwind_loop(pTHX)
         /* Check for  defer { last ... } etc */
         for(i = cxstack_ix; i > cxix; i--) {
             if(CxTYPE(&cxstack[i]) == CXt_DEFER)
-                Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", OP_NAME(PL_op));
+                /* diag_listed_as: Can't "%s" out of a "defer" block */
+                /* diag_listed_as: Can't "%s" out of a "finally" block */
+                Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+                        OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
         }
         dounwind(cxix);
     }
@@ -2893,7 +2904,9 @@ PP(pp_goto)
             /* Check for  defer { goto &...; } */
             for(ix = cxstack_ix; ix > cxix; ix--) {
                 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
-                    Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
+                    /* diag_listed_as: Can't "%s" out of a "defer" block */
+                    Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
+                            "goto", S_defer_blockname(&cxstack[ix]));
             }
 
             /* First do some returnish stuff. */
@@ -3135,7 +3148,8 @@ PP(pp_goto)
             case CXt_NULL:
                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
             case CXt_DEFER:
-                DIE(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
+                /* diag_listed_as: Can't "%s" out of a "defer" block */
+                DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
             default:
                 if (ix)
                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
@@ -5461,14 +5475,14 @@ PP(pp_break)
 }
 
 static void
-invoke_defer_block(pTHX_ void *_arg)
+_invoke_defer_block(pTHX_ U8 type, void *_arg)
 {
     OP *start = (OP *)_arg;
 #ifdef DEBUGGING
     I32 was_cxstack_ix = cxstack_ix;
 #endif
 
-    cx_pushblock(CXt_DEFER, G_VOID, PL_stack_sp, PL_savestack_ix);
+    cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
     ENTER;
     SAVETMPS;
 
@@ -5496,9 +5510,24 @@ invoke_defer_block(pTHX_ void *_arg)
     assert(cxstack_ix == was_cxstack_ix);
 }
 
+static void
+invoke_defer_block(pTHX_ void *_arg)
+{
+    _invoke_defer_block(aTHX_ CXt_DEFER, _arg);
+}
+
+static void
+invoke_finally_block(pTHX_ void *_arg)
+{
+    _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg);
+}
+
 PP(pp_pushdefer)
 {
-    SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
+    if(PL_op->op_private & OPpDEFER_FINALLY)
+        SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
+    else
+        SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
 
     return NORMAL;
 }