[shell changes from patch from perl5.003_23 to perl5.003_24]

[p5sagit/p5-mst-13.2.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index b9e3b87..707239f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -242,6 +242,8 @@ PP(pp_eq)
 PP(pp_preinc)
 {
     dSP;
+    if (SvREADONLY(TOPs))
+       croak(no_modify);
     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MAX)
     {
@@ -297,7 +299,19 @@ PP(pp_join)
 PP(pp_pushre)
 {
     dSP;
+#ifdef DEBUGGING
+    /*
+     * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
+     * will be enough to hold an OP*.
+     */
+    SV* sv = sv_newmortal();
+    sv_upgrade(sv, SVt_PVLV);
+    LvTYPE(sv) = '/';
+    Copy(&op, &LvTARGOFF(sv), 1, OP*);
+    XPUSHs(sv);
+#else
     XPUSHs((SV*)op);
+#endif
     RETURN;
 }
 
@@ -598,6 +612,7 @@ PP(pp_aassign)
            magic = SvMAGICAL(ary) != 0;
            
            av_clear(ary);
+           av_extend(ary, lastrelem - relem);
            i = 0;
            while (relem <= lastrelem) {        /* gobble up all the rest */
                sv = NEWSV(28,0);
@@ -1663,12 +1678,6 @@ PP(pp_leavesub)
                /* in case LEAVE wipes old return values */
     }
 
-    if (cx->blk_sub.hasargs) {         /* You don't exist; go away. */
-       AV* av = cx->blk_sub.argarray;
-
-       av_clear(av);
-       AvREAL_off(av);
-    }
     curpm = newpm;     /* Don't pop $1 et al till now */
 
     LEAVE;
@@ -1685,7 +1694,6 @@ PP(pp_entersub)
     register CONTEXT *cx;
     I32 gimme;
     bool hasargs = (op->op_flags & OPf_STACKED) != 0;
-    bool may_clone = TRUE;
 
     if (!sv)
        DIE("Not a CODE reference");
@@ -1705,17 +1713,14 @@ PP(pp_entersub)
            break;
        }
        cv = (CV*)SvRV(sv);
-       if (SvTYPE(cv) == SVt_PVCV) {
-           may_clone = FALSE;
+       if (SvTYPE(cv) == SVt_PVCV)
            break;
-       }
        /* FALL THROUGH */
     case SVt_PVHV:
     case SVt_PVAV:
        DIE("Not a CODE reference");
     case SVt_PVCV:
        cv = (CV*)sv;
-       may_clone = FALSE;
        break;
     case SVt_PVGV:
        if (!(cv = GvCVu((GV*)sv)))
@@ -1723,9 +1728,6 @@ PP(pp_entersub)
        break;
     }
 
-    if (may_clone && cv && CvCLONE(cv))
-       cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-
     ENTER;
     SAVETMPS;
 
@@ -1734,30 +1736,30 @@ PP(pp_entersub)
        DIE("Not a CODE reference");
 
     if (!CvROOT(cv) && !CvXSUB(cv)) {
-       if (gv = CvGV(cv)) {
-           SV *tmpstr;
-           GV *ngv;
-           if (cv != GvCV(gv)) {       /* autoloaded stub? */
-               cv = GvCV(gv);
-               goto retry;
-           }
-           tmpstr = sv_newmortal();
-           gv_efullname3(tmpstr, gv, Nullch);
-           ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
-           if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
-               gv = ngv;
-               sv_setsv(GvSV(CvGV(cv)), tmpstr);       /* Set CV's $AUTOLOAD */
-               SvTAINTED_off(GvSV(CvGV(cv)));
-               goto retry;
-           }
-           else
-               DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
+       GV* autogv;
+       SV* subname;
+
+       /* anonymous or undef'd function leaves us no recourse */
+       if (CvANON(cv) || !(gv = CvGV(cv)))
+           DIE("Undefined subroutine called");
+       /* autoloaded stub? */
+       if (cv != GvCV(gv)) {
+           cv = GvCV(gv);
+           goto retry;
+       }
+       /* should call AUTOLOAD now? */
+       if ((autogv = gv_autoload(GvESTASH(gv), GvNAME(gv), GvNAMELEN(gv)))) {
+           cv = GvCV(autogv);
+           goto retry;
        }
-       DIE("Undefined subroutine called");
+       /* sorry */
+       subname = sv_newmortal();
+       gv_efullname3(subname, gv, Nullch);
+       DIE("Undefined subroutine &%s called", SvPVX(subname));
     }
 
     gimme = GIMME;
-    if ((op->op_private & OPpENTERSUB_DB) && !CvNODEBUG(cv)) {
+    if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) {
        SV *oldsv = sv;
        sv = GvSV(DBsub);
        save_item(sv);
@@ -1851,8 +1853,8 @@ PP(pp_entersub)
            (void)SvREFCNT_inc(cv);
        else {  /* save temporaries on recursion? */
            if (CvDEPTH(cv) == 100 && dowarn 
-               && !(perldb && cv == GvCV(DBsub)))
-               warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
+                 && !(perldb && cv == GvCV(DBsub)))
+               sub_crush_depth(cv);
            if (CvDEPTH(cv) > AvFILL(padlist)) {
                AV *av;
                AV *newpad = newAV();
@@ -1932,6 +1934,19 @@ PP(pp_entersub)
     }
 }
 
+void
+sub_crush_depth(cv)
+CV* cv;
+{
+    if (CvANON(cv))
+       warn("Deep recursion on anonymous subroutine");
+    else {
+       SV* tmpstr = sv_newmortal();
+       gv_efullname3(tmpstr, CvGV(cv), Nullch);
+       warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+    }
+}
+
 PP(pp_aelem)
 {
     dSP;