X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=904ee9f8781a62c985157273eb408c8454262bea;hb=cc50ac46d6f5968c34044ce7c501b06af15fc51a;hp=c5df5e0db6d348291b8e9893a0bbec95840946f6;hpb=cf2093f6405d08be483e037b6052608c46952a75;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index c5df5e0..904ee9f 100644
--- 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)
     {
@@ -588,11 +601,12 @@ PP(pp_rv2hv)
 	dTARGET;
 	if (SvTYPE(hv) == SVt_PVAV)
 	    hv = avhv_keys((AV*)hv);
-	if (HvFILL(hv))
 #ifdef IV_IS_QUAD
+	if (HvFILL(hv))
             Perl_sv_setpvf(aTHX_ TARG, "%" PERL_PRId64 "/%" PERL_PRId64,
                       (Quad_t)HvFILL(hv), (Quad_t)HvMAX(hv) + 1);
 #else
+	if (HvFILL(hv))
             Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
                       (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 #endif
@@ -766,8 +780,8 @@ PP(pp_aassign)
 	    }
 #  endif /* HAS_SETREUID */
 #endif /* HAS_SETRESUID */
-	    PL_uid = (int)PerlProc_getuid();
-	    PL_euid = (int)PerlProc_geteuid();
+	    PL_uid = PerlProc_getuid();
+	    PL_euid = PerlProc_geteuid();
 	}
 	if (PL_delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
@@ -795,8 +809,8 @@ PP(pp_aassign)
 	    }
 #  endif /* HAS_SETREGID */
 #endif /* HAS_SETRESGID */
-	    PL_gid = (int)PerlProc_getgid();
-	    PL_egid = (int)PerlProc_getegid();
+	    PL_gid = PerlProc_getgid();
+	    PL_egid = PerlProc_getegid();
 	}
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
     }
@@ -1587,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;
     }
 
@@ -1631,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);
@@ -1920,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;
 	}
@@ -1949,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)
 {
@@ -1976,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))
@@ -2109,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))
@@ -2192,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 */
@@ -2372,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);