Skip Menu |
Report information
Id: 122107
Status: resolved
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: Harald.Joerg [at] arcor.de
Cc:
AdminCc:

Operating System: (no value)
PatchStatus: (no value)
Severity: low
Type: unknown
Perl Version: (no value)
Fixed In: (no value)



To: perlbug [...] perl.org
Subject: Subroutine BEGIN redefined - but no BEGIN at all
Date: Mon, 16 Jun 2014 04:09:44 +0200
From: Harald.Joerg [...] arcor.de (Harald Jörg)
Download (untitled) / with headers
text/plain 19.1k

Message body is not shown because it is too large.

Subject: Re: [perl #122107] Subroutine BEGIN redefined - but no BEGIN at all
To: perl5-porters [...] perl.org
From: Dave Mitchell <davem [...] iabyn.com>
Date: Mon, 16 Jun 2014 12:30:52 +0100
Download (untitled) / with headers
text/plain 1.9k
On Sun, Jun 15, 2014 at 07:10:12PM -0700, Harald Joerg wrote: Show quoted text
> Output under Perl V5.18.2:
... Show quoted text
> Bareword "Spec" not allowed while "strict subs" in use at (eval 1) line 1. > * Now we load a perfectly good module under eval: > Subroutine BEGIN redefined at (eval 2) line 2. > > Output under Perl V5.10.1:
... Show quoted text
> syntax error at (eval 1) line 1, near "use File::{" > * Now we load a perfectly good module under eval:
A bisect shows that the spurious warning appeared with the commit shown below, although I suspect that just it changed the behaviour of the error handling in the 'bad' eval, that triggered a pre-existing bug. The following shows the behaviour of perl pre- and-post- that commit: $ p -e'use strict; use File::{Spec}' syntax error at -e line 1, near "use File::{" $ p -e'use strict; use File::{Spec}' Bareword "Spec" not allowed while "strict subs" in use at -e line 1. commit 52d0e95bfa64548328a8cb945b92a6ff4892a5ad Author: Father Chrysostomos <sprout@cpan.org> AuthorDate: Fri Aug 3 18:35:26 2012 -0700 Commit: Father Chrysostomos <sprout@cpan.org> CommitDate: Fri Aug 3 19:40:30 2012 -0700 [perl #114222] Make ‘use’ parse arguments in term context (lexing context, that is) use constant { () } was a syntax error, because the lexer was guessing when { should be a statement or hash. It should not be doing that where a term is expected. It was actually getting itself confused, and trying to parse the argument list as a statement. Setting PL_expect after force_next is ineffectual, as force_next records the current value of PL_expect, arranging to have it restored. OPERATOR(USE) was setting PL_expect, but too late. So no we set PL_expect explicitly in S_tokenize_use, before any forced tokens, and use TOKEN(USE), which does not set PL_expect (as setting it there has no effect). -- It's not that I'm afraid to die, I just don't want to be there when it happens. -- Woody Allen
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 606b
On Mon Jun 16 04:31:19 2014, davem wrote: Show quoted text
> On Sun, Jun 15, 2014 at 07:10:12PM -0700, Harald Joerg wrote:
> > Output under Perl V5.18.2:
> ...
> > Bareword "Spec" not allowed while "strict subs" in use at (eval 1) line 1. > > * Now we load a perfectly good module under eval: > > Subroutine BEGIN redefined at (eval 2) line 2.
> > A bisect shows that the spurious warning appeared with the commit shown > below, although I suspect that just it changed the behaviour of the error > handling in the 'bad' eval, that triggered a pre-existing bug.
The attached patches test for and I think fix the bug. Tony
Subject: 0001-perl-122107-test-that-BEGIN-blocks-with-errors-don-t.patch
From 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
Subject: 0002-perl-122107-ensure-that-BEGIN-blocks-with-errors-don.patch
From 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 194b
On Wed Jul 09 19:01:13 2014, tonyc wrote: Show quoted text
> The attached patches test for and I think fix the bug.
Fix a problem in the fix patch (it used values before the assertion for those values.) Tony
Subject: 0002-perl-122107-ensure-that-BEGIN-blocks-with-errors-don.patch
From 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.3k
On Mon Jun 16 04:31:19 2014, davem wrote: Show quoted text
> On Sun, Jun 15, 2014 at 07:10:12PM -0700, Harald Joerg wrote:
> > Output under Perl V5.18.2:
> ...
> > Bareword "Spec" not allowed while "strict subs" in use at (eval 1) line 1. > > * Now we load a perfectly good module under eval: > > Subroutine BEGIN redefined at (eval 2) line 2. > > > > Output under Perl V5.10.1:
> ...
> > syntax error at (eval 1) line 1, near "use File::{" > > * Now we load a perfectly good module under eval:
> > A bisect shows that the spurious warning appeared with the commit shown > below, although I suspect that just it changed the behaviour of the error > handling in the 'bad' eval, that triggered a pre-existing bug.
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}//' Subroutine BEGIN redefined at -e line 1. Bareword "foo" not allowed while "strict subs" in use at -e line 1. BEGIN not safe after errors--compilation aborted at -e line 1. A bisect points to: 7678c486bb9005aaaba9a0134efb395936e5a9f7 is the first bad commit commit 7678c486bb9005aaaba9a0134efb395936e5a9f7 Author: Adrian M. Enache <enache@rdslink.ro> Date: Tue Apr 8 10:12:13 2003 +0300 Re: Error: Unknown error Message-ID: <20030408041213.GA13553@ratsnest.hole> p4raw-id: //depot/perl@19170 -- Father Chrysostomos
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 355b
On Sun Jul 13 17:44:09 2014, tonyc wrote: Show quoted text
> On Wed Jul 09 19:01:13 2014, tonyc wrote:
> > The attached patches test for and I think fix the bug.
> > Fix a problem in the fix patch (it used values before the assertion > for those values.) > > Tony
Your patch looks good to me. Is there any reason you have not applied it yet? -- Father Chrysostomos
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 515b
On Sun Aug 10 12:39:50 2014, sprout wrote: Show quoted text
> On Sun Jul 13 17:44:09 2014, tonyc wrote:
> > On Wed Jul 09 19:01:13 2014, tonyc wrote:
> > > The attached patches test for and I think fix the bug.
> > > > Fix a problem in the fix patch (it used values before the assertion > > for those values.) > > > > Tony
> > Your patch looks good to me. Is there any reason you have not applied > it yet?
Mostly, I forgot. Applied as 2806bfd899e5e4e1c29077c080a6a9ebc3512295 and 3969ff3f8e4bff4c0c8d6577220d61d3962a9f56. Tony


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org