resync with mainline
[p5sagit/p5-mst-13.2.git] / pp_hot.c
index 78f07a1..904ee9f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -164,8 +164,21 @@ PP(pp_concat)
        s = SvPV_force(TARG, len);
     }
     s = SvPV(right,len);
-    if (SvOK(TARG))
+    if (SvOK(TARG)) {
+#if defined(PERL_Y2KWARN)
+       if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) {
+           STRLEN n;
+           char *s = SvPV(TARG,n);
+           if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+               && (n == 2 || !isDIGIT(s[n-3])))
+           {
+               Perl_warner(aTHX_ WARN_MISC, "Possible Y2K bug: %s",
+                           "about to append an integer to '19'");
+           }
+       }
+#endif
        sv_catpvn(TARG,s,len);
+    }
     else
        sv_setpvn(TARG,s,len);  /* suppress warning */
     SETTARG;
@@ -221,7 +234,7 @@ PP(pp_preinc)
 {
     djSP;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MAX)
     {
@@ -1588,7 +1601,7 @@ PP(pp_iter)
        }
        LvTARG(lv) = SvREFCNT_inc(av);
        LvTARGOFF(lv) = cx->blk_loop.iterix;
-       LvTARGLEN(lv) = (UV) -1;
+       LvTARGLEN(lv) = (STRLEN)UV_MAX;
        sv = (SV*)lv;
     }
 
@@ -1632,7 +1645,7 @@ PP(pp_subst)
     if (SvREADONLY(TARG)
        || (SvTYPE(TARG) > SVt_PVLV
            && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
     s = SvPV(TARG, len);
@@ -1921,13 +1934,16 @@ PP(pp_leavesub)
                    *MARK = SvREFCNT_inc(TOPs);
                    FREETMPS;
                    sv_2mortal(*MARK);
-               } else {
+               }
+               else {
                    FREETMPS;
                    *MARK = sv_mortalcopy(TOPs);
                }
-           } else
+           }
+           else
                *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
-       } else {
+       }
+       else {
            MEXTEND(MARK, 0);
            *MARK = &PL_sv_undef;
        }
@@ -1950,6 +1966,151 @@ PP(pp_leavesub)
     return pop_return();
 }
 
+/* This duplicates the above code because the above code must not
+ * get any slower by more conditions */
+PP(pp_leavesublv)
+{
+    djSP;
+    SV **mark;
+    SV **newsp;
+    PMOP *newpm;
+    I32 gimme;
+    register PERL_CONTEXT *cx;
+    struct block_sub cxsub;
+
+    POPBLOCK(cx,newpm);
+    POPSUB1(cx);       /* Delay POPSUB2 until stack values are safe */
+    TAINT_NOT;
+
+    if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
+       /* We are an argument to a function or grep().
+        * This kind of lvalueness was legal before lvalue
+        * subroutines too, so be backward compatible:
+        * cannot report errors.  */
+
+       /* Scalar context *is* possible, on the LHS of -> only,
+        * as in f()->meth().  But this is not an lvalue. */
+       if (gimme == G_SCALAR)
+           goto temporise;
+       if (gimme == G_ARRAY) {
+           if (!CvLVALUE(cxsub.cv))
+               goto temporise_array;
+           EXTEND_MORTAL(SP - newsp);
+           for (mark = newsp + 1; mark <= SP; mark++) {
+               if (SvTEMP(*mark))
+                   /* empty */ ;
+               else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
+                   *mark = sv_mortalcopy(*mark);
+               else {
+                   /* Can be a localized value subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+       }
+    }
+    else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
+       /* Here we go for robustness, not for speed, so we change all
+        * the refcounts so the caller gets a live guy. Cannot set
+        * TEMP, so sv_2mortal is out of question. */
+       if (!CvLVALUE(cxsub.cv)) {
+           POPSUB2();
+           PL_curpm = newpm;
+           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       }
+       if (gimme == G_SCALAR) {
+           MARK = newsp + 1;
+           EXTEND_MORTAL(1);
+           if (MARK == SP) {
+               if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+                   POPSUB2();
+                   PL_curpm = newpm;
+                   DIE(aTHX_ "Can't return a %s from lvalue subroutine",
+                       SvREADONLY(TOPs) ? "readonly value" : "temporary");
+               }
+               else {                  /* Can be a localized value
+                                        * subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+           else {                      /* Should not happen? */
+               POPSUB2();
+               PL_curpm = newpm;
+               DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
+                   (MARK > SP ? "Empty array" : "Array"));
+           }
+           SP = MARK;
+       }
+       else if (gimme == G_ARRAY) {
+           EXTEND_MORTAL(SP - newsp);
+           for (mark = newsp + 1; mark <= SP; mark++) {
+               if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+                   /* Might be flattened array after $#array =  */
+                   PUTBACK;
+                   POPSUB2();
+                   PL_curpm = newpm;
+                   DIE(aTHX_ "Can't return %s from lvalue subroutine",
+                       (*mark != &PL_sv_undef)
+                       ? (SvREADONLY(TOPs)
+                           ? "a readonly value" : "a temporary")
+                       : "an uninitialized value");
+               }
+               else {
+                   mortalize:
+                   /* Can be a localized value subject to deletion. */
+                   PL_tmps_stack[++PL_tmps_ix] = *mark;
+                   SvREFCNT_inc(*mark);
+               }
+           }
+       }
+    }
+    else {
+       if (gimme == G_SCALAR) {
+         temporise:
+           MARK = newsp + 1;
+           if (MARK <= SP) {
+               if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+                   if (SvTEMP(TOPs)) {
+                       *MARK = SvREFCNT_inc(TOPs);
+                       FREETMPS;
+                       sv_2mortal(*MARK);
+                   }
+                   else {
+                       FREETMPS;
+                       *MARK = sv_mortalcopy(TOPs);
+                   }
+               }
+               else
+                   *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+           }
+           else {
+               MEXTEND(MARK, 0);
+               *MARK = &PL_sv_undef;
+           }
+           SP = MARK;
+       }
+       else if (gimme == G_ARRAY) {
+         temporise_array:
+           for (MARK = newsp + 1; MARK <= SP; MARK++) {
+               if (!SvTEMP(*MARK)) {
+                   *MARK = sv_mortalcopy(*MARK);
+                   TAINT_NOT;  /* Each item is independent */
+               }
+           }
+       }
+    }
+    PUTBACK;
+    
+    POPSUB2();         /* Stack values are safe: release CV and @_ ... */
+    PL_curpm = newpm;  /* ... and pop $1 et al */
+
+    LEAVE;
+    return pop_return();
+}
+
+
 STATIC CV *
 S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
@@ -1977,7 +2138,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv)
        SvUPGRADE(dbsv, SVt_PVIV);
        SvIOK_on(dbsv);
        SAVEIV(SvIVX(dbsv));
-       SvIVX(dbsv) = (IV)cv;           /* Do it the quickest way  */
+       SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
     }
 
     if (CvXSUB(cv))
@@ -2110,7 +2271,7 @@ try_autoload:
                    || !(sv = AvARRAY(av)[0]))
                {
                    MUTEX_UNLOCK(CvMUTEXP(cv));
-                   Perl_croak(aTHX_ "no argument for locked method call");
+                   DIE(aTHX_ "no argument for locked method call");
                }
            }
            if (SvROK(sv))
@@ -2193,7 +2354,8 @@ try_autoload:
                            "entersub: %p grabbing %p:%s in stash %s\n",
                            thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
                                HvNAME(CvSTASH(cv)) : "(none)"));
-           } else {
+           }
+           else {
                /* Make a new clone. */
                CV *clonecv;
                SvREFCNT_inc(cv); /* don't let it vanish from under us */
@@ -2373,10 +2535,7 @@ try_autoload:
                                  "%p entersub preparing @_\n", thr));
 #endif
            av = (AV*)PL_curpad[0];
-           if (AvREAL(av)) {
-               av_clear(av);
-               AvREAL_off(av);
-           }
+           assert(!AvREAL(av));
 #ifndef USE_THREADS
            cx->blk_sub.savearray = GvAV(PL_defgv);
            GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);