This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #122107] ensure that BEGIN blocks with errors don't remain named subs
authorTony Cook <tony@develop-help.com>
Mon, 14 Jul 2014 00:40:47 +0000 (10:40 +1000)
committerTony Cook <tony@develop-help.com>
Sun, 10 Aug 2014 23:32:09 +0000 (09:32 +1000)
embed.fnc
embed.h
op.c
proto.h
t/op/sub.t

index 90c56ed..b70404d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1934,6 +1934,8 @@ s |OP*    |ref_array_or_hash|NULLOK OP* cond
 s      |void   |process_special_blocks |I32 floor \
                                        |NN const char *const fullname\
                                        |NN GV *const gv|NN CV *const cv
+s      |void   |clear_special_blocks   |NN const char *const fullname\
+                                       |NN GV *const gv|NN CV *const cv
 #endif
 Xpa    |void*  |Slab_Alloc     |size_t sz
 Xp     |void   |Slab_Free      |NN void *op
diff --git a/embed.h b/embed.h
index 7ca719d..3962901 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
 #define bad_type_gv(a,b,c,d,e) S_bad_type_gv(aTHX_ a,b,c,d,e)
 #define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e)
+#define clear_special_blocks(a,b,c)    S_clear_special_blocks(aTHX_ a,b,c)
 #define cop_free(a)            S_cop_free(aTHX_ a)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)
 #define finalize_op(a)         S_finalize_op(aTHX_ a)
diff --git a/op.c b/op.c
index 7bdfbce..d2bd2e0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7669,7 +7669,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
        has_name = FALSE;
     }
-
     if (!ec)
         move_proto_attr(&proto, &attrs, gv);
 
@@ -7929,8 +7928,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            }
        }
 
-       if (name && ! (PL_parser && PL_parser->error_count))
-           process_special_blocks(floor, name, gv, cv);
+        if (name) {
+            if (PL_parser && PL_parser->error_count)
+                clear_special_blocks(name, gv, cv);
+            else
+                process_special_blocks(floor, name, gv, cv);
+        }
     }
 
   done:
@@ -7945,6 +7948,27 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 }
 
 STATIC void
+S_clear_special_blocks(pTHX_ const char *const fullname,
+                       GV *const gv, CV *const cv) {
+    const char *colon;
+    const char *name;
+
+    PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
+
+    colon = strrchr(fullname,':');
+    name = colon ? colon + 1 : fullname;
+
+    if ((*name == 'B' && strEQ(name, "BEGIN"))
+        || (*name == 'E' && strEQ(name, "END"))
+        || (*name == 'U' && strEQ(name, "UNITCHECK"))
+        || (*name == 'C' && strEQ(name, "CHECK"))
+        || (*name == 'I' && strEQ(name, "INIT"))) {
+        GvCV_set(gv, NULL);
+        SvREFCNT_dec_NN(MUTABLE_SV(cv));
+    }
+}
+
+STATIC void
 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                         GV *const gv,
                         CV *const cv)
diff --git a/proto.h b/proto.h
index 6abd867..1e42903 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6113,6 +6113,13 @@ STATIC void      S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flag
 #define PERL_ARGS_ASSERT_BAD_TYPE_PV   \
        assert(t); assert(name); assert(kid)
 
+STATIC void    S_clear_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS  \
+       assert(fullname); assert(gv); assert(cv)
+
 STATIC void    S_cop_free(pTHX_ COP *cop)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_COP_FREE      \
index 0e4ffda..1861623 100644 (file)
@@ -223,11 +223,9 @@ ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
       'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
 }
 
-{ local $TODO = "fixed in next commit";
 # [perl #122107] previously this would return
 #  Subroutine BEGIN redefined at (eval 2) line 2.
 fresh_perl_is(<<'EOS', "", { stderr => 1 },
 use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
 EOS
               "check special blocks are cleared on error");
-}