Eliminate the vestigial comment "magical thingies" from intrpvar.h

[perl5.git] / op.c

diff --git a/op.c b/op.c
index ee5d7ee..1406ffc 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2450,31 +2450,20 @@ S_dup_attrlist(pTHX_ OP *o)
 }
 
 STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
 {
     dVAR;
-    SV *stashsv;
+    SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
 
     PERL_ARGS_ASSERT_APPLY_ATTRS;
 
     /* fake up C<use attributes $pkg,$rv,@attrs> */
     ENTER;             /* need to protect against side-effects of 'use' */
-    stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
 
 #define ATTRSMODULE "attributes"
 #define ATTRSMODULE_PM "attributes.pm"
 
-    if (for_my) {
-       /* Don't force the C<use> if we don't need it. */
-       SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
-       if (svp && *svp != &PL_sv_undef)
-           NOOP;       /* already in %INC */
-       else
-           Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
-                            newSVpvs(ATTRSMODULE), NULL);
-    }
-    else {
-       Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
                         newSVpvs(ATTRSMODULE),
                         NULL,
                         op_prepend_elem(OP_LIST,
@@ -2483,7 +2472,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
                                                   newSVOP(OP_CONST, 0,
                                                           newRV(target)),
                                                   dup_attrlist(attrs))));
-    }
     LEAVE;
 }
 
@@ -2492,7 +2480,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
 {
     dVAR;
     OP *pack, *imop, *arg;
-    SV *meth, *stashsv;
+    SV *meth, *stashsv, **svp;
 
     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
 
@@ -2504,7 +2492,15 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
           target->op_type == OP_PADAV);
 
     /* Ensure that attributes.pm is loaded. */
-    apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
+    ENTER;             /* need to protect against side-effects of 'use' */
+    /* Don't force the C<use> if we don't need it. */
+    svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
+    if (svp && *svp != &PL_sv_undef)
+       NOOP;   /* already in %INC */
+    else
+       Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+                              newSVpvs(ATTRSMODULE), NULL);
+    LEAVE;
 
     /* Need package name for method call. */
     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
@@ -2624,7 +2620,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
                        (type == OP_RV2SV ? GvSV(gv) :
                         type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
                         type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
-                       attrs, FALSE);
+                       attrs);
        }
        o->op_private |= OPpOUR_INTRO;
        return o;
@@ -3055,6 +3051,17 @@ Perl_newPROG(pTHX_ OP *o)
                maybe other things) also take this path, because they set up
                PL_main_start and PL_main_root directly, without generating an
                optree.
+
+               If the parsing the main program aborts (due to parse errors,
+               or due to BEGIN or similar calling exit), then newPROG()
+               isn't even called, and hence this code path and its cleanups
+               are skipped. This shouldn't make a make a difference:
+               * a non-zero return from perl_parse is a failure, and
+                 perl_destruct() should be called immediately.
+               * however, if exit(0) is called during the parse, then
+                 perl_parse() returns 0, and perl_run() is called. As
+                 PL_main_start will be NULL, perl_run() will return
+                 promptly, and the exit code will remain 0.
             */
 
            PL_comppad_name = 0;
@@ -6934,7 +6941,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     PADNAME *name;
     PADOFFSET pax = o->op_targ;
     CV *outcv = CvOUTSIDE(PL_compcv);
+    CV *clonee = NULL;
     HEK *hek = NULL;
+    bool reusable = FALSE;
 
     PERL_ARGS_ASSERT_NEWMYSUB;
 
@@ -6954,7 +6963,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        goto redo;
     }
     svspot =
-       &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[1])[pax];
+       &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+                       [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
     spot = (CV **)svspot;
 
     if (proto) {
@@ -6977,7 +6987,11 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        goto done;
     }
 
-    if (PadnameIsSTATE(name))
+    if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+       cv = *spot;
+       svspot = (SV **)(spot = &clonee);
+    }
+    else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
        cv = *spot;
     else {
        MAGIC *mg;
@@ -7070,6 +7084,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                cv = NULL;
            }
        }
+       else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+           cv = NULL;
+           reusable = TRUE;
+       }
     }
     if (const_sv) {
        SvREFCNT_inc_simple_void_NN(const_sv);
@@ -7093,7 +7111,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        op_free(block);
        SvREFCNT_dec(compcv);
        PL_compcv = NULL;
-       goto done;
+       goto clone;
     }
     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
        determine whether this sub definition is in the same scope as its
@@ -7221,7 +7239,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
   attrs:
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
-       apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs, FALSE);
+       apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
     }
 
     if (block) {
@@ -7257,6 +7275,28 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
+  clone:
+    if (clonee) {
+       assert(CvDEPTH(outcv));
+       spot = (CV **)
+           &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
+       if (reusable) cv_clone_into(clonee, *spot);
+       else *spot = cv_clone(clonee);
+       SvREFCNT_dec(clonee);
+       cv = *spot;
+       SvPADMY_on(cv);
+    }
+    if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
+       PADOFFSET depth = CvDEPTH(outcv);
+       while (--depth) {
+           SV *oldcv;
+           svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
+           oldcv = *svspot;
+           *svspot = SvREFCNT_inc_simple_NN(cv);
+           SvREFCNT_dec(oldcv);
+       }
+    }
+
   done:
     if (PL_parser)
        PL_parser->copline = NOLINE;
@@ -7527,13 +7567,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        cv = PL_compcv;
        if (name) {
            GvCV_set(gv, cv);
-           if (PL_madskills) {
-               if (strEQ(name, "import")) {
-                   PL_formfeed = MUTABLE_SV(cv);
-                   /* diag_listed_as: SKIPME */
-                   Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
-               }
-           }
            GvCVGEN(gv) = 0;
            if (HvENAME_HEK(GvSTASH(gv)))
                /* sub Foo::bar { (shift)+1 } */
@@ -7603,7 +7636,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
        HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
-       apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+       apply_attrs(stash, MUTABLE_SV(cv), attrs);
     }
 
     if (block && has_name) {