From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sun, 13 Feb 2000 19:02:07 +0000 (+0000)
Subject: more purification (pp_require() could access free memory; vdie()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f79a09d62eb410185d697430134f937ab4e917d;p=p5sagit%2Fp5-mst-13.2.git

more purification (pp_require() could access free memory; vdie()
could think message was random length when passed a null argument;
utilize() didn't set up the hash for the method name leading to
pp_method_named() accessing random state; PL_curpm wasn't zeroed
properly)

p4raw-id: //depot/perl@5072
---

diff --git a/cop.h b/cop.h
index 734d2ea..cfa6f48 100644
--- a/cop.h
+++ b/cop.h
@@ -149,23 +149,28 @@ struct block_sub {
 struct block_eval {
     I32		old_in_eval;
     I32		old_op_type;
-    char *	old_name;
+    SV *	old_namesv;
     OP *	old_eval_root;
     SV *	cur_text;
 };
 
 #define PUSHEVAL(cx,n,fgv)						\
+    STMT_START {							\
 	cx->blk_eval.old_in_eval = PL_in_eval;				\
 	cx->blk_eval.old_op_type = PL_op->op_type;			\
-	cx->blk_eval.old_name = (n ? savepv(n) : Nullch);		\
+	cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : Nullsv);		\
 	cx->blk_eval.old_eval_root = PL_eval_root;			\
-	cx->blk_eval.cur_text = PL_linestr;
+	cx->blk_eval.cur_text = PL_linestr;				\
+    } STMT_END
 
 #define POPEVAL(cx)							\
+    STMT_START {							\
 	PL_in_eval = cx->blk_eval.old_in_eval;				\
 	optype = cx->blk_eval.old_op_type;				\
 	PL_eval_root = cx->blk_eval.old_eval_root;			\
-	Safefree(cx->blk_eval.old_name);
+	if (cx->blk_eval.old_namesv)					\
+	    sv_2mortal(cx->blk_eval.old_namesv);			\
+    } STMT_END
 
 /* loop context */
 struct block_loop {
diff --git a/op.c b/op.c
index 8f3330c..e1d0dcd 100644
--- a/op.c
+++ b/op.c
@@ -3105,7 +3105,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
 
     veop = Nullop;
 
-    if(version != Nullop) {
+    if (version != Nullop) {
 	SV *vesv = ((SVOP*)version)->op_sv;
 
 	if (arg == Nullop && !SvNIOK(vesv)) {
@@ -3113,6 +3113,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
 	}
 	else {
 	    OP *pack;
+	    SV *meth;
 
 	    if (version->op_type != OP_CONST || !SvNIOK(vesv))
 		Perl_croak(aTHX_ "Version number must be constant number");
@@ -3121,29 +3122,38 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
 	    pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
 
 	    /* Fake up a method call to VERSION */
+	    meth = newSVpvn("VERSION",7);
+	    sv_upgrade(meth, SVt_PVIV);
+	    SvIOK_on(meth);
+	    PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
 	    veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
 			    append_elem(OP_LIST,
-			    prepend_elem(OP_LIST, pack, list(version)),
-			    newSVOP(OP_METHOD_NAMED, 0,
-				    newSVpvn("VERSION", 7))));
+					prepend_elem(OP_LIST, pack, list(version)),
+					newSVOP(OP_METHOD_NAMED, 0, meth)));
 	}
     }
 
     /* Fake up an import/unimport */
     if (arg && arg->op_type == OP_STUB)
 	imop = arg;		/* no import on explicit () */
-    else if(SvNIOK(((SVOP*)id)->op_sv)) {
+    else if (SvNIOK(((SVOP*)id)->op_sv)) {
 	imop = Nullop;		/* use 5.0; */
     }
     else {
+	SV *meth;
+
 	/* Make copy of id so we don't free it twice */
 	pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+
+	/* Fake up a method call to import/unimport */
+	meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
+	sv_upgrade(meth, SVt_PVIV);
+	SvIOK_on(meth);
+	PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
 	imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
-		    append_elem(OP_LIST,
-			prepend_elem(OP_LIST, pack, list(arg)),
-			newSVOP(OP_METHOD_NAMED, 0,
-				aver ? newSVpvn("import", 6)
-				     : newSVpvn("unimport", 8))));
+		       append_elem(OP_LIST,
+				   prepend_elem(OP_LIST, pack, list(arg)),
+				   newSVOP(OP_METHOD_NAMED, 0, meth)));
     }
 
     /* Fake up a require, handle override, if any */
@@ -4247,10 +4257,10 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
     SV *sv = Nullsv;
 
-    if(!o)
+    if (!o)
 	return Nullsv;
  
-    if(o->op_type == OP_LINESEQ && cLISTOPo->op_first) 
+    if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 
 	o = cLISTOPo->op_first->op_sibling;
 
     for (; o; o = o->op_next) {
@@ -4370,7 +4380,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
 	    if (!block)
 		goto withattrs;
-	    if(const_sv = cv_const_sv(cv))
+	    if (const_sv = cv_const_sv(cv))
 		const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
 	    if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) 
 					&& !(CvGV(cv) && GvSTASH(CvGV(cv))
@@ -5956,7 +5966,7 @@ S_simplify_sort(pTHX_ OP *o)
 	return;
     if (strEQ(GvNAME(gv), "a"))
 	reversed = 0;
-    else if(strEQ(GvNAME(gv), "b"))
+    else if (strEQ(GvNAME(gv), "b"))
 	reversed = 1;
     else
 	return;
diff --git a/perl.c b/perl.c
index 1da8b0e..1891836 100644
--- a/perl.c
+++ b/perl.c
@@ -1452,13 +1452,13 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
 {
     dSP;
     OP myop;
-    if (!PL_op)
+    if (!PL_op) {
+	myop.op_next = Nullop;
 	PL_op = &myop;
+    }
     XPUSHs(sv_2mortal(newSVpv(methname,0)));
     PUTBACK;
     pp_method();
-	if(PL_op == &myop)
-		PL_op = Nullop;
     return call_sv(*PL_stack_sp--, flags);
 }
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 7b4cbfe..030bcbd 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1526,10 +1526,10 @@ PP(pp_caller)
 	if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
 	    PUSHs(cx->blk_eval.cur_text);
 	    PUSHs(&PL_sv_no);
-	} 
-	else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
-	    /* Require, put the name. */
-	    PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
+	}
+	/* try blocks have old_namesv == 0 */
+	else if (cx->blk_eval.old_namesv) {
+	    PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
 	    PUSHs(&PL_sv_yes);
 	}
     }
@@ -1813,9 +1813,9 @@ PP(pp_return)
 	    (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
 	{
 	    /* Unassume the success we assumed earlier. */
-	    char *name = cx->blk_eval.old_name;
-	    (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
-	    DIE(aTHX_ "%s did not return a true value", name);
+	    SV *nsv = cx->blk_eval.old_namesv;
+	    (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+	    DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
 	}
 	break;
     case CXt_FORMAT:
@@ -3294,9 +3294,9 @@ PP(pp_leaveeval)
 	!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
     {
 	/* Unassume the success we assumed earlier. */
-	char *name = cx->blk_eval.old_name;
-	(void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
-	retop = Perl_die(aTHX_ "%s did not return a true value", name);
+	SV *nsv = cx->blk_eval.old_namesv;
+	(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+	retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
 	/* die_where() did LEAVE, or we won't be here */
     }
     else {
diff --git a/regcomp.c b/regcomp.c
index 57a3bad..ca0b1d1 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -1388,6 +1388,10 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
 	 char, regexp);
     if (r == NULL)
 	FAIL("regexp out of space");
+#ifdef DEBUGGING
+    /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
+    Zero(r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), char);
+#endif
     r->refcnt = 1;
     r->prelen = xend - exp;
     r->precomp = PL_regprecomp;
diff --git a/regexec.c b/regexec.c
index 524313d..cef9887 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1670,7 +1670,7 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
 	    SAVEDESTRUCTOR_X(restore_pos, 0);
         }
 	if (!PL_reg_curpm)
-	    New(22,PL_reg_curpm, 1, PMOP);
+	    Newz(22,PL_reg_curpm, 1, PMOP);
 	PL_reg_curpm->op_pmregexp = prog;
 	PL_reg_oldcurpm = PL_curpm;
 	PL_curpm = PL_reg_curpm;
diff --git a/scope.c b/scope.c
index 0f56854..e6c3125 100644
--- a/scope.c
+++ b/scope.c
@@ -994,8 +994,9 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
 		PL_op_name[cx->blk_eval.old_op_type],
 		PL_op_desc[cx->blk_eval.old_op_type]);
-	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
-		cx->blk_eval.old_name);
+	if (cx->blk_eval.old_namesv)
+	    PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
+			  SvPVX(cx->blk_eval.old_namesv));
 	PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
 		PTR2UV(cx->blk_eval.old_eval_root));
 	break;
diff --git a/sv.c b/sv.c
index 8e84946..ac24299 100644
--- a/sv.c
+++ b/sv.c
@@ -6884,7 +6884,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
 	    case CXt_EVAL:
 		ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
 		ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
-		ncx->blk_eval.old_name	= SAVEPV(cx->blk_eval.old_name);
+		ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
 		ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
 		ncx->blk_eval.cur_text	= sv_dup(cx->blk_eval.cur_text);
 		break;
diff --git a/util.c b/util.c
index 031922a9..a63dd3f 100644
--- a/util.c
+++ b/util.c
@@ -1504,6 +1504,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
     }
     else {
 	message = Nullch;
+	msglen = 0;
     }
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,