X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=a16137279419338aaf81366fa9ccb6d7e47ffb5c;hb=8935ee17b2edadcfca0c196679b39cd0ade49541;hp=0dbab534a10ab88b9c0f3d8f9cd61bbedba51bb6;hpb=aea4f609175b8d3694278560443a821f9cb5265c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 0dbab53..a161372 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -91,7 +91,7 @@ PP(pp_regcomp)
     if (SvROK(tmpstr)) {
 	SV *sv = SvRV(tmpstr);
 	if(SvMAGICAL(sv))
-	    mg = mg_find(sv, 'r');
+	    mg = mg_find(sv, PERL_MAGIC_qr);
     }
     if (mg) {
 	regexp *re = (regexp *)mg->mg_obj;
@@ -164,7 +164,7 @@ PP(pp_substcont)
     register char *m = cx->sb_m;
     char *orig = cx->sb_orig;
     register REGEXP *rx = cx->sb_rx;
-    
+
     rxres_restore(&cx->sb_rxres, rx);
 
     if (cx->sb_iters++) {
@@ -227,9 +227,9 @@ PP(pp_substcont)
 	I32 i;
 	if (SvTYPE(sv) < SVt_PVMG)
 	    (void)SvUPGRADE(sv, SVt_PVMG);
-	if (!(mg = mg_find(sv, 'g'))) {
-	    sv_magic(sv, Nullsv, 'g', Nullch, 0);
-	    mg = mg_find(sv, 'g');
+	if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
+	    sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
+	    mg = mg_find(sv, PERL_MAGIC_regex_global);
 	}
 	i = m - orig;
 	if (DO_UTF8(sv))
@@ -312,18 +312,18 @@ PP(pp_formline)
     register char *s;
     register char *send;
     register I32 arg;
-    register SV *sv;
-    char *item;
-    I32 itemsize;
-    I32 fieldsize;
+    register SV *sv = Nullsv;
+    char *item = Nullch;
+    I32 itemsize  = 0;
+    I32 fieldsize = 0;
     I32 lines = 0;
     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
-    char *chophere;
-    char *linemark;
+    char *chophere = Nullch;
+    char *linemark = Nullch;
     NV value;
-    bool gotsome;
+    bool gotsome = FALSE;
     STRLEN len;
-    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
+    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
     bool item_is_utf = FALSE;
 
     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
@@ -373,7 +373,7 @@ PP(pp_formline)
 		PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 	    else
 		PerlIO_printf(Perl_debug_log, "%-16s\n", name);
-	} )
+	} );
 	switch (*fpc++) {
 	case FF_LINEMARK:
 	    linemark = t;
@@ -551,7 +551,13 @@ PP(pp_formline)
 	    if (item_is_utf) {
 		while (arg--) {
 		    if (UTF8_IS_CONTINUED(*s)) {
-			switch (UTF8SKIP(s)) {
+			STRLEN skip = UTF8SKIP(s);
+			switch (skip) {
+			default:
+			    Move(s,t,skip,char);
+			    s += skip;
+			    t += skip;
+			    break;
 			case 7: *t++ = *s++;
 			case 6: *t++ = *s++;
 			case 5: *t++ = *s++;
@@ -881,7 +887,7 @@ PP(pp_sort)
     register I32 max;
     HV *stash;
     GV *gv;
-    CV *cv;
+    CV *cv = 0;
     I32 gimme = GIMME;
     OP* nextop = PL_op->op_next;
     I32 overloading = 0;
@@ -1025,7 +1031,7 @@ PP(pp_sort)
 			? ( (PL_op->op_private & OPpSORT_INTEGER)
 			    ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
 			    : ( overloading ? amagic_ncmp : sv_ncmp))
-			: ( (PL_op->op_private & OPpLOCALE)
+			: ( IN_LOCALE_RUNTIME
 			    ? ( overloading
 				? amagic_cmp_locale
 				: sv_cmp_locale_static)
@@ -1073,7 +1079,7 @@ PP(pp_flip)
  	if (PL_op->op_private & OPpFLIP_LINENUM) {
  	    struct io *gp_io;
  	    flip = PL_last_in_gv
- 		&& (gp_io = GvIOp(PL_last_in_gv))
+ 		&& (gp_io = GvIO(PL_last_in_gv))
  		&& SvIV(sv) == (IV)IoLINES(gp_io);
  	} else {
  	    flip = SvTRUE(sv);
@@ -1154,7 +1160,8 @@ PP(pp_flop)
 	SV *targ = PAD_SV(cUNOP->op_first->op_targ);
 	sv_inc(targ);
 	if ((PL_op->op_private & OPpFLIP_LINENUM)
-	  ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
+	  ? (GvIO(PL_last_in_gv)
+	     && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
 	  : SvTRUE(sv) ) {
 	    sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
 	    sv_catpv(targ, "E0");
@@ -1380,41 +1387,6 @@ Perl_dounwind(pTHX_ I32 cxix)
     }
 }
 
-/*
- * Closures mentioned at top level of eval cannot be referenced
- * again, and their presence indirectly causes a memory leak.
- * (Note that the fact that compcv and friends are still set here
- * is, AFAIK, an accident.)  --Chip
- *
- * XXX need to get comppad et al from eval's cv rather than
- * relying on the incidental global values.
- */
-STATIC void
-S_free_closures(pTHX)
-{
-    SV **svp = AvARRAY(PL_comppad_name);
-    I32 ix;
-    for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
-	SV *sv = svp[ix];
-	if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
-	    SvREFCNT_dec(sv);
-	    svp[ix] = &PL_sv_undef;
-
-	    sv = PL_curpad[ix];
-	    if (CvCLONE(sv)) {
-		SvREFCNT_dec(CvOUTSIDE(sv));
-		CvOUTSIDE(sv) = Nullcv;
-	    }
-	    else {
-		SvREFCNT_dec(sv);
-		sv = NEWSV(0,0);
-		SvPADTMP_on(sv);
-		PL_curpad[ix] = sv;
-	    }
-	}
-    }
-}
-
 void
 Perl_qerror(pTHX_ SV *err)
 {
@@ -1462,10 +1434,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 	    }
 	    else {
 		sv_setpvn(ERRSV, message, msglen);
-		if (PL_hints & HINT_UTF8)
-		    SvUTF8_on(ERRSV);
-		else
-		    SvUTF8_off(ERRSV);
 	    }
 	}
 	else
@@ -1951,8 +1919,6 @@ PP(pp_return)
 	POPEVAL(cx);
 	if (CxTRYBLOCK(cx))
 	    break;
-	if (AvFILLp(PL_comppad_name) >= 0)
-	    free_closures();
 	lex_end();
 	if (optype == OP_REQUIRE &&
 	    (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
@@ -2260,7 +2226,7 @@ PP(pp_goto)
 	    if (cxix < cxstack_ix)
 		dounwind(cxix);
 	    TOPBLOCK(cx);
-	    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
+	    if (CxREALEVAL(cx))
 		DIE(aTHX_ "Can't goto subroutine from an eval-string");
 	    mark = PL_stack_sp;
 	    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
@@ -2491,6 +2457,8 @@ PP(pp_goto)
 
     if (label && *label) {
 	OP *gotoprobe = 0;
+	bool leaving_eval = FALSE;
+        PERL_CONTEXT *last_eval_cx = 0;
 
 	/* find label */
 
@@ -2500,8 +2468,15 @@ PP(pp_goto)
 	    cx = &cxstack[ix];
 	    switch (CxTYPE(cx)) {
 	    case CXt_EVAL:
-		gotoprobe = PL_eval_root; /* XXX not good for nested eval */
-		break;
+		leaving_eval = TRUE;
+                if (CxREALEVAL(cx)) {
+		    gotoprobe = (last_eval_cx ?
+				last_eval_cx->blk_eval.old_eval_root :
+				PL_eval_root);
+		    last_eval_cx = cx;
+		    break;
+                }
+                /* else fall through */
 	    case CXt_LOOP:
 		gotoprobe = cx->blk_oldcop->op_sibling;
 		break;
@@ -2539,6 +2514,17 @@ PP(pp_goto)
 	if (!retop)
 	    DIE(aTHX_ "Can't find label %s", label);
 
+	/* if we're leaving an eval, check before we pop any frames
+           that we're not going to punt, otherwise the error
+	   won't be caught */
+
+	if (leaving_eval && *enterops && enterops[1]) {
+	    I32 i;
+            for (i = 1; enterops[i]; i++)
+                if (enterops[i]->op_type == OP_ENTERITER)
+                    DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
+	}
+
 	/* pop unwanted frames */
 
 	if (ix < cxstack_ix) {
@@ -2877,7 +2863,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
 	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
     }
 
-    SAVEFREESV(PL_compcv);
+    SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
 
     /* make sure we compile in the right package */
 
@@ -3030,10 +3016,10 @@ PP(pp_require)
     SV *sv;
     char *name;
     STRLEN len;
-    char *tryname;
+    char *tryname = Nullch;
     SV *namesv = Nullsv;
     SV** svp;
-    I32 gimme = G_SCALAR;
+    I32 gimme = GIMME_V;
     PerlIO *tryrsfp = 0;
     STRLEN n_a;
     int filter_has_file = 0;
@@ -3043,19 +3029,19 @@ PP(pp_require)
 
     sv = POPs;
     if (SvNIOKp(sv)) {
-	if (SvPOK(sv) && SvNOK(sv)) {		/* require v5.6.1 */
+	if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {		/* require v5.6.1 */
 	    UV rev = 0, ver = 0, sver = 0;
 	    STRLEN len;
 	    U8 *s = (U8*)SvPVX(sv);
 	    U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
 	    if (s < end) {
-		rev = utf8_to_uv(s, end - s, &len, 0);
+		rev = utf8n_to_uvchr(s, end - s, &len, 0);
 		s += len;
 		if (s < end) {
-		    ver = utf8_to_uv(s, end - s, &len, 0);
+		    ver = utf8n_to_uvchr(s, end - s, &len, 0);
 		    s += len;
 		    if (s < end)
-			sver = utf8_to_uv(s, end - s, &len, 0);
+			sver = utf8n_to_uvchr(s, end - s, &len, 0);
 		}
 	    }
 	    if (PERL_REVISION < rev
@@ -3371,7 +3357,7 @@ trylocal: {
     PL_eval_owner = thr;
     MUTEX_UNLOCK(&PL_eval_mutex);
 #endif /* USE_THREADS */
-    return DOCATCH(doeval(G_SCALAR, NULL));
+    return DOCATCH(doeval(gimme, NULL));
 }
 
 PP(pp_dofile)
@@ -3507,9 +3493,6 @@ PP(pp_leaveeval)
     }
     PL_curpm = newpm;	/* Don't pop $1 et al till now */
 
-    if (AvFILLp(PL_comppad_name) >= 0)
-	free_closures();
-
 #ifdef DEBUGGING
     assert(CvDEPTH(PL_compcv) == 1);
 #endif
@@ -3546,7 +3529,6 @@ PP(pp_entertry)
     push_return(cLOGOP->op_other->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
     PUSHEVAL(cx, 0, 0);
-    PL_eval_root = PL_op;		/* Only needed so that goto works right. */
 
     PL_in_eval = EVAL_INEVAL;
     sv_setpv(ERRSV,"");
@@ -3607,14 +3589,14 @@ S_doparseform(pTHX_ SV *sv)
     STRLEN len;
     register char *s = SvPV_force(sv, len);
     register char *send = s + len;
-    register char *base;
+    register char *base = Nullch;
     register I32 skipspaces = 0;
-    bool noblank;
-    bool repeat;
+    bool noblank   = FALSE;
+    bool repeat    = FALSE;
     bool postspace = FALSE;
     U16 *fops;
     register U16 *fpc;
-    U16 *linepc;
+    U16 *linepc = 0;
     register I32 arg;
     bool ischop;
 
@@ -3793,7 +3775,7 @@ S_doparseform(pTHX_ SV *sv)
     }
     Copy(fops, s, arg, U16);
     Safefree(fops);
-    sv_magic(sv, Nullsv, 'f', Nullch, 0);
+    sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
     SvCOMPILED_on(sv);
 }