X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=621024a97db35f82efc692cbfc5a0e5b58427044;hb=45c0de28763808112fd2f46ea311b6bb0c6050b3;hp=230d94128a25ca9644f8be7d419c55d44d48a0f9;hpb=a0964cd6b053e8f07a8976c13435946b665520b4;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 230d941..621024a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -29,6 +29,7 @@
 #define CALLOP this->*PL_op
 #else
 #define CALLOP *PL_op
+static void *docatch_body _((void *o));
 static OP *docatch _((OP *o));
 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
 static void doparseform _((SV *sv));
@@ -41,6 +42,7 @@ static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
 static OP *doeval _((int gimme, OP** startop));
+static PerlIO *doopen_pmc _((const char *name, const char *mode));
 static I32 sv_ncmp _((SV *a, SV *b));
 static I32 sv_i_ncmp _((SV *a, SV *b));
 static I32 amagic_ncmp _((SV *a, SV *b));
@@ -1065,22 +1067,30 @@ PP(pp_flop)
 
     if (GIMME == G_ARRAY) {
 	dPOPPOPssrl;
-	register I32 i;
+	register I32 i, j;
 	register SV *sv;
 	I32 max;
 
+	if (SvGMAGICAL(left))
+	    mg_get(left);
+	if (SvGMAGICAL(right))
+	    mg_get(right);
+
 	if (SvNIOKp(left) || !SvPOKp(left) ||
 	  (looks_like_number(left) && *SvPVX(left) != '0') )
 	{
-	    if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
+	    if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 		croak("Range iterator outside integer range");
 	    i = SvIV(left);
 	    max = SvIV(right);
 	    if (max >= i) {
-		EXTEND_MORTAL(max - i + 1);
-		EXTEND(SP, max - i + 1);
+		j = max - i + 1;
+		EXTEND_MORTAL(j);
+		EXTEND(SP, j);
 	    }
-	    while (i <= max) {
+	    else
+		j = 0;
+	    while (j--) {
 		sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
@@ -1311,7 +1321,7 @@ dounwind(I32 cxix)
 }
 
 OP *
-die_where(char *message)
+die_where(char *message, STRLEN msglen)
 {
     dSP;
     STRLEN n_a;
@@ -1324,9 +1334,8 @@ die_where(char *message)
 	if (message) {
 	    if (PL_in_eval & 4) {
 		SV **svp;
-		STRLEN klen = strlen(message);
 		
-		svp = hv_fetch(ERRHV, message, klen, TRUE);
+		svp = hv_fetch(ERRHV, message, msglen, TRUE);
 		if (svp) {
 		    if (!SvIOK(*svp)) {
 			static char prefix[] = "\t(in cleanup) ";
@@ -1335,11 +1344,11 @@ die_where(char *message)
 			(void)SvIOK_only(*svp);
 			if (!SvPOK(err))
 			    sv_setpv(err,"");
-			SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+			SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
 			sv_catpvn(err, prefix, sizeof(prefix)-1);
-			sv_catpvn(err, message, klen);
+			sv_catpvn(err, message, msglen);
 			if (ckWARN(WARN_UNSAFE)) {
-			    STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
+			    STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
 			    warner(WARN_UNSAFE, SvPVX(err)+start);
 			}
 		    }
@@ -1347,10 +1356,10 @@ die_where(char *message)
 		}
 	    }
 	    else
-		sv_setpv(ERRSV, message);
+		sv_setpvn(ERRSV, message, msglen);
 	}
 	else
-	    message = SvPVx(ERRSV, n_a);
+	    message = SvPVx(ERRSV, msglen);
 
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
 	    dounwind(-1);
@@ -1365,7 +1374,8 @@ die_where(char *message)
 
 	    POPBLOCK(cx,PL_curpm);
 	    if (CxTYPE(cx) != CXt_EVAL) {
-		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+		PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
+		PerlIO_write(PerlIO_stderr(), message, msglen);
 		my_exit(1);
 	    }
 	    POPEVAL(cx);
@@ -1384,9 +1394,18 @@ die_where(char *message)
 	}
     }
     if (!message)
-	message = SvPVx(ERRSV, n_a);
-    PerlIO_printf(PerlIO_stderr(), "%s",message);
-    PerlIO_flush(PerlIO_stderr());
+	message = SvPVx(ERRSV, msglen);
+    {
+#ifdef USE_SFIO
+	/* SFIO can really mess with your errno */
+	int e = errno;
+#endif
+	PerlIO_write(PerlIO_stderr(), message, msglen);
+	(void)PerlIO_flush(PerlIO_stderr());
+#ifdef USE_SFIO
+	errno = e;
+#endif
+    }
     my_failure_exit();
     /* NOTREACHED */
     return 0;
@@ -1481,7 +1500,8 @@ PP(pp_caller)
 	PUSHs(&PL_sv_undef);
     else
 	PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
-    PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
+    PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
+			      SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
 	RETURN;
@@ -1492,7 +1512,7 @@ PP(pp_caller)
 	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
     else {
-	PUSHs(sv_2mortal(newSVpv("(eval)",0)));
+	PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
 	PUSHs(sv_2mortal(newSViv(0)));
     }
     gimme = (I32)cx->blk_gimme;
@@ -1640,8 +1660,12 @@ PP(pp_enteriter)
     SAVETMPS;
 
 #ifdef USE_THREADS
-    if (PL_op->op_flags & OPf_SPECIAL)
-	svp = save_threadsv(PL_op->op_targ);	/* per-thread variable */
+    if (PL_op->op_flags & OPf_SPECIAL) {
+	dTHR;
+	svp = &THREADSV(PL_op->op_targ);	/* per-thread variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
+    }
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
@@ -1649,9 +1673,9 @@ PP(pp_enteriter)
 	SAVESPTR(*svp);
     }
     else {
-	GV *gv = (GV*)POPs;
-	(void)save_scalar(gv);
-	svp = &GvSV(gv);			/* symbol table variable */
+	svp = &GvSV((GV*)POPs);			/* symbol table variable */
+	SAVEGENERICSV(*svp);
+	*svp = NEWSV(0,0);
     }
 
     ENTER;
@@ -2019,6 +2043,7 @@ PP(pp_goto)
     OP *enterops[GOTO_DEPTH];
     char *label;
     int do_dump = (PL_op->op_type == OP_DUMP);
+    static char must_have_label[] = "goto must have label";
 
     label = 0;
     if (PL_op->op_flags & OPf_STACKED) {
@@ -2107,6 +2132,7 @@ PP(pp_goto)
 	    /* Now do some callish stuff. */
 	    SAVETMPS;
 	    if (CvXSUB(cv)) {
+#ifdef PERL_XSUB_OLDSTYLE
 		if (CvOLDSTYLE(cv)) {
 		    I32 (*fp3)_((int,int,int));
 		    while (SP > mark) {
@@ -2119,7 +2145,9 @@ PP(pp_goto)
 				   items);
 		    SP = PL_stack_base + items;
 		}
-		else {
+		else
+#endif /* PERL_XSUB_OLDSTYLE */
+		{
 		    SV **newsp;
 		    I32 gimme;
 
@@ -2272,12 +2300,15 @@ PP(pp_goto)
 		RETURNOP(CvSTART(cv));
 	    }
 	}
-	else
+	else {
 	    label = SvPV(sv,n_a);
+	    if (!(do_dump || *label))
+		DIE(must_have_label);
+	}
     }
     else if (PL_op->op_flags & OPf_SPECIAL) {
 	if (! do_dump)
-	    DIE("goto must have label");
+	    DIE(must_have_label);
     }
     else
 	label = cPVOP->op_pv;
@@ -2461,38 +2492,41 @@ save_lines(AV *array, SV *sv)
     }
 }
 
+STATIC void *
+docatch_body(va_list args)
+{
+    CALLRUNOPS();
+    return NULL;
+}
+
 STATIC OP *
 docatch(OP *o)
 {
     dTHR;
     int ret;
     OP *oldop = PL_op;
-    dJMPENV;
 
-    PL_op = o;
 #ifdef DEBUGGING
     assert(CATCH_GET == TRUE);
-    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
 #endif
-    JMPENV_PUSH(ret);
+    PL_op = o;
+ redo_body:
+    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body));
     switch (ret) {
-    default:				/* topmost level handles it */
-pass_the_buck:
-	JMPENV_POP;
+    case 0:
+	break;
+    case 3:
+	if (PL_restartop) {
+	    PL_op = PL_restartop;
+	    PL_restartop = 0;
+	    goto redo_body;
+	}
+	/* FALL THROUGH */
+    default:
 	PL_op = oldop;
 	JMPENV_JUMP(ret);
 	/* NOTREACHED */
-    case 3:
-	if (!PL_restartop)
-	    goto pass_the_buck;
-	PL_op = PL_restartop;
-	PL_restartop = 0;
-	/* FALL THROUGH */
-    case 0:
-        CALLRUNOPS();
-	break;
     }
-    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
@@ -2603,7 +2637,7 @@ doeval(int gimme, OP** startop)
     SAVESPTR(PL_compcv);
     PL_compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
-    CvUNIQUE_on(PL_compcv);
+    CvEVAL_on(PL_compcv);
 #ifdef USE_THREADS
     CvOWNER(PL_compcv) = 0;
     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
@@ -2618,7 +2652,7 @@ doeval(int gimme, OP** startop)
     PL_min_intro_pending = 0;
     PL_padix = 0;
 #ifdef USE_THREADS
-    av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+    av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
     PL_curpad[0] = (SV*)newAV();
     SvPADMY_on(PL_curpad[0]);	/* XXX Needed? */
 #endif /* USE_THREADS */
@@ -2652,7 +2686,7 @@ doeval(int gimme, OP** startop)
     PL_curcop = &PL_compiling;
     PL_curcop->cop_arybase = 0;
     SvREFCNT_dec(PL_rs);
-    PL_rs = newSVpv("\n", 1);
+    PL_rs = newSVpvn("\n", 1);
     if (saveop && saveop->op_flags & OPf_SPECIAL)
 	PL_in_eval |= 4;
     else
@@ -2742,6 +2776,38 @@ doeval(int gimme, OP** startop)
     RETURNOP(PL_eval_start);
 }
 
+STATIC PerlIO *
+doopen_pmc(const char *name, const char *mode)
+{
+    STRLEN namelen = strlen(name);
+    PerlIO *fp;
+
+    if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
+	SV *pmcsv = newSVpvf("%s%c", name, 'c');
+	char *pmc = SvPV_nolen(pmcsv);
+	Stat_t pmstat;
+	Stat_t pmcstat;
+	if (PerlLIO_stat(pmc, &pmcstat) < 0) {
+	    fp = PerlIO_open(name, mode);
+	}
+	else {
+	    if (PerlLIO_stat(name, &pmstat) < 0 ||
+	        pmstat.st_mtime < pmcstat.st_mtime)
+	    {
+		fp = PerlIO_open(pmc, mode);
+	    }
+	    else {
+		fp = PerlIO_open(name, mode);
+	    }
+	}
+	SvREFCNT_dec(pmcsv);
+    }
+    else {
+	fp = PerlIO_open(name, mode);
+    }
+    return fp;
+}
+
 PP(pp_require)
 {
     djSP;
@@ -2792,7 +2858,7 @@ PP(pp_require)
     )
     {
 	tryname = name;
-	tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+	tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
     }
     else {
 	AV *ar = GvAVn(PL_incgv);
@@ -2816,7 +2882,7 @@ PP(pp_require)
 #endif
 		TAINT_PROPER("require");
 		tryname = SvPVX(namesv);
-		tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
+		tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
 		if (tryrsfp) {
 		    if (tryname[0] == '.' && tryname[1] == '/')
 			tryname += 2;
@@ -2860,7 +2926,7 @@ PP(pp_require)
 
     ENTER;
     SAVETMPS;
-    lex_start(sv_2mortal(newSVpv("",0)));
+    lex_start(sv_2mortal(newSVpvn("",0)));
     SAVEGENERICSV(PL_rsfp_filters);
     PL_rsfp_filters = Nullav;