X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=58ab34ccda41c9af62f77ca9cb2f0e0734c4d848;hb=9f8d30d514938e706a878aae5fd5b902550604e2;hp=0e86fd132bed94780dbf5067dffdb1d4f9c8cf16;hpb=1ce6579f507d8df65469f4640c049d0c3af07863;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 0e86fd1..58ab34c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -31,8 +31,9 @@ static I32 dopoptolabel _((char *label));
 static I32 dopoptoloop _((I32 startingblock));
 static I32 dopoptosub _((I32 startingblock));
 static void save_lines _((AV *array, SV *sv));
-static int sortcmp _((const void *, const void *));
 static int sortcv _((const void *, const void *));
+static int sortcmp _((const void *, const void *));
+static int sortcmp_locale _((const void *, const void *));
 
 static I32 sortcxix;
 
@@ -108,6 +109,8 @@ PP(pp_substcont)
 	if (cx->sb_iters > cx->sb_maxiters)
 	    DIE("Substitution loop");
 
+	if (!cx->sb_rxtainted)
+	    cx->sb_rxtainted = SvTAINTED(TOPs);
 	sv_catsv(dstr, POPs);
 	if (rx->subbase)
 	    Safefree(rx->subbase);
@@ -130,6 +133,8 @@ PP(pp_substcont)
 
 	    (void)SvPOK_only(targ);
 	    SvSETMAGIC(targ);
+	    if (cx->sb_rxtainted)
+		SvTAINTED_on(targ);
 	    PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 	    LEAVE_SCOPE(cx->sb_oldsave);
 	    POPSUBST(cx);
@@ -147,6 +152,7 @@ PP(pp_substcont)
     sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0];
     cx->sb_subbase = rx->subbase;
+    cx->sb_rxtainted |= rx->exec_tainted;
 
     rx->subbase = Nullch;	/* so recursion works */
     RETURNOP(pm->op_pmreplstart);
@@ -174,7 +180,7 @@ PP(pp_formline)
     bool gotsome;
     STRLEN len;
 
-    if (!SvCOMPILED(form)) {
+    if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
 	SvREADONLY_off(form);
 	doparseform(form);
     }
@@ -212,9 +218,9 @@ PP(pp_formline)
 	    case FF_END:	name = "END";		break;
 	    }
 	    if (arg >= 0)
-		fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+		PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
 	    else
-		fprintf(stderr, "%-16s\n", name);
+		PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
 	} )
 	switch (*fpc++) {
 	case FF_LINEMARK:
@@ -376,6 +382,8 @@ PP(pp_formline)
 	    }
 	    gotsome = TRUE;
 	    value = SvNV(sv);
+	    /* Formats aren't yet marked for locales, so assume "yes". */
+	    SET_NUMERIC_LOCAL();
 	    if (arg & 256) {
 		sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
 	    } else {
@@ -574,7 +582,7 @@ PP(pp_sort)
 	    if (!(cv && CvROOT(cv))) {
 		if (gv) {
 		    SV *tmpstr = sv_newmortal();
-		    gv_efullname(tmpstr, gv);
+		    gv_efullname3(tmpstr, gv, Nullch);
 		    if (cv && CvXSUB(cv))
 			DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
 		    DIE("Undefined sort subroutine \"%s\" called",
@@ -604,10 +612,9 @@ PP(pp_sort)
     while (MARK < SP) {	/* This may or may not shift down one here. */
 	/*SUPPRESS 560*/
 	if (*up = *++MARK) {			/* Weed out nulls. */
-	    if (!SvPOK(*up))
+	    SvTEMP_off(*up);
+	    if (!sortcop && !SvPOK(*up))
 		(void)sv_2pv(*up, &na);
-	    else
-		SvTEMP_off(*up);
 	    up++;
 	}
     }
@@ -649,7 +656,8 @@ PP(pp_sort)
     else {
 	if (max > 1) {
 	    MEXTEND(SP, 20);	/* Can't afford stack realloc on signal. */
-	    qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+	    qsort((char*)(ORIGMARK+1), max, sizeof(SV*),
+		  (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp);
 	}
     }
     stack_sp = ORIGMARK + max;
@@ -707,14 +715,16 @@ PP(pp_flop)
 	I32 max;
 
 	if (SvNIOKp(left) || !SvPOKp(left) ||
-	  (looks_like_number(left) && *SvPVX(left) != '0') ) {
+	  (looks_like_number(left) && *SvPVX(left) != '0') )
+	{
 	    i = SvIV(left);
 	    max = SvIV(right);
-	    if (max > i)
+	    if (max >= i) {
+		EXTEND_MORTAL(max - i + 1);
 		EXTEND(SP, max - i + 1);
+	    }
 	    while (i <= max) {
-		sv = sv_mortalcopy(&sv_no);
-		sv_setiv(sv,i++);
+		sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
 	}
@@ -853,7 +863,7 @@ I32 startingblock;
 	switch (cx->cx_type) {
 	case CXt_SUBST:
 	    if (dowarn)
-		warn("Exiting substitition via %s", op_name[op->op_type]);
+		warn("Exiting substitution via %s", op_name[op->op_type]);
 	    break;
 	case CXt_SUB:
 	    if (dowarn)
@@ -881,7 +891,7 @@ I32 cxix;
 
     while (cxstack_ix > cxix) {
 	cx = &cxstack[cxstack_ix--];
-	DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
 		    block_type[cx->cx_type]));
 	/* Note: we don't need to restore the base context info till the end. */
 	switch (cx->cx_type) {
@@ -900,54 +910,6 @@ I32 cxix;
     }
 }
 
-#ifdef I_STDARG
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
-    char *pat;
-    va_dcl
-#endif
-{
-    va_list args;
-    char *message;
-    int oldrunlevel = runlevel;
-    int was_in_eval = in_eval;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-
-    /* We have to switch back to mainstack or die_where may try to pop
-     * the eval block from the wrong stack if die is being called from a
-     * signal handler.  - dkindred@cs.cmu.edu */
-    if (curstack != mainstack) {
-        dSP;
-        SWITCHSTACK(curstack, mainstack);
-    }
-#ifdef I_STDARG
-    va_start(args, pat);
-#else
-    va_start(args);
-#endif
-    message = mess(pat, &args);
-    va_end(args);
-    if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
-	dSP;
-
-	PUSHMARK(sp);
-	EXTEND(sp, 1);
-	PUSHs(sv_2mortal(newSVpv(message,0)));
-	PUTBACK;
-	perl_call_sv((SV*)cv, G_DISCARD);
-    }
-    restartop = die_where(message);
-    if ((!restartop && was_in_eval) || oldrunlevel > 1)
-	Siglongjmp(top_env, 3);
-    return restartop;
-}
-
 OP *
 die_where(message)
 char *message;
@@ -987,7 +949,7 @@ char *message;
 
 	    POPBLOCK(cx,curpm);
 	    if (cx->cx_type != CXt_EVAL) {
-		fprintf(stderr, "panic: die %s", message);
+		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
 		my_exit(1);
 	    }
 	    POPEVAL(cx);
@@ -1003,11 +965,11 @@ char *message;
 	    return pop_return();
 	}
     }
-    fputs(message, stderr);
-    (void)Fflush(stderr);
+    PerlIO_printf(PerlIO_stderr(), "%s",message);
+    PerlIO_flush(PerlIO_stderr());
     if (e_tmpname) {
 	if (e_fp) {
-	    fclose(e_fp);
+	    PerlIO_close(e_fp);
 	    e_fp = Nullfp;
 	}
 	(void)UNLINK(e_tmpname);
@@ -1114,7 +1076,7 @@ PP(pp_caller)
 	RETURN;
     if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
 	sv = NEWSV(49, 0);
-	gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+	gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
 	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
@@ -1189,33 +1151,15 @@ sortcmp(a, b)
 const void *a;
 const void *b;
 {
-    register SV *str1 = *(SV **) a;
-    register SV *str2 = *(SV **) b;
-    I32 retval;
-
-    if (!SvPOKp(str1)) {
-	if (!SvPOKp(str2))
-	    return 0;
-	else
-	    return -1;
-    }
-    if (!SvPOKp(str2))
-	return 1;
+    return sv_cmp(*(SV **)a, *(SV **)b);
+}
 
-    if (SvCUR(str1) < SvCUR(str2)) {
-	/*SUPPRESS 560*/
-	if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
-	    return retval;
-	else
-	    return -1;
-    }
-    /*SUPPRESS 560*/
-    else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
-	return retval;
-    else if (SvCUR(str1) == SvCUR(str2))
-	return 0;
-    else
-	return 1;
+static int
+sortcmp_locale(a, b)
+const void *a;
+const void *b;
+{
+    return sv_cmp_locale(*(SV **)a, *(SV **)b);
 }
 
 PP(pp_reset)
@@ -1265,7 +1209,7 @@ PP(pp_dbstate)
 	SAVETMPS;
 
 	SAVEI32(debug);
-	SAVESPTR(stack_sp);
+	SAVESTACK_POS();
 	debug = 0;
 	hasargs = 0;
 	sp = stack_sp;
@@ -1309,11 +1253,8 @@ PP(pp_enteriter)
 
     PUSHBLOCK(cx, CXt_LOOP, SP);
     PUSHLOOP(cx, svp, MARK);
-    if (op->op_flags & OPf_STACKED) {
-	AV* av = (AV*)POPs;
-	cx->blk_loop.iterary = av;
-	cx->blk_loop.iterix = -1;
-    }
+    if (op->op_flags & OPf_STACKED)
+	cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
     else {
 	cx->blk_loop.iterary = curstack;
 	AvFILL(curstack) = sp - stack_base;
@@ -1623,7 +1564,7 @@ PP(pp_goto)
 	    if (!CvROOT(cv) && !CvXSUB(cv)) {
 		if (CvGV(cv)) {
 		    SV *tmpstr = sv_newmortal();
-		    gv_efullname(tmpstr, CvGV(cv));
+		    gv_efullname3(tmpstr, CvGV(cv), Nullch);
 		    DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
 		}
 		DIE("Goto undefined subroutine");
@@ -1645,6 +1586,7 @@ PP(pp_goto)
 		EXTEND(stack_sp, items); /* @_ could have been extended. */
 		Copy(AvARRAY(av), stack_sp, items, SV*);
 		stack_sp += items;
+		SvREFCNT_dec(GvAV(defgv));
 		GvAV(defgv) = cx->blk_sub.savearray;
 		AvREAL_off(av);
 		av_clear(av);
@@ -1686,8 +1628,7 @@ PP(pp_goto)
 		    (void)SvREFCNT_inc(cv);
 		else {	/* save temporaries on recursion? */
 		    if (CvDEPTH(cv) == 100 && dowarn)
-			warn("Deep recursion on subroutine \"%s\"",
-			    GvENAME(CvGV(cv)));
+			sub_crush_depth(cv);
 		    if (CvDEPTH(cv) > AvFILL(padlist)) {
 			AV *newpad = newAV();
 			SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
@@ -1696,8 +1637,10 @@ PP(pp_goto)
 			for ( ;ix > 0; ix--) {
 			    if (svp[ix] != &sv_undef) {
 				char *name = SvPVX(svp[ix]);
-				if (SvFLAGS(svp[ix]) & SVf_FAKE) {
-				    /* outer lexical? */
+				if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+				    || *name == '&')
+				{
+				    /* outer lexical or anon code */
 				    av_store(newpad, ix,
 					SvREFCNT_inc(oldpad[ix]) );
 				}
@@ -1735,7 +1678,7 @@ PP(pp_goto)
 
 		    cx->blk_sub.savearray = GvAV(defgv);
 		    cx->blk_sub.argarray = av;
-		    GvAV(defgv) = cx->blk_sub.argarray;
+		    GvAV(defgv) = (AV*)SvREFCNT_inc(av);
 		    ++mark;
 
 		    if (items >= AvMAX(av) + 1) {
@@ -1760,12 +1703,14 @@ PP(pp_goto)
 			mark++;
 		    }
 		}
-		if (perldb && curstash != debstash) { /* &xsub is not copying @_ */
+		if (perldb && curstash != debstash) {
+		    /*
+		     * We do not care about using sv to call CV;
+		     * it's for informational purposes only.
+		     */
 		    SV *sv = GvSV(DBsub);
 		    save_item(sv);
-		    gv_efullname(sv, CvGV(cv)); /* We do not care about
-						 * using sv to call CV,
-						 * just for info. */
+		    gv_efullname3(sv, CvGV(cv), Nullch);
 		}
 		RETURNOP(CvSTART(cv));
 	    }
@@ -1957,6 +1902,7 @@ int gimme;
     dSP;
     OP *saveop = op;
     HV *newstash;
+    CV *caller;
     AV* comppadlist;
 
     in_eval = 1;
@@ -1965,17 +1911,19 @@ int gimme;
 
     /* set up a scratch pad */
 
-    SAVEINT(padix);
+    SAVEI32(padix);
     SAVESPTR(curpad);
     SAVESPTR(comppad);
     SAVESPTR(comppad_name);
-    SAVEINT(comppad_name_fill);
-    SAVEINT(min_intro_pending);
-    SAVEINT(max_intro_pending);
+    SAVEI32(comppad_name_fill);
+    SAVEI32(min_intro_pending);
+    SAVEI32(max_intro_pending);
 
+    caller = compcv;
     SAVESPTR(compcv);
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     comppad_name = newAV();
@@ -1990,6 +1938,10 @@ int gimme;
     av_store(comppadlist, 0, (SV*)comppad_name);
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(compcv) = comppadlist;
+
+    if (saveop->op_type != OP_REQUIRE)
+	CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
     SAVEFREESV(compcv);
 
     /* make sure we compile in the right package */
@@ -2049,6 +2001,20 @@ int gimme;
 
     DEBUG_x(dump_eval());
 
+    /* Register with debugger: */
+
+    if (perldb && saveop->op_type == OP_REQUIRE) {
+	CV *cv = perl_get_cv("DB::postponed", FALSE);
+	
+	if (cv) {
+	    dSP;
+	    PUSHMARK(sp);
+	    XPUSHs((SV*)compiling.cop_filegv);
+	    PUTBACK;
+	    perl_call_sv((SV*)cv, G_DISCARD);
+	}
+    }
+
     /* compiled okay, so do it */
 
     SP = stack_base + POPMARK;		/* pop original mark */
@@ -2064,10 +2030,11 @@ PP(pp_require)
     char *tmpname;
     SV** svp;
     I32 gimme = G_SCALAR;
-    FILE *tryrsfp = 0;
+    PerlIO *tryrsfp = 0;
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
+	SET_NUMERIC_STANDARD();
 	if (atof(patchlevel) + 0.00000999 < SvNV(sv))
 	    DIE("Perl %s required--this is only version %s, stopped",
 		SvPV(sv,na),patchlevel);
@@ -2093,27 +2060,29 @@ PP(pp_require)
       || (tmpname[0] && tmpname[1] == ':')
 #endif
 #ifdef VMS
-	|| (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
-	    (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+	|| (strchr(tmpname,':')  || ((*tmpname == '[' || *tmpname == '<') &&
+	    (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
 #endif
     )
     {
-	tryrsfp = fopen(tmpname,"r");
+	tryrsfp = PerlIO_open(tmpname,"r");
     }
     else {
 	AV *ar = GvAVn(incgv);
 	I32 i;
-
-	for (i = 0; i <= AvFILL(ar); i++) {
 #ifdef VMS
+	char unixified[256];
+	if (tounixspec_ts(tmpname,unixified) != NULL)
+	  for (i = 0; i <= AvFILL(ar); i++) {
 	    if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
 		continue;
-	    strcat(buf,name);
+	    strcat(buf,unixified);
 #else
+	for (i = 0; i <= AvFILL(ar); i++) {
 	    (void)sprintf(buf, "%s/%s",
 		SvPVx(*av_fetch(ar, i, TRUE), na), name);
 #endif
-	    tryrsfp = fopen(buf, "r");
+	    tryrsfp = PerlIO_open(buf, "r");
 	    if (tryrsfp) {
 		char *s = buf;
 
@@ -2182,9 +2151,10 @@ PP(pp_entereval)
     dSP;
     register CONTEXT *cx;
     dPOPss;
-    I32 gimme = GIMME;
-    char tmpbuf[32];
+    I32 gimme = GIMME, was = sub_generation;
+    char tmpbuf[32], *safestr;
     STRLEN len;
+    OP *ret;
 
     if (!SvPV(sv,len) || !len)
 	RETPUSHUNDEF;
@@ -2200,7 +2170,13 @@ PP(pp_entereval)
     sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
     compiling.cop_line = 1;
-    SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+    /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+       deleting the eval's FILEGV from the stash before gv_check() runs
+       (i.e. before run-time proper). To work around the coredump that
+       ensues, we always turn GvMULTI_on for any globals that were
+       introduced within evals. See force_ident(). GSAR 96-10-12 */
+    safestr = savepv(tmpbuf);
+    SAVEDELETE(defstash, safestr, strlen(safestr));
     SAVEI32(hints);
     hints = op->op_targ;
 
@@ -2213,7 +2189,11 @@ PP(pp_entereval)
     if (perldb && curstash != debstash)
 	save_lines(GvAV(compiling.cop_filegv), linestr);
     PUTBACK;
-    return doeval(gimme);
+    ret = doeval(gimme);
+    if (perldb && was != sub_generation) { /* Some subs defined here. */
+	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */
+    }
+    return ret;
 }
 
 PP(pp_leaveeval)
@@ -2225,7 +2205,7 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
-    OP *saveop = op;
+    U8 save_flags = op -> op_flags;
     I32 optype;
 
     POPBLOCK(cx,newpm);
@@ -2252,7 +2232,7 @@ PP(pp_leaveeval)
     }
     else {
 	for (mark = newsp + 1; mark <= SP; mark++)
-	    if (!(SvFLAGS(TOPs) & SVs_TEMP))
+	    if (!(SvFLAGS(*mark) & SVs_TEMP))
 		*mark = sv_mortalcopy(*mark);
 		/* in case LEAVE wipes old return values */
     }
@@ -2269,7 +2249,7 @@ PP(pp_leaveeval)
 
     lex_end();
     LEAVE;
-    if (!(saveop->op_flags & OPf_SPECIAL))
+    if (!(save_flags & OPf_SPECIAL))
 	sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
@@ -2328,7 +2308,7 @@ PP(pp_leavetry)
     }
     else {
 	for (mark = newsp + 1; mark <= SP; mark++)
-	    if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+	    if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
 		*mark = sv_mortalcopy(*mark);
 		/* in case LEAVE wipes old return values */
     }
@@ -2357,7 +2337,10 @@ SV *sv;
     register I32 arg;
     bool ischop;
 
-    New(804, fops, (send - s)*3+2, U16);    /* Almost certainly too long... */
+    if (len == 0)
+	croak("Null picture in formline");
+    
+    New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
     fpc = fops;
 
     if (s < send) {
@@ -2390,13 +2373,12 @@ SV *sv;
 	    skipspaces++;
 	    arg -= skipspaces;
 	    if (arg) {
-		if (postspace) {
+		if (postspace)
 		    *fpc++ = FF_SPACE;
-		    postspace = FALSE;
-		}
 		*fpc++ = FF_LITERAL;
 		*fpc++ = arg;
 	    }
+	    postspace = FALSE;
 	    if (s <= send)
 		skipspaces--;
 	    if (skipspaces) {
@@ -2512,5 +2494,6 @@ SV *sv;
     }
     Copy(fops, s, arg, U16);
     Safefree(fops);
+    sv_magic(sv, Nullsv, 'f', Nullch, 0);
     SvCOMPILED_on(sv);
 }