X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=f512832a30d9e922ff2f94cd75d8f665f74e1805;hb=76467b2a651c6c83b127a7ee5b8170cd17171b66;hp=e9771b9534a25a25b8abcf75f2662f015a3410ff;hpb=f1f66076265cc2bac3adabd54c01b0dea28ca3f0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index e9771b9..f512832 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -9,12 +9,14 @@
  */
 
 /*
- * Now far ahead the Road has gone,
- * And I must follow, if I can,
- * Pursuing it with eager feet,
- * Until it joins some larger way
- * Where many paths and errands meet.
- * And whither then?  I cannot say.
+ *      Now far ahead the Road has gone,
+ *          And I must follow, if I can,
+ *      Pursuing it with eager feet,
+ *          Until it joins some larger way
+ *      Where many paths and errands meet.
+ *          And whither then?  I cannot say.
+ *
+ *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  */
 
 /* This file contains control-oriented pp ("push/pop") functions that
@@ -355,8 +357,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
     }
 }
 
-void
-Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
+static void
+S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 {
     UV *p = (UV*)*rsp;
     U32 i;
@@ -385,8 +387,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
     }
 }
 
-void
-Perl_rxres_free(pTHX_ void **rsp)
+static void
+S_rxres_free(pTHX_ void **rsp)
 {
     UV * const p = (UV*)*rsp;
 
@@ -509,8 +511,7 @@ PP(pp_formline)
 	    if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 		SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 		*t = '\0';
-		sv_utf8_upgrade(PL_formtarget);
-		SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+		sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 		t = SvEND(PL_formtarget);
 		targ_is_utf8 = TRUE;
 	    }
@@ -693,8 +694,8 @@ PP(pp_formline)
 		    if (!targ_is_utf8) {
 			SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 			*t = '\0';
-			sv_utf8_upgrade(PL_formtarget);
-			SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+			sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
+								    fudge + 1);
 			t = SvEND(PL_formtarget);
 			targ_is_utf8 = TRUE;
 		    }
@@ -805,7 +806,7 @@ PP(pp_formline)
 				      t - SvPVX_const(PL_formtarget));
 			    targ_is_utf8 = TRUE;
 			    /* Don't need get magic.  */
-			    sv_utf8_upgrade_flags(PL_formtarget, 0);
+			    sv_utf8_upgrade_nomg(PL_formtarget);
 			} else {
 			    SvCUR_set(PL_formtarget,
 				      t - SvPVX_const(PL_formtarget));
@@ -986,7 +987,7 @@ PP(pp_grepstart)
     if (PL_op->op_private & OPpGREP_LEX)
 	PAD_SVl(PL_op->op_targ) = src;
     else
-	DEFSV = src;
+	DEFSV_set(src);
 
     PUTBACK;
     if (PL_op->op_type == OP_MAPSTART)
@@ -1097,7 +1098,7 @@ PP(pp_mapwhile)
 	if (PL_op->op_private & OPpGREP_LEX)
 	    PAD_SVl(PL_op->op_targ) = src;
 	else
-	    DEFSV = src;
+	    DEFSV_set(src);
 
 	RETURNOP(cLOGOP->op_other);
     }
@@ -1777,7 +1778,7 @@ PP(pp_caller)
 	    /* Get the bit mask for $warnings::Bits{all}, because
 	     * it could have been extended by warnings::register */
 	    SV **bits_all;
-	    HV * const bits = get_hv("warnings::Bits", FALSE);
+	    HV * const bits = get_hv("warnings::Bits", 0);
 	    if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
 		mask = newSVsv(*bits_all);
 	    }
@@ -2574,7 +2575,7 @@ PP(pp_goto)
 		if (PERLDB_SUB) {	/* Checking curstash breaks DProf. */
 		    Perl_get_db_sub(aTHX_ NULL, cv);
 		    if (PERLDB_GOTO) {
-			CV * const gotocv = get_cv("DB::goto", FALSE);
+			CV * const gotocv = get_cvs("DB::goto", 0);
 			if (gotocv) {
 			    PUSHMARK( PL_stack_sp );
 			    call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
@@ -2762,7 +2763,7 @@ S_save_lines(pTHX_ AV *array, SV *sv)
 	const char *t;
 	SV * const tmpstr = newSV_type(SVt_PVMG);
 
-	t = strchr(s, '\n');
+	t = (const char *)memchr(s, '\n', send - s);
 	if (t)
 	    t++;
 	else
@@ -3046,7 +3047,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 	    POPEVAL(cx);
 	}
 	lex_end();
-	LEAVE;
+	LEAVE; /* pp_entereval knows about this LEAVE.  */
 
 	msg = SvPVx_nolen_const(ERRSV);
 	if (optype == OP_REQUIRE) {
@@ -3097,7 +3098,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 
     /* Register with debugger: */
     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
-	CV * const cv = get_cv("DB::postponed", FALSE);
+	CV * const cv = get_cvs("DB::postponed", 0);
 	if (cv) {
 	    dSP;
 	    PUSHMARK(SP);
@@ -3651,18 +3652,14 @@ PP(pp_entereval)
     register PERL_CONTEXT *cx;
     SV *sv;
     const I32 gimme = GIMME_V;
-    const I32 was = PL_sub_generation;
+    const U32 was = PL_breakable_sub_gen;
     char tbuf[TYPE_DIGITS(long) + 12];
     char *tmpbuf = tbuf;
-    char *safestr;
     STRLEN len;
-    bool ok;
     CV* runcv;
     U32 seq;
     HV *saved_hh = NULL;
-    const char * const fakestr = "_<(eval )";
-    const int fakelen = 9 + 1;
-    
+
     if (PL_op->op_private & OPpEVAL_HAS_HH) {
 	saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
     }
@@ -3696,8 +3693,6 @@ PP(pp_entereval)
        (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 = savepvn(tmpbuf, len);
-    SAVEDELETE(PL_defstash, safestr, len);
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
     if (saved_hh)
@@ -3726,17 +3721,32 @@ PP(pp_entereval)
 
     /* prepare to compile string */
 
-    if (PERLDB_SAVESRC && PL_curstash != PL_debstash)
+    if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
 	save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
     PUTBACK;
-    ok = doeval(gimme, NULL, runcv, seq);
-    if ((PERLDB_LINE || PERLDB_SAVESRC)
-	&& was != (I32)PL_sub_generation /* Some subs defined here. */
-	&& ok) {
-	/* Copy in anything fake and short. */
-	my_strlcpy(safestr, fakestr, fakelen);
-    }
-    return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
+
+    if (doeval(gimme, NULL, runcv, seq)) {
+	if (was != PL_breakable_sub_gen /* Some subs defined here. */
+	    ? (PERLDB_LINE || PERLDB_SAVESRC)
+	    :  PERLDB_SAVESRC_NOSUBS) {
+	    /* Retain the filegv we created.  */
+	} else {
+	    char *const safestr = savepvn(tmpbuf, len);
+	    SAVEDELETE(PL_defstash, safestr, len);
+	}
+	return DOCATCH(PL_eval_start);
+    } else {
+	/* We have already left the scope set up earler thanks to the LEAVE
+	   in doeval().  */
+	if (was != PL_breakable_sub_gen /* Some subs defined here. */
+	    ? (PERLDB_LINE || PERLDB_SAVESRC)
+	    :  PERLDB_SAVESRC_INVALID) {
+	    /* Retain the filegv we created.  */
+	} else {
+	    (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
+	}
+	return PL_op->op_next;
+    }
 }
 
 PP(pp_leaveeval)
@@ -4077,8 +4087,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     if (SvGMAGICAL(e))
 	e = sv_mortalcopy(e);
 
-    if (SM_OBJECT)
-	Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+    if (SM_OBJECT) {
+	if (!SvOK(d) || !SvOK(e))
+	    RETPUSHNO;
+	else
+	    Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+    }
 
     if (SM_CV_NEP) {
 	I32 c;
@@ -4820,7 +4834,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 	SAVETMPS;
 	EXTEND(SP, 2);
 
-	DEFSV = upstream;
+	DEFSV_set(upstream);
 	PUSHMARK(SP);
 	mPUSHi(0);
 	if (filter_state) {