[perl #113712] Don’t create stubs after errors

perl5.002beta3 (c07a80fdfe) stopped bodies of subrou-
tines from being defined after compilation errors, as in
eval "@a =~ s///; sub { die }".

But, instead of making the sub declaration not happen at all, it ended
up leaving a stub.

For a full sub declaration (body and all) to create a stub just
seems wrong.

Likewise, it would be weird if a stub declaration
after a compilation error created a stub, because then
eval "@a =~ s///; sub foo; sub bar { }" would create foo but not bar.

Similarly, a compilation error will cause ‘sub foo {}’ no suppress
‘used once’ warnings; but a lexing error won’t.

This commit fixes all this, making things consistent:  If there is a
compilation, parsing or lexing error, any kind of sub declaration that
follows is ignored.

diff --git a/op.c b/op.c
index 69bd2a4..5756eeb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6719,13 +6719,15 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     U32 ps_utf8 = 0;
     register CV *cv = NULL;
     SV *const_sv;
+    const bool ec = PL_parser && PL_parser->error_count;
     /* If the subroutine has no body, no attributes, and no builtin attributes
        then it's just a sub declaration, and we may be able to get away with
        storing with a placeholder scalar in the symbol table, rather than a
        full GV and CV.  If anything is present then it will take a full CV to
        store it.  */
     const I32 gv_fetch_flags
-       = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+       = ec ? GV_NOADD_NOINIT :
+        (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
           || PL_madskills)
        ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     STRLEN namlen = 0;
@@ -6774,6 +6776,27 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            SAVEFREEOP(attrs);
     }
 
+    if (ec) {
+       op_free(block);
+       if (name && block) {
+           const char *s = strrchr(name, ':');
+           s = s ? s+1 : name;
+           if (strEQ(s, "BEGIN")) {
+               const char not_safe[] =
+                   "BEGIN not safe after errors--compilation aborted";
+               if (PL_in_eval & EVAL_KEEPERR)
+                   Perl_croak(aTHX_ not_safe);
+               else {
+                   /* force display of errors found but not reported */
+                   sv_catpv(ERRSV, not_safe);
+                   Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+               }
+           }
+       }
+       cv = PL_compcv;
+       goto done;
+    }
+
     if (SvTYPE(gv) != SVt_PVGV) {      /* Maybe prototype now, and had at
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
@@ -6949,25 +6972,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
     }
 
-    if (PL_parser && PL_parser->error_count) {
-       op_free(block);
-       block = NULL;
-       if (name) {
-           const char *s = strrchr(name, ':');
-           s = s ? s+1 : name;
-           if (strEQ(s, "BEGIN")) {
-               const char not_safe[] =
-                   "BEGIN not safe after errors--compilation aborted";
-               if (PL_in_eval & EVAL_KEEPERR)
-                   Perl_croak(aTHX_ not_safe);
-               else {
-                   /* force display of errors found but not reported */
-                   sv_catpv(ERRSV, not_safe);
-                   Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
-               }
-           }
-       }
-    }
  install_block:
     if (!block)
        goto attrs;

diff --git a/t/comp/parser.t b/t/comp/parser.t
index 97b6fbd..c0fc246 100644 (file)
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -3,7 +3,7 @@
 # Checks if the parser behaves correctly in edge cases
 # (including weird syntax errors)
 
-print "1..125\n";
+print "1..135\n";
 
 sub failed {
     my ($got, $expected, $name) = @_;
@@ -362,6 +362,28 @@ is($@, "", "multiline whitespace inside substitute expression");
 
 # Add new tests HERE:
 
+eval '@A =~ s/a/b/; # compilation error
+      sub tahi {}
+      sub rua;
+      sub toru ($);
+      sub wha :lvalue;
+      sub rima ($%&*$&*\$%\*&$%*&) :method;
+      sub ono :lvalue { die }
+      sub whitu (_) { die }
+      sub waru ($;) :method { die }
+      sub iwa { die }
+      BEGIN { }';
+is $::{tahi}, undef, 'empty sub decl ignored after compilation error';
+is $::{rua}, undef, 'stub decl ignored after compilation error';
+is $::{toru}, undef, 'stub+proto decl ignored after compilation error';
+is $::{wha}, undef, 'stub+attr decl ignored after compilation error';
+is $::{rima}, undef, 'stub+proto+attr ignored after compilation error';
+is $::{ono}, undef, 'sub decl with attr ignored after compilation error';
+is $::{whitu}, undef, 'sub decl w proto ignored after compilation error';
+is $::{waru}, undef, 'sub w attr+proto ignored after compilation error';
+is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error';
+is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error';
+
 # bug #74022: Loop on characters in \p{OtherIDContinue}
 # This test hangs if it fails.
 eval chr 0x387;

diff --git a/t/lib/warnings/perl b/t/lib/warnings/perl
index f619cc6..a00ed62 100644 (file)
--- a/t/lib/warnings/perl
+++ b/t/lib/warnings/perl
@@ -223,3 +223,9 @@ BEGIN { $^W = 1 }
 $ŷ = 3 ;
 EXPECT
 Name "ɕლȃṢȿ::ŷ" used only once: possible typo at - line 9.
+########
+
+use warnings 'once';
+$foo++; BEGIN { eval q|@a =~ s///; sub foo;| }
+EXPECT
+Name "main::foo" used only once: possible typo at - line 3.