diff options
| -rw-r--r-- | op.c | 58 | ||||
| -rw-r--r-- | pod/perldiag.pod | 7 | ||||
| -rw-r--r-- | t/op/blocks.t | 29 |
3 files changed, 74 insertions, 20 deletions
@@ -10231,6 +10231,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, bool has_name; bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); bool evanescent = FALSE; + bool isBEGIN = FALSE; OP *start = NULL; #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; @@ -10283,6 +10284,36 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } } + if (o) + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); + + /* we need this in two places later on, so set it up here */ + if (name && block) { + const char *s = (char *) my_memrchr(name, ':', namlen); + s = s ? s+1 : name; + isBEGIN = strEQ(s,"BEGIN"); + } + + if (isBEGIN) { + /* Make sure that we do not have any prototypes or + * attributes associated with this BEGIN block, as the block + * is already done and dusted, and we will assert or worse + * if we try to attach the prototype to the now essentially + * nonexistent sub. */ + if (proto) + /* diag_listed_as: %s on BEGIN block ignored */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored"); + if (attrs) + /* diag_listed_as: %s on BEGIN block ignored */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored"); + proto = NULL; + attrs = NULL; + } + if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len); @@ -10291,13 +10322,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else ps = NULL; - if (o) - SAVEFREEOP(o); - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); - if (ec) { op_free(block); @@ -10307,18 +10331,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv = PL_compcv; PL_compcv = 0; - if (name && block) { - const char *s = (char *) my_memrchr(name, ':', namlen); - s = s ? s+1 : name; - if (strEQ(s, "BEGIN")) { - if (PL_in_eval & EVAL_KEEPERR) - Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); - else { - SV * const errsv = ERRSV; - /* force display of errors found but not reported */ - sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); - Perl_croak_nocontext("%" SVf, SVfARG(errsv)); - } + if (isBEGIN) { + if (PL_in_eval & EVAL_KEEPERR) + Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); + else { + SV * const errsv = ERRSV; + /* force display of errors found but not reported */ + sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); } } goto done; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 60df382646..e513bb0b8c 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -5249,6 +5249,13 @@ the sub name and via the prototype attribute. The prototype in parentheses is useless, since it will be replaced by the prototype from the attribute before it's ever used. +=item %s on BEGIN block ignored + +(W syntax) C<BEGIN> blocks are executed immediately after they are parsed +and then thrown away. Any prototypes or attributes are therefore +meaningless and are ignored. You should remove them from the C<BEGIN> block. +Note this also means you cannot create a constant called C<BEGIN>. + =item Quantifier follows nothing in regex; marked by S<<-- HERE> in m/%s/ (F) You started a regular expression with a quantifier. Backslash it if diff --git a/t/op/blocks.t b/t/op/blocks.t index 18f0596226..33401bdaf6 100644 --- a/t/op/blocks.t +++ b/t/op/blocks.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 23; +plan tests => 26; my @expect = qw( b1 @@ -253,6 +253,33 @@ fresh_perl_like( "INIT{die} should exit" ); +fresh_perl_is( + "BEGIN{} BEGIN(){1} print 'done'", + "Prototype on BEGIN block ignored at - line 1.\ndone", + {}, + "Prototypes on BEGIN blocks should warn" +); + +SKIP: { + skip "Test requires full perl, this is miniperl", 1 + if is_miniperl; + + fresh_perl_is( + "use attributes; BEGIN{} sub BEGIN :blerg {1} print 'done'", + "Attribute on BEGIN block ignored at - line 1.\ndone", + {}, + "Attributes on BEGIN blocks should warn" + ); +} + +fresh_perl_is( + 'BEGIN() {10} foreach my $p (sort {lc($a) cmp lc($b)} keys %v)', + "Prototype on BEGIN block ignored at - line 1.\n" + . "syntax error at - line 1, at EOF\n" + . "Execution of - aborted due to compilation errors.", + {}, + "Prototype on BEGIN blocks should warn" +); TODO: { local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late'; |