X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6ad3d225cec2692b410002582f5558652eea32c8..f9277f475182e73cbf77386678e16ed5037ab2bb:/pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index 77e104e..9fbd176 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -65,7 +65,7 @@ PP(pp_nextstate)
 PP(pp_gvsv)
 {
     djSP;
-    EXTEND(sp,1);
+    EXTEND(SP,1);
     if (op->op_private & OPpLVAL_INTRO)
 	PUSHs(save_scalar(cGVOP->op_gv));
     else
@@ -183,8 +183,11 @@ PP(pp_padsv)
     if (op->op_flags & OPf_MOD) {
 	if (op->op_private & OPpLVAL_INTRO)
 	    SAVECLEARSV(curpad[op->op_targ]);
-        else if (op->op_private & OPpDEREF)
+        else if (op->op_private & OPpDEREF) {
+	    PUTBACK;
 	    vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF);
+	    SPAGAIN;
+	}
     }
     RETURN;
 }
@@ -248,6 +251,7 @@ PP(pp_aelemfast)
     djSP;
     AV *av = GvAV((GV*)cSVOP->op_sv);
     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
+    EXTEND(SP, 1);
     PUSHs(svp ? *svp : &sv_undef);
     RETURN;
 }
@@ -295,8 +299,11 @@ PP(pp_print)
 	gv = (GV*)*++MARK;
     else
 	gv = defoutgv;
-    if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+    if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
 	if (MARK == ORIGMARK) {
+	    /* If using default handle then we need to make space to 
+	     * pass object as 1st arg, so move other args up ...
+	     */
 	    MEXTEND(SP, 1);
 	    ++MARK;
 	    Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
@@ -443,8 +450,17 @@ PP(pp_rv2av)
 
     if (GIMME == G_ARRAY) {
 	I32 maxarg = AvFILL(av) + 1;
-	EXTEND(SP, maxarg);
-	Copy(AvARRAY(av), SP+1, maxarg, SV*);
+	EXTEND(SP, maxarg);          
+	if (SvRMAGICAL(av)) {
+	    U32 i; 
+	    for (i=0; i < maxarg; i++) {
+		SV **svp = av_fetch(av, i, FALSE);
+		SP[i+1] = (svp) ? *svp : &sv_undef;
+	    }
+	} 
+	else {
+	    Copy(AvARRAY(av), SP+1, maxarg, SV*);
+	}
 	SP += maxarg;
     }
     else {
@@ -629,8 +645,15 @@ PP(pp_aassign)
 		    }
 		    TAINT_NOT;
 		}
-		if (relem == lastrelem && dowarn)
-		    warn("Odd number of elements in hash list");
+		if (relem == lastrelem && dowarn) {
+		    if (relem == firstrelem &&
+			SvROK(*relem) &&
+			( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
+			  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
+			warn("Reference found where even-sized list expected");
+		    else
+			warn("Odd number of elements in hash assignment");
+		}
 	    }
 	    break;
 	default:
@@ -678,12 +701,12 @@ PP(pp_aassign)
 	    if (delaymagic & DM_UID) {
 		if (uid != euid)
 		    DIE("No setreuid available");
-		(void)setuid(uid);
+		(void)PerlProc_setuid(uid);
 	    }
 #  endif /* HAS_SETREUID */
 #endif /* HAS_SETRESUID */
-	    uid = (int)getuid();
-	    euid = (int)geteuid();
+	    uid = (int)PerlProc_getuid();
+	    euid = (int)PerlProc_geteuid();
 	}
 	if (delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
@@ -707,12 +730,12 @@ PP(pp_aassign)
 	    if (delaymagic & DM_GID) {
 		if (gid != egid)
 		    DIE("No setregid available");
-		(void)setgid(gid);
+		(void)PerlProc_setgid(gid);
 	    }
 #  endif /* HAS_SETREGID */
 #endif /* HAS_SETRESGID */
-	    gid = (int)getgid();
-	    egid = (int)getegid();
+	    gid = (int)PerlProc_getgid();
+	    egid = (int)PerlProc_getegid();
 	}
 	tainting |= (uid && (euid != uid || egid != gid));
     }
@@ -769,7 +792,7 @@ PP(pp_match)
 	DIE("panic: do_match");
     TAINT_NOT;
 
-    if (pm->op_pmflags & PMf_USED) {
+    if (pm->op_pmdynflags & PMdf_USED) {
       failure:
 	if (gimme == G_ARRAY)
 	    RETURN;
@@ -865,7 +888,7 @@ play_it_again:
     {
 	curpm = pm;
 	if (pm->op_pmflags & PMf_ONCE)
-	    pm->op_pmflags |= PMf_USED;
+	    pm->op_pmdynflags |= PMdf_USED;
 	goto gotcha;
     }
     else
@@ -930,7 +953,7 @@ yup:					/* Confirmed by check_substr */
     ++BmUSEFUL(rx->check_substr);
     curpm = pm;
     if (pm->op_pmflags & PMf_ONCE)
-	pm->op_pmflags |= PMf_USED;
+	pm->op_pmdynflags |= PMdf_USED;
     Safefree(rx->subbase);
     rx->subbase = Nullch;
     if (global) {
@@ -983,7 +1006,7 @@ do_readline(void)
     I32 gimme = GIMME_V;
     MAGIC *mg;
 
-    if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) {
+    if (SvRMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) {
 	PUSHMARK(SP);
 	XPUSHs(mg->mg_obj);
 	PUTBACK;
@@ -1062,7 +1085,10 @@ do_readline(void)
 		       }
 		    }
 		    if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
-		        ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
+		        Stat_t st;
+		        if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
+		          ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
+		        else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
 		        if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
 		        while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
 		                                    &dfltdsc,NULL,NULL,NULL))&1)) {
@@ -1209,7 +1235,7 @@ do_readline(void)
 		if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
 		    strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
 			break;
-	    if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
+	    if (*tmps && PerlLIO_stat(SvPVX(sv), &statbuf) < 0) {
 		(void)POPs;		/* Unmatched wildcard?  Chuck it... */
 		continue;
 	    }
@@ -1250,7 +1276,7 @@ PP(pp_enter)
     ENTER;
 
     SAVETMPS;
-    PUSHBLOCK(cx, CXt_BLOCK, sp);
+    PUSHBLOCK(cx, CXt_BLOCK, SP);
 
     RETURN;
 }
@@ -1295,7 +1321,7 @@ PP(pp_helem)
 	    if (HvNAME(hv) && isGV(*svp))
 		save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL));
 	    else
-		save_svref(svp);
+		save_helem(hv, keysv, svp);
 	}
 	else if (op->op_private & OPpDEREF)
 	    vivify_ref(*svp, op->op_private & OPpDEREF);
@@ -1367,7 +1393,7 @@ PP(pp_iter)
     SV* sv;
     AV* av;
 
-    EXTEND(sp, 1);
+    EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
     if (cx->cx_type != CXt_LOOP)
 	DIE("panic: pp_iter");
@@ -1378,7 +1404,9 @@ PP(pp_iter)
 
     SvREFCNT_dec(*cx->blk_loop.itervar);
 
-    if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
+    if (sv = (SvMAGICAL(av)) 
+	    ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) 
+	    : AvARRAY(av)[++cx->blk_loop.iterix])
 	SvTEMP_off(sv);
     else
 	sv = &sv_undef;
@@ -1439,14 +1467,17 @@ PP(pp_subst)
     else {
 	TARG = DEFSV;
 	EXTEND(SP,1);
-    }
+    }                  
     if (SvREADONLY(TARG)
 	|| (SvTYPE(TARG) > SVt_PVLV
 	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
 	croak(no_modify);
+    PUTBACK;
+
     s = SvPV(TARG, len);
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
 	force_on_match = 1;
+    rxtainted = tainted << 1;
     TAINT_NOT;
 
   force_it:
@@ -1519,6 +1550,7 @@ PP(pp_subst)
     if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
 	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
 	if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+	    SPAGAIN;
 	    PUSHs(&sv_no);
 	    LEAVE_SCOPE(oldsave);
 	    RETURN;
@@ -1532,7 +1564,7 @@ PP(pp_subst)
 	curpm = pm;
 	SvSCREAM_off(TARG);	/* disable possible screamer */
 	if (once) {
-	    rxtainted = RX_MATCH_TAINTED(rx);
+	    rxtainted |= RX_MATCH_TAINTED(rx);
 	    if (rx->subbase) {
 		m = orig + (rx->startp[0] - rx->subbase);
 		d = orig + (rx->endp[0] - rx->subbase);
@@ -1573,11 +1605,11 @@ PP(pp_subst)
 	    else {
 		sv_chop(TARG, d);
 	    }
-	    TAINT_IF(rxtainted);
+	    TAINT_IF(rxtainted & 1);
+	    SPAGAIN;
 	    PUSHs(&sv_yes);
 	}
 	else {
-	    rxtainted = 0;
 	    do {
 		if (iters++ > maxiters)
 		    DIE("Substitution loop");
@@ -1601,11 +1633,17 @@ PP(pp_subst)
 		SvCUR_set(TARG, d - SvPVX(TARG) + i);
 		Move(s, d, i+1, char);		/* include the NUL */
 	    }
-	    TAINT_IF(rxtainted);
+	    TAINT_IF(rxtainted & 1);
+	    SPAGAIN;
 	    PUSHs(sv_2mortal(newSViv((I32)iters)));
 	}
 	(void)SvPOK_only(TARG);
-	SvSETMAGIC(TARG);
+	TAINT_IF(rxtainted);
+	if (SvSMAGICAL(TARG)) {
+	    PUTBACK;
+	    mg_set(TARG);
+	    SPAGAIN;
+	}
 	SvTAINT(TARG);
 	LEAVE_SCOPE(oldsave);
 	RETURN;
@@ -1617,12 +1655,13 @@ PP(pp_subst)
 	    s = SvPV_force(TARG, len);
 	    goto force_it;
 	}
-	rxtainted = RX_MATCH_TAINTED(rx);
-	dstr = NEWSV(25, sv_len(TARG));
+	rxtainted |= RX_MATCH_TAINTED(rx);
+	dstr = NEWSV(25, len);
 	sv_setpvn(dstr, m, s-m);
 	curpm = pm;
 	if (!c) {
 	    register PERL_CONTEXT *cx;
+	    SPAGAIN;
 	    PUSHSUBST(cx);
 	    RETURNOP(cPMOP->op_pmreplroot);
 	}
@@ -1647,8 +1686,6 @@ PP(pp_subst)
 	} while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
 	sv_catpvn(dstr, s, strend - s);
 
-	TAINT_IF(rxtainted);
-
 	(void)SvOOK_off(TARG);
 	Safefree(SvPVX(TARG));
 	SvPVX(TARG) = SvPVX(dstr);
@@ -1657,10 +1694,14 @@ PP(pp_subst)
 	SvPVX(dstr) = 0;
 	sv_free(dstr);
 
+	TAINT_IF(rxtainted & 1);
+	SPAGAIN;
+	PUSHs(sv_2mortal(newSViv((I32)iters)));
+
 	(void)SvPOK_only(TARG);
+	TAINT_IF(rxtainted);
 	SvSETMAGIC(TARG);
 	SvTAINT(TARG);
-	PUSHs(sv_2mortal(newSViv((I32)iters)));
 	LEAVE_SCOPE(oldsave);
 	RETURN;
     }
@@ -1669,7 +1710,8 @@ PP(pp_subst)
 nope:
     ++BmUSEFUL(rx->check_substr);
 
-ret_no:
+ret_no:         
+    SPAGAIN;
     PUSHs(&sv_no);
     LEAVE_SCOPE(oldsave);
     RETURN;
@@ -1685,7 +1727,7 @@ PP(pp_grepwhile)
     LEAVE;					/* exit inner scope */
 
     /* All done yet? */
-    if (stack_base + *markstack_ptr > sp) {
+    if (stack_base + *markstack_ptr > SP) {
 	I32 items;
 	I32 gimme = GIMME_V;
 
@@ -1757,31 +1799,39 @@ PP(pp_leavesub)
     return pop_return();
 }
 
-static CV *
+STATIC CV *
 get_db_sub(SV **svp, CV *cv)
 {
     dTHR;
-    SV *oldsv = *svp;
-    GV *gv;
+    SV *dbsv = GvSV(DBsub);
+
+    if (!PERLDB_SUB_NN) {
+	GV *gv = CvGV(cv);
 
-    *svp = GvSV(DBsub);
-    save_item(*svp);
-    gv = CvGV(cv);
-    if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
-	 || strEQ(GvNAME(gv), "END") 
-	 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
-	     !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
-    		&& (gv = (GV*)oldsv) ))) {
-	/* Use GV from the stack as a fallback. */
-	/* GV is potentially non-unique, or contain different CV. */
-	sv_setsv(*svp, newRV((SV*)cv));
+	save_item(dbsv);
+	if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+	     || strEQ(GvNAME(gv), "END") 
+	     || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+		 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
+		    && (gv = (GV*)*svp) ))) {
+	    /* Use GV from the stack as a fallback. */
+	    /* GV is potentially non-unique, or contain different CV. */
+	    sv_setsv(dbsv, newRV((SV*)cv));
+	}
+	else {
+	    gv_efullname3(dbsv, gv, Nullch);
+	}
     }
     else {
-	gv_efullname3(*svp, gv, Nullch);
+	SvUPGRADE(dbsv, SVt_PVIV);
+	SvIOK_on(dbsv);
+	SAVEIV(SvIVX(dbsv));
+	SvIVX(dbsv) = (IV)cv;		/* Do it the quickest way  */
     }
-    cv = GvCV(DBsub);
+
     if (CvXSUB(cv))
 	curcopdb = curcop;
+    cv = GvCV(DBsub);
     return cv;
 }
 
@@ -1950,8 +2000,9 @@ PP(pp_entersub)
      	 * (3) instead of (2) so we'd have to clone. Would the fact
      	 * that we released the mutex more quickly make up for this?
      	 */
-	svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE);
-     	if (svp) {
+	if (threadnum &&
+	    (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
+	{
 	    /* We already have a clone to use */
 	    MUTEX_UNLOCK(CvMUTEXP(cv));
 	    cv = *(CV**)svp;
@@ -2003,17 +2054,15 @@ PP(pp_entersub)
     }
 #endif /* USE_THREADS */
 
-    gimme = GIMME;
-
     if (CvXSUB(cv)) {
 	if (CvOLDSTYLE(cv)) {
 	    I32 (*fp3)_((int,int,int));
 	    dMARK;
 	    register I32 items = SP - MARK;
 					/* We dont worry to copy from @_. */
-	    while (sp > mark) {
-		sp[1] = sp[0];
-		sp--;
+	    while (SP > mark) {
+		SP[1] = SP[0];
+		SP--;
 	    }
 	    stack_sp = mark + 1;
 	    fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
@@ -2038,13 +2087,13 @@ PP(pp_entersub)
 #else
 		av = GvAV(defgv);
 #endif /* USE_THREADS */		
-		items = AvFILL(av) + 1;
+		items = AvFILLp(av) + 1;   /* @_ is not tieable */
 
 		if (items) {
 		    /* Mark is at the end of the stack. */
-		    EXTEND(sp, items);
-		    Copy(AvARRAY(av), sp + 1, items, SV*);
-		    sp += items;
+		    EXTEND(SP, items);
+		    Copy(AvARRAY(av), SP + 1, items, SV*);
+		    SP += items;
 		    PUTBACK ;		    
 		}
 	    }
@@ -2056,7 +2105,7 @@ PP(pp_entersub)
 		curcopdb = NULL;
 	    }
 	    /* Do we need to open block here? XXXX */
-	    (void)(*CvXSUB(cv))(cv);
+	    (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
 
 	    /* Enforce some sanity in scalar context. */
 	    if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
@@ -2085,11 +2134,11 @@ PP(pp_entersub)
 	    if (CvDEPTH(cv) == 100 && dowarn 
 		  && !(PERLDB_SUB && cv == GvCV(DBsub)))
 		sub_crush_depth(cv);
-	    if (CvDEPTH(cv) > AvFILL(padlist)) {
+	    if (CvDEPTH(cv) > AvFILLp(padlist)) {
 		AV *av;
 		AV *newpad = newAV();
 		SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
-		I32 ix = AvFILL((AV*)svp[1]);
+		I32 ix = AvFILLp((AV*)svp[1]);
 		svp = AvARRAY(svp[0]);
 		for ( ;ix > 0; ix--) {
 		    if (svp[ix] != &sv_undef) {
@@ -2119,7 +2168,7 @@ PP(pp_entersub)
 		av_store(newpad, 0, (SV*)av);
 		AvFLAGS(av) = AVf_REIFY;
 		av_store(padlist, CvDEPTH(cv), (SV*)newpad);
-		AvFILL(padlist) = CvDEPTH(cv);
+		AvFILLp(padlist) = CvDEPTH(cv);
 		svp = AvARRAY(padlist);
 	    }
 	}
@@ -2127,12 +2176,12 @@ PP(pp_entersub)
 	if (!hasargs) {
 	    AV* av = (AV*)curpad[0];
 
-	    items = AvFILL(av) + 1;
+	    items = AvFILLp(av) + 1;
 	    if (items) {
 		/* Mark is at the end of the stack. */
-		EXTEND(sp, items);
-		Copy(AvARRAY(av), sp + 1, items, SV*);
-		sp += items;
+		EXTEND(SP, items);
+		Copy(AvARRAY(av), SP + 1, items, SV*);
+		SP += items;
 		PUTBACK ;		    
 	    }
 	}
@@ -2176,7 +2225,7 @@ PP(pp_entersub)
 		}
 	    }
 	    Copy(MARK,AvARRAY(av),items,SV*);
-	    AvFILL(av) = items - 1;
+	    AvFILLp(av) = items - 1;
 	    
 	    while (items--) {
 		if (*MARK)
@@ -2234,7 +2283,7 @@ PP(pp_aelem)
 	    RETURN;
 	}
 	if (op->op_private & OPpLVAL_INTRO)
-	    save_svref(svp);
+	    save_aelem(av, elem, svp);
 	else if (op->op_private & OPpDEREF)
 	    vivify_ref(*svp, op->op_private & OPpDEREF);
     }
@@ -2259,7 +2308,7 @@ vivify_ref(SV *sv, U32 to_what)
 	}
 	switch (to_what) {
 	case OPpDEREF_SV:
-	    SvRV(sv) = newSV(0);
+	    SvRV(sv) = NEWSV(355,0);
 	    break;
 	case OPpDEREF_AV:
 	    SvRV(sv) = (SV*)newAV();