X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=b2e43a72890923a21d52354d4bf5b38389343347;hb=0ee1060bc7f323c193867d7f04e45058f219516b;hp=fbd533eac203bc0e216d3a9a7a5ef30e06ce02b7;hpb=9d4ba2ae61ff15b15f3e889810ff89dfb2ed1738;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index fbd533e..b2e43a7 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -122,7 +122,7 @@ PP(pp_regcomp)
 	    mg = mg_find(sv, PERL_MAGIC_qr);
     }
     if (mg) {
-	regexp *re = (regexp *)mg->mg_obj;
+	regexp * const re = (regexp *)mg->mg_obj;
 	ReREFCNT_dec(PM_GETRE(pm));
 	PM_SETRE(pm, ReREFCNT_inc(re));
     }
@@ -204,7 +204,7 @@ PP(pp_substcont)
     }
 
     rxres_restore(&cx->sb_rxres, rx);
-    RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
+    RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 
     if (cx->sb_iters++) {
 	const I32 saviters = cx->sb_iters;
@@ -280,7 +280,7 @@ PP(pp_substcont)
     }
     cx->sb_s = rx->endp[0] + orig;
     { /* Update the pos() information. */
-	SV *sv = cx->sb_targ;
+	SV * const sv = cx->sb_targ;
 	MAGIC *mg;
 	I32 i;
 	if (SvTYPE(sv) < SVt_PVMG)
@@ -314,7 +314,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 	i = 6 + rx->nparens * 2;
 #endif
 	if (!p)
-	    New(501, p, i, UV);
+	    Newx(p, i, UV);
 	else
 	    Renew(p, i, UV);
 	*rsp = (void*)p;
@@ -368,7 +368,7 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 void
 Perl_rxres_free(pTHX_ void **rsp)
 {
-    UV *p = (UV*)*rsp;
+    UV * const p = (UV*)*rsp;
 
     if (p) {
 #ifdef PERL_POISON
@@ -1075,7 +1075,7 @@ PP(pp_flip)
     }
     else {
 	dTOPss;
-	SV *targ = PAD_SV(PL_op->op_targ);
+	SV * const targ = PAD_SV(PL_op->op_targ);
 	int flip = 0;
 
 	if (PL_op->op_private & OPpFLIP_LINENUM) {
@@ -1083,8 +1083,9 @@ PP(pp_flip)
 		flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 	    }
 	    else {
-		GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
-		if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
+		GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
+		if (gv && GvSV(gv))
+		    flip = SvIV(sv) == SvIV(GvSV(gv));
 	    }
 	} else {
 	    flip = SvTRUE(sv);
@@ -1126,10 +1127,8 @@ PP(pp_flop)
     if (GIMME == G_ARRAY) {
 	dPOPPOPssrl;
 
-	if (SvGMAGICAL(left))
-	    mg_get(left);
-	if (SvGMAGICAL(right))
-	    mg_get(right);
+	SvGETMAGIC(left);
+	SvGETMAGIC(right);
 
 	if (RANGE_IS_NUMERIC(left,right)) {
 	    register IV i, j;
@@ -1152,7 +1151,7 @@ PP(pp_flop)
 	    }
 	}
 	else {
-	    SV *final = sv_mortalcopy(right);
+	    SV * const final = sv_mortalcopy(right);
 	    STRLEN len;
 	    const char *tmps = SvPV_const(final, len);
 
@@ -1408,7 +1407,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen)
 	if (message) {
 	    if (PL_in_eval & EVAL_KEEPERR) {
                 static const char prefix[] = "\t(in cleanup) ";
-		SV *err = ERRSV;
+		SV * const err = ERRSV;
                 const char *e = Nullch;
 		if (!SvPOK(err))
 		    sv_setpvn(err,"",0);
@@ -1472,7 +1471,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen)
 	    PL_curcop = cx->blk_oldcop;
 
 	    if (optype == OP_REQUIRE) {
-                const char* msg = SvPVx_nolen_const(ERRSV);
+                const char* const msg = SvPVx_nolen_const(ERRSV);
 		SV * const nsv = cx->blk_eval.old_namesv;
                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                                &PL_sv_undef, 0);
@@ -1543,8 +1542,7 @@ PP(pp_dorassign)
 	    RETURN;
 	break;
     default:
-	if (SvGMAGICAL(sv))
-	    mg_get(sv);
+	SvGETMAGIC(sv);
 	if (SvOK(sv))
 	    RETURN;
     }
@@ -1774,12 +1772,24 @@ PP(pp_dbstate)
 	hasargs = 0;
 	SPAGAIN;
 
-	PUSHBLOCK(cx, CXt_SUB, SP);
-	PUSHSUB_DB(cx);
-	cx->blk_sub.retop = PL_op->op_next;
-	CvDEPTH(cv)++;
-	PAD_SET_CUR(CvPADLIST(cv),1);
-	RETURNOP(CvSTART(cv));
+	if (CvXSUB(cv)) {
+	    CvDEPTH(cv)++;
+	    PUSHMARK(SP);
+	    (void)(*CvXSUB(cv))(aTHX_ cv);
+	    CvDEPTH(cv)--;
+	    FREETMPS;
+	    LEAVE;
+	    return NORMAL;
+	}
+	else {
+	    PUSHBLOCK(cx, CXt_SUB, SP);
+	    PUSHSUB_DB(cx);
+	    cx->blk_sub.retop = PL_op->op_next;
+	    CvDEPTH(cv)++;
+	    SAVECOMPPAD();
+	    PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
+	    RETURNOP(CvSTART(cv));
+	}
     }
     else
 	return NORMAL;
@@ -1842,12 +1852,18 @@ PP(pp_enteriter)
 	if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
 	    dPOPss;
 	    SV *right = (SV*)cx->blk_loop.iterary;
+	    SvGETMAGIC(sv);
+	    SvGETMAGIC(right);
 	    if (RANGE_IS_NUMERIC(sv,right)) {
 		if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
 		    (SvOK(right) && SvNV(right) >= IV_MAX))
 		    DIE(aTHX_ "Range iterator outside integer range");
 		cx->blk_loop.iterix = SvIV(sv);
 		cx->blk_loop.itermax = SvIV(right);
+#ifdef DEBUGGING
+		/* for correct -Dstv display */
+		cx->blk_oldsp = sp - PL_stack_base;
+#endif
 	    }
 	    else {
 		cx->blk_loop.iterlval = newSVsv(sv);
@@ -2209,7 +2225,6 @@ PP(pp_redo)
 STATIC OP *
 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
 {
-    OP *kid = Nullop;
     OP **ops = opstack;
     static const char too_deep[] = "Target of goto is too deeply nested";
 
@@ -2227,6 +2242,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
     }
     *ops = 0;
     if (o->op_flags & OPf_KIDS) {
+	OP *kid;
 	/* First try all the kids at this level, since that's likeliest. */
 	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 	    if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
@@ -2342,8 +2358,7 @@ PP(pp_goto)
 		}
 	    }
 	    else if (CvXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
-		AV* av;
-		av = GvAV(PL_defgv);
+		AV* const av = GvAV(PL_defgv);
 		items = AvFILLp(av) + 1;
 		EXTEND(SP, items+1); /* @_ could have been extended. */
 		Copy(AvARRAY(av), SP + 1, items, SV*);
@@ -2417,7 +2432,8 @@ PP(pp_goto)
 			sub_crush_depth(cv);
 		    pad_push(padlist, CvDEPTH(cv));
 		}
-		PAD_SET_CUR(padlist, CvDEPTH(cv));
+		SAVECOMPPAD();
+		PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
 		if (cx->blk_sub.hasargs)
 		{
 		    AV* av = (AV*)PAD_SVl(0);
@@ -2461,12 +2477,12 @@ PP(pp_goto)
 		     * We do not care about using sv to call CV;
 		     * it's for informational purposes only.
 		     */
-		    SV *sv = GvSV(PL_DBsub);
+		    SV * const sv = GvSV(PL_DBsub);
 		    CV *gotocv;
 
 		    save_item(sv);
 		    if (PERLDB_SUB_NN) {
-			int type = SvTYPE(sv);
+			const int type = SvTYPE(sv);
 			if (type < SVt_PVIV && type != SVt_IV)
 			    sv_upgrade(sv, SVt_PVIV);
 			(void)SvIOK_on(sv);
@@ -2682,12 +2698,12 @@ STATIC void
 S_save_lines(pTHX_ AV *array, SV *sv)
 {
     const char *s = SvPVX_const(sv);
-    const char *send = SvPVX_const(sv) + SvCUR(sv);
+    const char * const send = SvPVX_const(sv) + SvCUR(sv);
     I32 line = 1;
 
     while (s && s < send) {
 	const char *t;
-	SV *tmpstr = NEWSV(85,0);
+	SV * const tmpstr = NEWSV(85,0);
 
 	sv_upgrade(tmpstr, SVt_PVMG);
 	t = strchr(s, '\n');
@@ -2768,7 +2784,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     dVAR; dSP;				/* Make POPBLOCK work. */
     PERL_CONTEXT *cx;
     SV **newsp;
-    I32 gimme;
+    I32 gimme = G_VOID;
     I32 optype;
     OP dummy;
     OP *rop;
@@ -2857,7 +2873,7 @@ Locate the CV corresponding to the currently executing sub or eval.
 If db_seqp is non_null, skip CVs that are in the DB package and populate
 *db_seqp with the cop sequence number at the point that the DB:: code was
 entered. (allows debuggers to eval in the scope of the breakpoint rather
-than in in the scope of the debugger itself).
+than in the scope of the debugger itself).
 
 =cut
 */
@@ -2901,7 +2917,7 @@ STATIC OP *
 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 {
     dVAR; dSP;
-    OP *saveop = PL_op;
+    OP * const saveop = PL_op;
 
     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
 		  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
@@ -3013,7 +3029,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 
     /* Register with debugger: */
     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
-	CV *cv = get_cv("DB::postponed", FALSE);
+	CV * const cv = get_cv("DB::postponed", FALSE);
 	if (cv) {
 	    dSP;
 	    PUSHMARK(SP);
@@ -3078,7 +3094,6 @@ PP(pp_require)
     STRLEN len;
     const char *tryname = Nullch;
     SV *namesv = Nullsv;
-    SV** svp;
     const I32 gimme = GIMME_V;
     PerlIO *tryrsfp = 0;
     int filter_has_file = 0;
@@ -3098,9 +3113,16 @@ PP(pp_require)
 	sv = new_version(sv);
 	if (!sv_derived_from(PL_patchlevel, "version"))
 	    (void *)upg_version(PL_patchlevel);
-	if ( vcmp(sv,PL_patchlevel) > 0 )
-	    DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
-		vnormal(sv), vnormal(PL_patchlevel));
+	if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
+	    if ( vcmp(sv,PL_patchlevel) < 0 )
+		DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
+		    vnormal(sv), vnormal(PL_patchlevel));
+	}
+	else {
+	    if ( vcmp(sv,PL_patchlevel) > 0 )
+		DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
+		    vnormal(sv), vnormal(PL_patchlevel));
+	}
 
 	    RETPUSHYES;
     }
@@ -3108,12 +3130,14 @@ PP(pp_require)
     if (!(name && len > 0 && *name))
 	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
-    if (PL_op->op_type == OP_REQUIRE &&
-       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
-       if (*svp != &PL_sv_undef)
-           RETPUSHYES;
-       else
-           DIE(aTHX_ "Compilation failed in require");
+    if (PL_op->op_type == OP_REQUIRE) {
+	SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if ( svp ) {
+	    if (*svp != &PL_sv_undef)
+		RETPUSHYES;
+	    else
+		DIE(aTHX_ "Compilation failed in require");
+	}
     }
 
     /* prepare to compile file */
@@ -3134,7 +3158,7 @@ PP(pp_require)
     }
 #endif
     if (!tryrsfp) {
-	AV *ar = GvAVn(PL_incgv);
+	AV * const ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
 	char *unixname;
@@ -3316,25 +3340,32 @@ PP(pp_require)
     if (!tryrsfp) {
 	if (PL_op->op_type == OP_REQUIRE) {
 	    const char *msgstr = name;
-	    if (namesv) {			/* did we lookup @INC? */
-		SV *msg = sv_2mortal(newSVpv(msgstr,0));
-		SV *dirmsgsv = NEWSV(0, 0);
-		AV *ar = GvAVn(PL_incgv);
-		I32 i;
-		sv_catpvn(msg, " in @INC", 8);
-		if (instr(SvPVX_const(msg), ".h "))
-		    sv_catpv(msg, " (change .h to .ph maybe?)");
-		if (instr(SvPVX_const(msg), ".ph "))
-		    sv_catpv(msg, " (did you run h2ph?)");
-		sv_catpv(msg, " (@INC contains:");
-		for (i = 0; i <= AvFILL(ar); i++) {
-		    const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
-		    Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
-		    sv_catsv(msg, dirmsgsv);
-		}
-		sv_catpvn(msg, ")", 1);
-		SvREFCNT_dec(dirmsgsv);
+	    if(errno == EMFILE) {
+		SV * const msg = sv_2mortal(newSVpv(msgstr,0));
+		sv_catpv(msg, ":  "); 
+		sv_catpv(msg, Strerror(errno));
 		msgstr = SvPV_nolen_const(msg);
+	    } else {
+	        if (namesv) {			/* did we lookup @INC? */
+		    SV * const msg = sv_2mortal(newSVpv(msgstr,0));
+		    SV * const dirmsgsv = NEWSV(0, 0);
+		    AV * const ar = GvAVn(PL_incgv);
+		    I32 i;
+		    sv_catpvn(msg, " in @INC", 8);
+		    if (instr(SvPVX_const(msg), ".h "))
+		        sv_catpv(msg, " (change .h to .ph maybe?)");
+		    if (instr(SvPVX_const(msg), ".ph "))
+		        sv_catpv(msg, " (did you run h2ph?)");
+		    sv_catpv(msg, " (@INC contains:");
+		    for (i = 0; i <= AvFILL(ar); i++) {
+		        const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
+		        Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
+		        sv_catsv(msg, dirmsgsv);
+		    }
+		    sv_catpvn(msg, ")", 1);
+		    SvREFCNT_dec(dirmsgsv);
+		    msgstr = SvPV_nolen_const(msg);
+		}    
 	    }
 	    DIE(aTHX_ "Can't locate %s", msgstr);
 	}
@@ -3347,11 +3378,12 @@ PP(pp_require)
     /* Assume success here to prevent recursive requirement. */
     len = strlen(name);
     /* Check whether a hook in @INC has already filled %INC */
-    if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
-	(void)hv_store(GvHVn(PL_incgv), name, len,
-		       (hook_sv ? SvREFCNT_inc(hook_sv)
-				: newSVpv(CopFILE(&PL_compiling), 0)),
-		       0 );
+    if (!hook_sv) {
+	(void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+    } else {
+	SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if (!svp)
+	    (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
     }
 
     ENTER;
@@ -3376,7 +3408,7 @@ PP(pp_require)
     PL_compiling.cop_io = Nullsv;
 
     if (filter_sub || filter_child_proc) {
-	SV *datasv = filter_add(run_user_filter, Nullsv);
+	SV * const datasv = filter_add(run_user_filter, Nullsv);
 	IoLINES(datasv) = filter_has_file;
 	IoFMT_GV(datasv) = (GV *)filter_child_proc;
 	IoTOP_GV(datasv) = (GV *)filter_state;
@@ -3415,7 +3447,8 @@ PP(pp_entereval)
     dVAR; dSP;
     register PERL_CONTEXT *cx;
     dPOPss;
-    const I32 gimme = GIMME_V, was = PL_sub_generation;
+    const I32 gimme = GIMME_V;
+    const I32 was = PL_sub_generation;
     char tbuf[TYPE_DIGITS(long) + 12];
     char *tmpbuf = tbuf;
     char *safestr;
@@ -3435,7 +3468,7 @@ PP(pp_entereval)
     /* switch to eval mode */
 
     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
-	SV *sv = sv_newmortal();
+	SV * const sv = sv_newmortal();
 	Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
 		       (unsigned long)++PL_evalseq,
 		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
@@ -3658,7 +3691,7 @@ S_doparseform(pTHX_ SV *sv)
     s = base;
     base = Nullch;
 
-    New(804, fops, maxops, U32);
+    Newx(fops, maxops, U32);
     fpc = fops;
 
     if (s < send) {