In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/3969ff3f8e4bff4c0c8d6577220d61d3962a9f56?hp=10380cb3585f27510276b532ec6e5450d1b16391>
- Log -----------------------------------------------------------------
commit 3969ff3f8e4bff4c0c8d6577220d61d3962a9f56
Author: Tony Cook <t...@develop-help.com>
Date: Mon Jul 14 10:40:47 2014 +1000
[perl #122107] ensure that BEGIN blocks with errors don't remain named subs
M embed.fnc
M embed.h
M op.c
M proto.h
M t/op/sub.t
commit 2806bfd899e5e4e1c29077c080a6a9ebc3512295
Author: Tony Cook <t...@develop-help.com>
Date: Thu Jul 10 11:37:39 2014 +1000
[perl #122107] test that BEGIN blocks with errors don't remain named subs
M t/op/sub.t
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 2 ++
embed.h | 1 +
op.c | 30 +++++++++++++++++++++++++++---
proto.h | 7 +++++++
t/op/sub.t | 9 ++++++++-
5 files changed, 45 insertions(+), 4 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 90c56ed..b70404d 100644
--- 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
--- a/embed.h
+++ b/embed.h
@@ -1485,6 +1485,7 @@
#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
--- 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
--- 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 \
diff --git a/t/op/sub.t b/t/op/sub.t
index 7df8f49..1861623 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
require './test.pl';
}
-plan( tests => 33 );
+plan( tests => 34 );
sub empty_sub {}
@@ -222,3 +222,10 @@ ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
is $str[1], $str[0],
'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
}
+
+# [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");
--
Perl5 Master Repository
