X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=76a2466ca540826ac9a23d720ce841c5dd392e77;hb=1a67fee7d910c67790fff4a69f2f20f7628aa80a;hp=d46187379b923e6c446bd86cd79447d1be2572ef;hpb=13e28e4cdde09b7e9e7692148b86222565bcbf1d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index d461873..76a2466 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -73,7 +73,7 @@ PP(pp_regcomp)
     tmpstr = POPs;
 
     /* prevent recompiling under /o and ithreads. */
-#if defined(USE_ITHREADS) || defined(USE_5005THREADS)
+#if defined(USE_ITHREADS)
     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
 	 RETURN;
 #endif
@@ -138,7 +138,7 @@ PP(pp_regcomp)
     /* XXX runtime compiled output needs to move to the pad */
     if (pm->op_pmflags & PMf_KEEP) {
 	pm->op_private &= ~OPpRUNTIME;	/* no point compiling again */
-#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
+#if !defined(USE_ITHREADS)
 	/* XXX can't change the optree at runtime either */
 	cLOGOP->op_first->op_next = PL_op->op_next;
 #endif
@@ -836,7 +836,7 @@ PP(pp_mapwhile)
 	}
 	/* copy the new items down to the destination list */
 	dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
-	while (items--)
+	while (items-- > 0)
 	    *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
     }
     LEAVE;					/* exit inner scope */
@@ -943,10 +943,14 @@ PP(pp_flop)
 	if (SvGMAGICAL(right))
 	    mg_get(right);
 
+	/* This code tries to decide if "$left .. $right" should use the
+	   magical string increment, or if the range is numeric (we make
+	   an exception for .."0" [#18165]). AMS 20021031. */
+
 	if (SvNIOKp(left) || !SvPOKp(left) ||
 	    SvNIOKp(right) || !SvPOKp(right) ||
 	    (looks_like_number(left) && *SvPVX(left) != '0' &&
-	     looks_like_number(right) && *SvPVX(right) != '0'))
+	     looks_like_number(right)))
 	{
 	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 		DIE(aTHX_ "Range iterator outside integer range");
@@ -1378,7 +1382,40 @@ PP(pp_orassign)
     else
 	RETURNOP(cLOGOP->op_other);
 }
-	
+
+PP(pp_dorassign)
+{
+    dSP;
+    register SV* sv;
+
+    sv = TOPs;
+    if (!sv || !SvANY(sv)) {
+	RETURNOP(cLOGOP->op_other);
+    }
+
+    switch (SvTYPE(sv)) {
+    case SVt_PVAV:
+	if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+	    RETURN;
+	break;
+    case SVt_PVHV:
+	if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
+	    RETURN;
+	break;
+    case SVt_PVCV:
+	if (CvROOT(sv) || CvXSUB(sv))
+	    RETURN;
+	break;
+    default:
+	if (SvGMAGICAL(sv))
+	    mg_get(sv);
+	if (SvOK(sv))
+	    RETURN;
+    }
+
+    RETURNOP(cLOGOP->op_other);
+}
+
 PP(pp_caller)
 {
     dSP;
@@ -1450,11 +1487,18 @@ PP(pp_caller)
     if (!MAXARG)
 	RETURN;
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+	GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 	/* So is ccstack[dbcxix]. */
-	sv = NEWSV(49, 0);
-	gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
-	PUSHs(sv_2mortal(sv));
-	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+	if (isGV(cvgv)) {
+	    sv = NEWSV(49, 0);
+	    gv_efullname3(sv, cvgv, Nullch);
+	    PUSHs(sv_2mortal(sv));
+	    PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+	}
+	else {
+	    PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
+	    PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+	}
     }
     else {
 	PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
@@ -1547,6 +1591,8 @@ PP(pp_lineseq)
     return NORMAL;
 }
 
+/* like pp_nextstate, but used instead when the debugger is active */
+
 PP(pp_dbstate)
 {
     PL_curcop = (COP*)PL_op;
@@ -1586,8 +1632,7 @@ PP(pp_dbstate)
 	PUSHSUB(cx);
 	CvDEPTH(cv)++;
 	(void)SvREFCNT_inc(cv);
-	SAVEVPTR(PL_curpad);
-	PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
+	PAD_SET_CUR(CvPADLIST(cv),1);
 	RETURNOP(CvSTART(cv));
     }
     else
@@ -1613,17 +1658,9 @@ PP(pp_enteriter)
     ENTER;
     SAVETMPS;
 
-#ifdef USE_5005THREADS
-    if (PL_op->op_flags & OPf_SPECIAL) {
-	svp = &THREADSV(PL_op->op_targ);	/* per-thread variable */
-	SAVEGENERICSV(*svp);
-	*svp = NEWSV(0,0);
-    }
-    else
-#endif /* USE_5005THREADS */
     if (PL_op->op_targ) {
 #ifndef USE_ITHREADS
-	svp = &PL_curpad[PL_op->op_targ];		/* "my" variable */
+	svp = &PAD_SVl(PL_op->op_targ);		/* "my" variable */
 	SAVESPTR(*svp);
 #else
 	SAVEPADSV(PL_op->op_targ);
@@ -2095,26 +2132,20 @@ PP(pp_goto)
 		EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
 		Copy(AvARRAY(av), PL_stack_sp, items, SV*);
 		PL_stack_sp += items;
-#ifndef USE_5005THREADS
 		SvREFCNT_dec(GvAV(PL_defgv));
 		GvAV(PL_defgv) = cx->blk_sub.savearray;
-#endif /* USE_5005THREADS */
 		/* abandon @_ if it got reified */
 		if (AvREAL(av)) {
 		    (void)sv_2mortal((SV*)av);	/* delay until return */
 		    av = newAV();
 		    av_extend(av, items-1);
 		    AvFLAGS(av) = AVf_REIFY;
-		    PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
+		    PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
 		}
 	    }
 	    else if (CvXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
 		AV* av;
-#ifdef USE_5005THREADS
-		av = (AV*)PL_curpad[0];
-#else
 		av = GvAV(PL_defgv);
-#endif
 		items = AvFILLp(av) + 1;
 		PL_stack_sp++;
 		EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
@@ -2162,7 +2193,6 @@ PP(pp_goto)
 	    }
 	    else {
 		AV* padlist = CvPADLIST(cv);
-		SV** svp = AvARRAY(padlist);
 		if (CxTYPE(cx) == CXt_EVAL) {
 		    PL_in_eval = cx->blk_eval.old_in_eval;
 		    PL_eval_root = cx->blk_eval.old_eval_root;
@@ -2171,85 +2201,24 @@ PP(pp_goto)
 		}
 		cx->blk_sub.cv = cv;
 		cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+
 		CvDEPTH(cv)++;
 		if (CvDEPTH(cv) < 2)
 		    (void)SvREFCNT_inc(cv);
-		else {	/* save temporaries on recursion? */
+		else {
 		    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
 			sub_crush_depth(cv);
-		    if (CvDEPTH(cv) > AvFILLp(padlist)) {
-			AV *newpad = newAV();
-			SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
-			I32 ix = AvFILLp((AV*)svp[1]);
-			I32 names_fill = AvFILLp((AV*)svp[0]);
-			svp = AvARRAY(svp[0]);
-			for ( ;ix > 0; ix--) {
-			    if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
-				char *name = SvPVX(svp[ix]);
-				if ((SvFLAGS(svp[ix]) & SVf_FAKE)
-				    || *name == '&')
-				{
-				    /* outer lexical or anon code */
-				    av_store(newpad, ix,
-					SvREFCNT_inc(oldpad[ix]) );
-				}
-				else {		/* our own lexical */
-				    if (*name == '@')
-					av_store(newpad, ix, sv = (SV*)newAV());
-				    else if (*name == '%')
-					av_store(newpad, ix, sv = (SV*)newHV());
-				    else
-					av_store(newpad, ix, sv = NEWSV(0,0));
-				    SvPADMY_on(sv);
-				}
-			    }
-			    else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
-				av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
-			    }
-			    else {
-				av_store(newpad, ix, sv = NEWSV(0,0));
-				SvPADTMP_on(sv);
-			    }
-			}
-			if (cx->blk_sub.hasargs) {
-			    AV* av = newAV();
-			    av_extend(av, 0);
-			    av_store(newpad, 0, (SV*)av);
-			    AvFLAGS(av) = AVf_REIFY;
-			}
-			av_store(padlist, CvDEPTH(cv), (SV*)newpad);
-			AvFILLp(padlist) = CvDEPTH(cv);
-			svp = AvARRAY(padlist);
-		    }
-		}
-#ifdef USE_5005THREADS
-		if (!cx->blk_sub.hasargs) {
-		    AV* av = (AV*)PL_curpad[0];
-		
-		    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;
-			PUTBACK ;		
-		    }
+		    pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
 		}
-#endif /* USE_5005THREADS */		
-		SAVEVPTR(PL_curpad);
-		PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_5005THREADS
+		PAD_SET_CUR(padlist, CvDEPTH(cv));
 		if (cx->blk_sub.hasargs)
-#endif /* USE_5005THREADS */
 		{
-		    AV* av = (AV*)PL_curpad[0];
+		    AV* av = (AV*)PAD_SVl(0);
 		    SV** ary;
 
-#ifndef USE_5005THREADS
 		    cx->blk_sub.savearray = GvAV(PL_defgv);
 		    GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_5005THREADS */
-		    cx->blk_sub.oldcurpad = PL_curpad;
+		    CX_CURPAD_SAVE(cx->blk_sub);
 		    cx->blk_sub.argarray = av;
 		    ++mark;
 
@@ -2588,7 +2557,7 @@ S_docatch(pTHX_ OP *o)
 }
 
 OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
+Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
 /* sv Text to convert to OP tree. */
 /* startop op_free() this to undo. */
 /* code Short string id of the caller. */
@@ -2603,6 +2572,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     char tbuf[TYPE_DIGITS(long) + 12 + 10];
     char *tmpbuf = tbuf;
     char *safestr;
+    int runtime;
+    CV* runcv;
 
     ENTER;
     lex_start(sv);
@@ -2641,19 +2612,29 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
 #endif
     PL_hints &= HINT_UTF8;
 
+    /* we get here either during compilation, or via pp_regcomp at runtime */
+    runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
+    if (runtime)
+	runcv = find_runcv();
+
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;			/* Avoid uninit warning. */
     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
-    rop = doeval(G_SCALAR, startop);
+
+    if (runtime)
+	rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+    else
+	rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
     POPBLOCK(cx,PL_curpm);
     POPEVAL(cx);
 
     (*startop)->op_type = OP_NULL;
     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
     lex_end();
-    *avp = (AV*)SvREFCNT_inc(PL_comppad);
+    /* XXX DAPM do this properly one year */
+    *padp = (AV*)SvREFCNT_inc(PL_comppad);
     LEAVE;
     if (PL_curcop == &PL_compiling)
 	PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
@@ -2663,15 +2644,47 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     return rop;
 }
 
+
+/*
+=for apidoc find_runcv
+
+Locate the CV corresponding to the currently executing sub or eval.
+
+=cut
+*/
+
+CV*
+Perl_find_runcv(pTHX)
+{
+    I32		 ix;
+    PERL_SI	 *si;
+    PERL_CONTEXT *cx;
+
+    for (si = PL_curstackinfo; si; si = si->si_prev) {
+	for (ix = si->si_cxix; ix >= 0; ix--) {
+	    cx = &(si->si_cxstack[ix]);
+	    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+		return cx->blk_sub.cv;
+	    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+		return PL_compcv;
+	}
+    }
+    return PL_main_cv;
+}
+
+
+/* Compile a require/do, an eval '', or a /(?{...})/.
+ * In the last case, startop is non-null, and contains the address of
+ * a pointer that should be set to the just-compiled code.
+ * outside is the lexically enclosing CV (if any) that invoked us.
+ */
+
 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
 STATIC OP *
-S_doeval(pTHX_ int gimme, OP** startop)
+S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 {
     dSP;
     OP *saveop = PL_op;
-    CV *caller;
-    AV* comppadlist;
-    I32 i;
 
     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
 		  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
@@ -2679,27 +2692,6 @@ S_doeval(pTHX_ int gimme, OP** startop)
 
     PUSHMARK(SP);
 
-    /* set up a scratch pad */
-
-    SAVEI32(PL_padix);
-    SAVEVPTR(PL_curpad);
-    SAVESPTR(PL_comppad);
-    SAVESPTR(PL_comppad_name);
-    SAVEI32(PL_comppad_name_fill);
-    SAVEI32(PL_min_intro_pending);
-    SAVEI32(PL_max_intro_pending);
-
-    caller = PL_compcv;
-    for (i = cxstack_ix - 1; i >= 0; i--) {
-	PERL_CONTEXT *cx = &cxstack[i];
-	if (CxTYPE(cx) == CXt_EVAL)
-	    break;
-	else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
-	    caller = cx->blk_sub.cv;
-	    break;
-	}
-    }
-
     SAVESPTR(PL_compcv);
     PL_compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
@@ -2707,36 +2699,13 @@ S_doeval(pTHX_ int gimme, OP** startop)
     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
 
-#ifdef USE_5005THREADS
-    CvOWNER(PL_compcv) = 0;
-    New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
-    MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_5005THREADS */
-
-    PL_comppad = newAV();
-    av_push(PL_comppad, Nullsv);
-    PL_curpad = AvARRAY(PL_comppad);
-    PL_comppad_name = newAV();
-    PL_comppad_name_fill = 0;
-    PL_min_intro_pending = 0;
-    PL_padix = 0;
-#ifdef USE_5005THREADS
-    av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
-    PL_curpad[0] = (SV*)newAV();
-    SvPADMY_on(PL_curpad[0]);	/* XXX Needed? */
-#endif /* USE_5005THREADS */
-
-    comppadlist = newAV();
-    AvREAL_off(comppadlist);
-    av_store(comppadlist, 0, (SV*)PL_comppad_name);
-    av_store(comppadlist, 1, (SV*)PL_comppad);
-    CvPADLIST(PL_compcv) = comppadlist;
-
-    if (!saveop ||
-	(saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
-    {
-	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
-    }
+    CvOUTSIDE_SEQ(PL_compcv) = seq;
+    CvOUTSIDE(PL_compcv) = outside ? (CV*)SvREFCNT_inc(outside) : outside;
+
+    /* set up a scratch pad */
+
+    CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+
 
     SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
 
@@ -2794,19 +2763,17 @@ S_doeval(pTHX_ int gimme, OP** startop)
 	    Perl_croak(aTHX_ "%sCompilation failed in regexp",
 		       (*msg ? msg : "Unknown error\n"));
 	}
-#ifdef USE_5005THREADS
-	MUTEX_LOCK(&PL_eval_mutex);
-	PL_eval_owner = 0;
-	COND_SIGNAL(&PL_eval_cond);
-	MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
+	else {
+	    char* msg = SvPVx(ERRSV, n_a);
+	    if (!*msg) {
+	        sv_setpv(ERRSV, "Compilation error");
+	    }
+	}
 	RETPUSHUNDEF;
     }
     CopLINE_set(&PL_compiling, 0);
     if (startop) {
 	*startop = PL_eval_root;
-	SvREFCNT_dec(CvOUTSIDE(PL_compcv));
-	CvOUTSIDE(PL_compcv) = Nullcv;
     } else
 	SAVEFREEOP(PL_eval_root);
     if (gimme & G_VOID)
@@ -2836,12 +2803,6 @@ S_doeval(pTHX_ int gimme, OP** startop)
     SP = PL_stack_base + POPMARK;		/* pop original mark */
     PL_op = saveop;			/* The caller may need it. */
     PL_lex_state = LEX_NOTPARSING;	/* $^S needs this. */
-#ifdef USE_5005THREADS
-    MUTEX_LOCK(&PL_eval_mutex);
-    PL_eval_owner = 0;
-    COND_SIGNAL(&PL_eval_cond);
-    MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
 
     RETURNOP(PL_eval_start);
 }
@@ -3181,7 +3142,7 @@ PP(pp_require)
 	RETPUSHUNDEF;
     }
     else
-	SETERRNO(0, SS$_NORMAL);
+	SETERRNO(0, SS_NORMAL);
 
     /* Assume success here to prevent recursive requirement. */
     len = strlen(name);
@@ -3231,20 +3192,12 @@ PP(pp_require)
     CopLINE_set(&PL_compiling, 0);
 
     PUTBACK;
-#ifdef USE_5005THREADS
-    MUTEX_LOCK(&PL_eval_mutex);
-    if (PL_eval_owner && PL_eval_owner != thr)
-	while (PL_eval_owner)
-	    COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
-    PL_eval_owner = thr;
-    MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
 
     /* Store and reset encoding. */
     encoding = PL_encoding;
     PL_encoding = Nullsv;
 
-    op = DOCATCH(doeval(gimme, NULL));
+    op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
     
     /* Restore encoding. */
     PL_encoding = encoding;
@@ -3268,8 +3221,9 @@ PP(pp_entereval)
     char *safestr;
     STRLEN len;
     OP *ret;
+    CV* runcv;
 
-    if (!SvPV(sv,len) || !len)
+    if (!SvPV(sv,len))
 	RETPUSHUNDEF;
     TAINT_PROPER("eval");
 
@@ -3315,6 +3269,7 @@ PP(pp_entereval)
         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
         SAVEFREESV(PL_compiling.cop_io);
     }
+    runcv = find_runcv();
 
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
@@ -3325,15 +3280,7 @@ PP(pp_entereval)
     if (PERLDB_LINE && PL_curstash != PL_debstash)
 	save_lines(CopFILEAV(&PL_compiling), PL_linestr);
     PUTBACK;
-#ifdef USE_5005THREADS
-    MUTEX_LOCK(&PL_eval_mutex);
-    if (PL_eval_owner && PL_eval_owner != thr)
-	while (PL_eval_owner)
-	    COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
-    PL_eval_owner = thr;
-    MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
-    ret = doeval(gimme, NULL);
+    ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq);
     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
 	&& ret != PL_op->op_next) {	/* Successive compilation. */
 	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */