X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=261b1be2e2c865f4b50669a8f0bff857de5be868;hb=206957a79d0bac91e0b2fccc7ef76f95e8df245e;hp=20df1342a5d407c8ccce185b287ddec7a04973a5;hpb=493b0a3c46c2cc9f06bf88c450ded6aa981c4fd3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index 20df134..261b1be 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -231,7 +231,6 @@ PP(pp_substcont)
 	if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 	    cx->sb_rxtainted |= 2;
 	sv_catsv(dstr, POPs);
-	FREETMPS; /* Prevent excess tmp stack */
 
 	/* Are we done */
 	if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
@@ -298,7 +297,6 @@ PP(pp_substcont)
     { /* Update the pos() information. */
 	SV * const sv = cx->sb_targ;
 	MAGIC *mg;
-	I32 i;
 	SvUPGRADE(sv, SVt_PVMG);
 	if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 #ifdef PERL_OLD_COPY_ON_WRITE
@@ -308,10 +306,7 @@ PP(pp_substcont)
 	    mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 			     NULL, 0);
 	}
-	i = m - orig;
-	if (DO_UTF8(sv))
-	    sv_pos_b2u(sv, &i);
-	mg->mg_len = i;
+	mg->mg_len = m - orig;
     }
     if (old != rx)
 	(void)ReREFCNT_inc(rx);
@@ -325,6 +320,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 {
     UV *p = (UV*)*rsp;
     U32 i;
+
+    PERL_ARGS_ASSERT_RXRES_SAVE;
     PERL_UNUSED_CONTEXT;
 
     if (!p || p[1] < RX_NPARENS(rx)) {
@@ -363,6 +360,8 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 {
     UV *p = (UV*)*rsp;
     U32 i;
+
+    PERL_ARGS_ASSERT_RXRES_RESTORE;
     PERL_UNUSED_CONTEXT;
 
     RX_MATCH_COPY_FREE(rx);
@@ -390,6 +389,8 @@ void
 Perl_rxres_free(pTHX_ void **rsp)
 {
     UV * const p = (UV*)*rsp;
+
+    PERL_ARGS_ASSERT_RXRES_FREE;
     PERL_UNUSED_CONTEXT;
 
     if (p) {
@@ -1224,14 +1225,17 @@ PP(pp_flop)
 
 static const char * const context_name[] = {
     "pseudo-block",
+    "when",
+    NULL, /* CXt_BLOCK never actually needs "block" */
+    "given",
+    NULL, /* CXt_LOOP_FOR never actually needs "loop" */
+    NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
+    NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
+    NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
     "subroutine",
+    "format",
     "eval",
-    "loop",
     "substitution",
-    "block",
-    "format",
-    "given",
-    "when"
 };
 
 STATIC I32
@@ -1240,6 +1244,8 @@ S_dopoptolabel(pTHX_ const char *label)
     dVAR;
     register I32 i;
 
+    PERL_ARGS_ASSERT_DOPOPTOLABEL;
+
     for (i = cxstack_ix; i >= 0; i--) {
 	register const PERL_CONTEXT * const cx = &cxstack[i];
 	switch (CxTYPE(cx)) {
@@ -1257,7 +1263,7 @@ S_dopoptolabel(pTHX_ const char *label)
 		return -1;
 	    break;
 	case CXt_LOOP_LAZYIV:
-	case CXt_LOOP_STACK:
+	case CXt_LOOP_LAZYSV:
 	case CXt_LOOP_FOR:
 	case CXt_LOOP_PLAIN:
 	    if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
@@ -1322,6 +1328,9 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
 {
     dVAR;
     I32 i;
+
+    PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
+
     for (i = startingblock; i >= 0; i--) {
 	register const PERL_CONTEXT * const cx = &cxstk[i];
 	switch (CxTYPE(cx)) {
@@ -1375,7 +1384,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 		return -1;
 	    break;
 	case CXt_LOOP_LAZYIV:
-	case CXt_LOOP_STACK:
+	case CXt_LOOP_LAZYSV:
 	case CXt_LOOP_FOR:
 	case CXt_LOOP_PLAIN:
 	    DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
@@ -1402,7 +1411,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
 	    assert(!CxFOREACHDEF(cx));
 	    break;
 	case CXt_LOOP_LAZYIV:
-	case CXt_LOOP_STACK:
+	case CXt_LOOP_LAZYSV:
 	case CXt_LOOP_FOR:
 	    if (CxFOREACHDEF(cx)) {
 		DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
@@ -1455,7 +1464,7 @@ Perl_dounwind(pTHX_ I32 cxix)
 	    POPEVAL(cx);
 	    break;
 	case CXt_LOOP_LAZYIV:
-	case CXt_LOOP_STACK:
+	case CXt_LOOP_LAZYSV:
 	case CXt_LOOP_FOR:
 	case CXt_LOOP_PLAIN:
 	    POPLOOP(cx);
@@ -1475,6 +1484,9 @@ void
 Perl_qerror(pTHX_ SV *err)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_QERROR;
+
     if (PL_in_eval)
 	sv_catsv(ERRSV, err);
     else if (PL_errors)
@@ -1835,9 +1847,9 @@ PP(pp_enteriter)
     register PERL_CONTEXT *cx;
     const I32 gimme = GIMME_V;
     SV **svp;
-    U16 cxtype = 0;
+    U8 cxtype = CXt_LOOP_FOR;
 #ifdef USE_ITHREADS
-    void *iterdata;
+    PAD *iterdata;
 #endif
 
     ENTER;
@@ -1849,13 +1861,11 @@ PP(pp_enteriter)
 	    SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
 		    SVs_PADSTALE, SVs_PADSTALE);
 	}
+	SAVEPADSVANDMORTALIZE(PL_op->op_targ);
 #ifndef USE_ITHREADS
 	svp = &PAD_SVl(PL_op->op_targ);		/* "my" variable */
-	SAVESPTR(*svp);
 #else
-	SAVEPADSV(PL_op->op_targ);
-	iterdata = INT2PTR(void*, PL_op->op_targ);
-	cxtype |= CXp_PADVAR;
+	iterdata = NULL;
 #endif
     }
     else {
@@ -1864,7 +1874,7 @@ PP(pp_enteriter)
 	SAVEGENERICSV(*svp);
 	*svp = newSV(0);
 #ifdef USE_ITHREADS
-	iterdata = (void*)gv;
+	iterdata = (PAD*)gv;
 #endif
     }
 
@@ -1873,21 +1883,21 @@ PP(pp_enteriter)
 
     ENTER;
 
-    cxtype |= (PL_op->op_flags & OPf_STACKED) ? CXt_LOOP_FOR : CXt_LOOP_STACK;
     PUSHBLOCK(cx, cxtype, SP);
 #ifdef USE_ITHREADS
-    PUSHLOOP_FOR(cx, iterdata, MARK);
+    PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
 #else
-    PUSHLOOP_FOR(cx, svp, MARK);
+    PUSHLOOP_FOR(cx, svp, MARK, 0);
 #endif
     if (PL_op->op_flags & OPf_STACKED) {
-	cx->blk_loop.ary_min_u.iterary = (AV*)SvREFCNT_inc(POPs);
-	if (SvTYPE(cx->blk_loop.ary_min_u.iterary) != SVt_PVAV) {
+	SV *maybe_ary = POPs;
+	if (SvTYPE(maybe_ary) != SVt_PVAV) {
 	    dPOPss;
-	    SV * const right = (SV*)cx->blk_loop.ary_min_u.iterary;
+	    SV * const right = maybe_ary;
 	    SvGETMAGIC(sv);
 	    SvGETMAGIC(right);
 	    if (RANGE_IS_NUMERIC(sv,right)) {
+		cx->cx_type &= ~CXTYPEMASK;
 		cx->cx_type |= CXt_LOOP_LAZYIV;
 		/* Make sure that no-one re-orders cop.h and breaks our
 		   assumptions */
@@ -1912,31 +1922,50 @@ PP(pp_enteriter)
 					 (SvNV(right) > (NV)UV_MAX))))))
 #endif
 		    DIE(aTHX_ "Range iterator outside integer range");
-		cx->blk_loop.iterix = SvIV(sv);
-		cx->blk_loop.lval_max_u.itermax = SvIV(right);
+		cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
+		cx->blk_loop.state_u.lazyiv.end = SvIV(right);
 #ifdef DEBUGGING
 		/* for correct -Dstv display */
 		cx->blk_oldsp = sp - PL_stack_base;
 #endif
 	    }
 	    else {
-		cx->blk_loop.lval_max_u.iterlval = newSVsv(sv);
-		(void) SvPV_force_nolen(cx->blk_loop.lval_max_u.iterlval);
+		cx->cx_type &= ~CXTYPEMASK;
+		cx->cx_type |= CXt_LOOP_LAZYSV;
+		/* Make sure that no-one re-orders cop.h and breaks our
+		   assumptions */
+		assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
+		cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
+		cx->blk_loop.state_u.lazysv.end = right;
+		SvREFCNT_inc(right);
+		(void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
+		/* This will do the upgrade to SVt_PV, and warn if the value
+		   is uninitialised.  */
 		(void) SvPV_nolen_const(right);
+		/* Doing this avoids a check every time in pp_iter in pp_hot.c
+		   to replace !SvOK() with a pointer to "".  */
+		if (!SvOK(right)) {
+		    SvREFCNT_dec(right);
+		    cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
+		}
 	    }
 	}
-	else if (PL_op->op_private & OPpITER_REVERSED) {
-	    cx->blk_loop.iterix = AvFILL(cx->blk_loop.ary_min_u.iterary) + 1;
-
+	else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
+	    cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
+	    SvREFCNT_inc(maybe_ary);
+	    cx->blk_loop.state_u.ary.ix =
+		(PL_op->op_private & OPpITER_REVERSED) ?
+		AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
+		-1;
 	}
     }
-    else {
+    else { /* iterating over items on the stack */
+	cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
 	if (PL_op->op_private & OPpITER_REVERSED) {
-	    cx->blk_loop.ary_min_u.itermin = MARK - PL_stack_base + 1;
-	    cx->blk_loop.iterix = cx->blk_oldsp + 1;
+	    cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
 	}
 	else {
-	    cx->blk_loop.iterix = MARK - PL_stack_base;
+	    cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
 	}
     }
 
@@ -2157,7 +2186,7 @@ PP(pp_last)
     mark = newsp;
     switch (CxTYPE(cx)) {
     case CXt_LOOP_LAZYIV:
-    case CXt_LOOP_STACK:
+    case CXt_LOOP_LAZYSV:
     case CXt_LOOP_FOR:
     case CXt_LOOP_PLAIN:
 	pop2 = CxTYPE(cx);
@@ -2204,7 +2233,7 @@ PP(pp_last)
     switch (pop2) {
     case CXt_LOOP_LAZYIV:
     case CXt_LOOP_PLAIN:
-    case CXt_LOOP_STACK:
+    case CXt_LOOP_LAZYSV:
     case CXt_LOOP_FOR:
 	POPLOOP(cx);	/* release loop vars ... */
 	LEAVE;
@@ -2295,6 +2324,8 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
     OP **ops = opstack;
     static const char too_deep[] = "Target of goto is too deeply nested";
 
+    PERL_ARGS_ASSERT_DOFINDLABEL;
+
     if (ops >= oplimit)
 	Perl_croak(aTHX_ too_deep);
     if (o->op_type == OP_LEAVE ||
@@ -2313,7 +2344,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
 	/* 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) &&
-		    kCOP->cop_label && strEQ(kCOP->cop_label, label))
+		    CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
 		return kid;
 	}
 	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
@@ -2564,7 +2595,7 @@ PP(pp_goto)
                 }
                 /* else fall through */
 	    case CXt_LOOP_LAZYIV:
-	    case CXt_LOOP_STACK:
+	    case CXt_LOOP_LAZYSV:
 	    case CXt_LOOP_FOR:
 	    case CXt_LOOP_PLAIN:
 		gotoprobe = cx->blk_oldcop->op_sibling;
@@ -2698,6 +2729,8 @@ S_save_lines(pTHX_ AV *array, SV *sv)
     const char * const send = SvPVX_const(sv) + SvCUR(sv);
     I32 line = 1;
 
+    PERL_ARGS_ASSERT_SAVE_LINES;
+
     while (s && s < send) {
 	const char *t;
 	SV * const tmpstr = newSV_type(SVt_PVMG);
@@ -2785,6 +2818,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     CV* runcv = NULL;	/* initialise to avoid compiler warnings */
     STRLEN len;
 
+    PERL_ARGS_ASSERT_SV_COMPILE_2OP;
+
     ENTER;
     lex_start(sv, NULL, FALSE);
     SAVETMPS;
@@ -2832,7 +2867,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;			/* Avoid uninit warning. */
     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
-    PUSHEVAL(cx, 0, NULL);
+    PUSHEVAL(cx, 0);
 
     if (runtime)
 	(void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
@@ -3065,6 +3100,8 @@ S_check_type_and_open(pTHX_ const char *name)
     Stat_t st;
     const int st_rc = PerlLIO_stat(name, &st);
 
+    PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
+
     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
 	return NULL;
     }
@@ -3078,6 +3115,8 @@ S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
 {
     PerlIO *fp;
 
+    PERL_ARGS_ASSERT_DOOPEN_PM;
+
     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
 	SV *const pmcsv = newSV(namelen + 2);
 	char *const pmc = SvPVX(pmcsv);
@@ -3520,6 +3559,11 @@ PP(pp_require)
 
     SAVEHINTS();
     PL_hints = 0;
+    if (PL_compiling.cop_hints_hash) {
+	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+	PL_compiling.cop_hints_hash = NULL;
+    }
+
     SAVECOMPILEWARNINGS();
     if (PL_dowarn & G_WARN_ALL_ON)
         PL_compiling.cop_warnings = pWARN_ALL ;
@@ -3538,7 +3582,7 @@ PP(pp_require)
 
     /* switch to eval mode */
     PUSHBLOCK(cx, CXt_EVAL, SP);
-    PUSHEVAL(cx, name, NULL);
+    PUSHEVAL(cx, name);
     cx->blk_eval.retop = PL_op->op_next;
 
     SAVECOPLINE(&PL_compiling);
@@ -3561,6 +3605,19 @@ PP(pp_require)
     return op;
 }
 
+/* This is a op added to hold the hints hash for
+   pp_entereval. The hash can be modified by the code
+   being eval'ed, so we return a copy instead. */
+
+PP(pp_hintseval)
+{
+    dVAR;
+    dSP;
+    mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
+    RETURN;
+}
+
+
 PP(pp_entereval)
 {
     dVAR; dSP;
@@ -3637,7 +3694,7 @@ PP(pp_entereval)
     runcv = find_runcv(&seq);
 
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
-    PUSHEVAL(cx, 0, NULL);
+    PUSHEVAL(cx, 0);
     cx->blk_eval.retop = PL_op->op_next;
 
     /* prepare to compile string */
@@ -3754,7 +3811,7 @@ Perl_create_eval_scope(pTHX_ U32 flags)
     SAVETMPS;
 
     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
-    PUSHEVAL(cx, 0, 0);
+    PUSHEVAL(cx, 0);
 
     PL_in_eval = EVAL_INEVAL;
     if (flags & G_KEEPERR)
@@ -3874,8 +3931,11 @@ S_make_matcher(pTHX_ REGEXP *re)
 {
     dVAR;
     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+
+    PERL_ARGS_ASSERT_MAKE_MATCHER;
+
     PM_SETRE(matcher, ReREFCNT_inc(re));
-    
+
     SAVEFREEOP((OP *) matcher);
     ENTER; SAVETMPS;
     SAVEOP();
@@ -3887,6 +3947,8 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
 {
     dVAR;
     dSP;
+
+    PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
     
     PL_op = (OP *) matcher;
     XPUSHs(sv);
@@ -3900,7 +3962,10 @@ STATIC void
 S_destroy_matcher(pTHX_ PMOP *matcher)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_DESTROY_MATCHER;
     PERL_UNUSED_ARG(matcher);
+
     FREETMPS;
     LEAVE;
 }
@@ -3947,6 +4012,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	&& (Other = d))	)
 	
 
+#   define SM_OBJECT ( \
+	   (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))		\
+    ||									\
+	   (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )	\
+
 #   define SM_OTHER_REF(type) \
 	(SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
 
@@ -3978,6 +4048,9 @@ 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_CV_NEP) {
 	I32 c;
 	
@@ -4404,6 +4477,8 @@ S_doparseform(pTHX_ SV *sv)
     bool unchopnum = FALSE;
     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
 
+    PERL_ARGS_ASSERT_DOPARSEFORM;
+
     if (len == 0)
 	Perl_croak(aTHX_ "Null picture in formline");
 
@@ -4646,6 +4721,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
     bool read_from_cache = FALSE;
     STRLEN umaxlen;
 
+    PERL_ARGS_ASSERT_RUN_USER_FILTER;
+
     assert(maxlen >= 0);
     umaxlen = maxlen;
 
@@ -4812,6 +4889,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
 static bool
 S_path_is_absolute(const char *name)
 {
+    PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
+
     if (PERL_FILE_IS_ABSOLUTE(name)
 #ifdef MACOS_TRADITIONAL
 	|| (*name == ':')