Subroutine BEGIN redefined - but no BEGIN at all #13926
Comments
From Harald.Joerg@arcor.deThis is a bug report for perl from Harald.Joerg@arcor.de, It happened in a real-world application after upgrade to Perl 5.18.2, Apparently there's a remote side effect when a module fails to The error message "Subroutine BEGIN redefined" is just too misleading Test script (works with perl -x): ###################################################################### say "* This is Perl version $^V"; $SIG{'__WARN__'} = sub { die @_ }; # The application is pretty strict Output under Perl V5.18.2: Output under Perl V5.10.1: Some details: The application falls over this when loading a list of "plugin" The compilation issue is "only" a warning, so without promoting The problem vanishes if either of the 'use' statements is replaced by The problem vanishes for many other "syntax errors" in the first eval Here's perlbug -d output, to be summarized as "vanilla Perl as it Flags: Site configuration information for perl 5.18.2: Configured by Debian Project at Thu Mar 27 18:28:21 UTC 2014. Summary of my perl5 (revision 5 version 18 subversion 2) configuration: Locally applied patches: @INC for perl 5.18.2: Environment for perl 5.18.2: Flags: Site configuration information for perl 5.18.2: Configured by Debian Project at Thu Mar 27 18:28:21 UTC 2014. Summary of my perl5 (revision 5 version 18 subversion 2) configuration: Locally applied patches: @INC for perl 5.18.2: Environment for perl 5.18.2: |
From @iabynOn Sun, Jun 15, 2014 at 07:10:12PM -0700, Harald Joerg wrote:
A bisect shows that the spurious warning appeared with the commit shown The following shows the behaviour of perl pre- and-post- that commit: $ p -e'use strict; use File::{Spec}' $ p -e'use strict; use File::{Spec}' commit 52d0e95 [perl #114222] Make ‘use’ parse arguments in term context -- |
|
The RT System itself - Status changed from 'new' to 'open' |
From @tonycozOn Mon Jun 16 04:31:19 2014, davem wrote:
The attached patches test for and I think fix the bug. Tony |
From @tonycoz0001-perl-122107-test-that-BEGIN-blocks-with-errors-don-t.patchFrom b31436aff4c9260e08d1858f662d2ed752977c42 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 10 Jul 2014 11:37:39 +1000
Subject: [perl #122107] test that BEGIN blocks with errors don't remain named
subs
---
t/op/sub.t | 11 ++++++++++-
1 file changed, 10 insertions(+), 1 deletion(-)
diff --git a/t/op/sub.t b/t/op/sub.t
index 7df8f49..0e4ffda 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,12 @@ 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';
}
+
+{ 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");
+}
--
1.7.10.4
|
From @tonycoz0002-perl-122107-ensure-that-BEGIN-blocks-with-errors-don.patchFrom 85b807102b92d533e72ddef04cdc3278ef093564 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 10 Jul 2014 11:48:07 +1000
Subject: [perl #122107] ensure that BEGIN blocks with errors don't remain
named subs
---
embed.fnc | 2 ++
embed.h | 1 +
op.c | 27 ++++++++++++++++++++++++---
proto.h | 7 +++++++
t/op/sub.t | 2 --
5 files changed, 34 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b3e24d6..2027938 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1930,6 +1930,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 37c5b20..5195802 100644
--- a/embed.h
+++ b/embed.h
@@ -1482,6 +1482,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 1ee59a3..bacaf72 100644
--- a/op.c
+++ b/op.c
@@ -7335,7 +7335,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);
@@ -7595,8 +7594,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:
@@ -7611,6 +7614,24 @@ 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 *const colon = strrchr(fullname,':');
+ const char *const name = colon ? colon + 1 : fullname;
+
+ PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
+
+ 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 46c41bc..fc8cda2 100644
--- a/proto.h
+++ b/proto.h
@@ -6098,6 +6098,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 0e4ffda..1861623 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -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");
-}
--
1.7.10.4
|
From @tonycozOn Wed Jul 09 19:01:13 2014, tonyc wrote:
Fix a problem in the fix patch (it used values before the assertion for those values.) Tony |
From @tonycoz0002-perl-122107-ensure-that-BEGIN-blocks-with-errors-don.patchFrom 9a337c06ccdaa8e5217ee60a66c3a6835a749075 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 14 Jul 2014 10:40:47 +1000
Subject: [perl #122107] ensure that BEGIN blocks with errors don't remain
named subs
---
embed.fnc | 2 ++
embed.h | 1 +
op.c | 30 +++++++++++++++++++++++++++---
proto.h | 7 +++++++
t/op/sub.t | 2 --
5 files changed, 37 insertions(+), 5 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index b3e24d6..2027938 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1930,6 +1930,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 37c5b20..5195802 100644
--- a/embed.h
+++ b/embed.h
@@ -1482,6 +1482,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 1ee59a3..22dc50a 100644
--- a/op.c
+++ b/op.c
@@ -7335,7 +7335,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);
@@ -7595,8 +7594,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:
@@ -7611,6 +7614,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 46c41bc..fc8cda2 100644
--- a/proto.h
+++ b/proto.h
@@ -6098,6 +6098,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 0e4ffda..1861623 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -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");
-}
--
1.7.10.4
|
From @cpansproutOn Mon Jun 16 04:31:19 2014, davem wrote:
I actually came across this bug myself a while ago (due to a typo), but never got around to reporting it: $ perl5.10 -we 'use strict; BEGIN {foo} tr/\x{100}//' A bisect points to: 7678c48 is the first bad commit Re: Error: Unknown error -- Father Chrysostomos |
From @cpansproutOn Sun Jul 13 17:44:09 2014, tonyc wrote:
Your patch looks good to me. Is there any reason you have not applied it yet? -- Father Chrysostomos |
From @tonycozOn Sun Aug 10 12:39:50 2014, sprout wrote:
Mostly, I forgot. Applied as 2806bfd and 3969ff3. Tony |
|
@tonycoz - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#122107 (status was 'resolved')
Searchable as RT122107$
The text was updated successfully, but these errors were encountered: