X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=b06267869fc8aa45ed1adfbdf93bd020d58dcc0e;hb=bdf3085f9fca00a6148ef3f26060d442844b64bd;hp=73f33ff87bb79117a2b54263f423dd6a1f6fbea7;hpb=862a34c634844bb3ea22e5f44bdaf2e973831a89;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 73f33ff..b062678 100644
--- a/op.c
+++ b/op.c
@@ -158,13 +158,12 @@ Perl_Slab_Free(pTHX_ void *op)
 
 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 
-STATIC char*
+STATIC const char*
 S_gv_ename(pTHX_ GV *gv)
 {
-    STRLEN n_a;
     SV* tmpsv = sv_newmortal();
     gv_efullname3(tmpsv, gv, Nullch);
-    return SvPV(tmpsv,n_a);
+    return SvPV_nolen_const(tmpsv);
 }
 
 STATIC OP *
@@ -1596,14 +1595,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
 				    dup_attrlist(attrs)));
 
     /* Fake up a method call to import */
-    meth = newSVpvn("import", 6);
-    SvUPGRADE(meth, SVt_PVIV);
-    (void)SvIOK_on(meth);
-    {
-	U32 hash;
-	PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
-	SvUV_set(meth, hash);
-    }
+    meth = newSVpvn_share("import", 6, 0);
     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
 		   append_elem(OP_LIST,
 			       prepend_elem(OP_LIST, pack, list(arg)),
@@ -2384,8 +2376,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     SV *rstr = ((SVOP*)repl)->op_sv;
     STRLEN tlen;
     STRLEN rlen;
-    U8 *t = (U8*)SvPV(tstr, tlen);
-    U8 *r = (U8*)SvPV(rstr, rlen);
+    const U8 *t = (U8*)SvPV_const(tstr, tlen);
+    const U8 *r = (U8*)SvPV_const(rstr, rlen);
     register I32 i;
     register I32 j;
     I32 del;
@@ -2408,8 +2400,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 	SV* listsv = newSVpvn("# comment\n",10);
 	SV* transv = 0;
-	U8* tend = t + tlen;
-	U8* rend = r + rlen;
+	const U8* tend = t + tlen;
+	const U8* rend = r + rlen;
 	STRLEN ulen;
 	UV tfirst = 1;
 	UV tlast = 0;
@@ -2430,12 +2422,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 
 	if (!from_utf) {
 	    STRLEN len = tlen;
-	    tsave = t = bytes_to_utf8(t, &len);
+	    t = tsave = bytes_to_utf8(t, &len);
 	    tend = t + len;
 	}
 	if (!to_utf && rlen) {
 	    STRLEN len = rlen;
-	    rsave = r = bytes_to_utf8(r, &len);
+	    r = rsave = bytes_to_utf8(r, &len);
 	    rend = r + len;
 	}
 
@@ -2492,7 +2484,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	    t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
 				    UNICODE_ALLOW_SUPER);
 	    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
-	    t = (U8*)SvPVX(transv);
+	    t = (const U8*)SvPVX_const(transv);
 	    tlen = SvCUR(transv);
 	    tend = t + tlen;
 	    Safefree(cp);
@@ -2792,15 +2784,31 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
     if (expr->op_type == OP_CONST) {
 	STRLEN plen;
 	SV *pat = ((SVOP*)expr)->op_sv;
-	char *p = SvPV(pat, plen);
+	const char *p = SvPV_const(pat, plen);
 	if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
+	    U32 was_readonly = SvREADONLY(pat);
+
+	    if (was_readonly) {
+		if (SvFAKE(pat)) {
+		    sv_force_normal_flags(pat, 0);
+		    assert(!SvREADONLY(pat));
+		    was_readonly = 0;
+		} else {
+		    SvREADONLY_off(pat);
+		}
+	    }   
+
 	    sv_setpvn(pat, "\\s+", 3);
-	    p = SvPV(pat, plen);
+
+	    SvFLAGS(pat) |= was_readonly;
+
+	    p = SvPV_const(pat, plen);
 	    pm->op_pmflags |= PMf_SKIPWHITE;
 	}
         if (DO_UTF8(pat))
 	    pm->op_pmdynflags |= PMdf_UTF8;
-	PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
+	/* FIXME - can we make this function take const char * args?  */
+	PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
 	if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 	    pm->op_pmflags |= PMf_WHITE;
 	op_free(expr);
@@ -2996,7 +3004,7 @@ Perl_package(pTHX_ OP *o)
     save_hptr(&PL_curstash);
     save_item(PL_curstname);
 
-    name = SvPV(cSVOPo->op_sv, len);
+    name = SvPV_const(cSVOPo->op_sv, len);
     PL_curstash = gv_stashpvn(name, len, TRUE);
     sv_setpvn(PL_curstname, name, len);
     op_free(o);
@@ -3035,14 +3043,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 	    pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
 
 	    /* Fake up a method call to VERSION */
-	    meth = newSVpvn("VERSION",7);
-	    sv_upgrade(meth, SVt_PVIV);
-	    (void)SvIOK_on(meth);
-	    {
-		U32 hash;
-		PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
-		SvUV_set(meth, hash);
-	    }
+	    meth = newSVpvn_share("VERSION", 7, 0);
 	    veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
 			    append_elem(OP_LIST,
 					prepend_elem(OP_LIST, pack, list(version)),
@@ -3063,14 +3064,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 	pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
 
 	/* Fake up a method call to import/unimport */
-	meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
-	SvUPGRADE(meth, SVt_PVIV);
-	(void)SvIOK_on(meth);
-	{
-	    U32 hash;
-	    PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
-	    SvUV_set(meth, hash);
-	}
+	meth = aver
+	    ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
 	imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
 		       append_elem(OP_LIST,
 				   prepend_elem(OP_LIST, pack, list(arg)),
@@ -3079,7 +3074,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 
     /* Fake up the BEGIN {}, which does its thing immediately. */
     newATTRSUB(floor,
-	newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
+	newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
 	Nullop,
 	Nullop,
 	append_elem(OP_LINESEQ,
@@ -3279,14 +3274,15 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 	OP *curop;
 
 	PL_modcount = 0;
-	PL_eval_start = right;	/* Grandfathering $[ assignment here.  Bletch.*/
+	/* Grandfathering $[ assignment here.  Bletch.*/
+	/* Only simple assignments like C<< ($[) = 1 >> are allowed */
+	PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
 	left = mod(left, OP_AASSIGN);
 	if (PL_eval_start)
 	    PL_eval_start = 0;
-	else {
-	    op_free(left);
-	    op_free(right);
-	    return Nullop;
+	else if (left->op_type == OP_CONST) {
+	    /* Result of assignment is always 1 (or we'd be dead already) */
+	    return newSVOP(OP_CONST, 0, newSViv(1));
 	}
 	/* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
 	if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
@@ -3423,8 +3419,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 	if (PL_eval_start)
 	    PL_eval_start = 0;
 	else {
-	    op_free(o);
-	    return Nullop;
+	    o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
 	}
     }
     return o;
@@ -3897,7 +3892,7 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my)
 }
 
 OP *
-Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
+Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
 {
     dVAR;
     LOOP *loop;
@@ -3952,8 +3947,8 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
 	 */
 	UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
 	LOGOP* range = (LOGOP*) flip->op_first;
-	OP* left  = range->op_first;
-	OP* right = left->op_sibling;
+	OP* const left  = range->op_first;
+	OP* const right = left->op_sibling;
 	LISTOP* listop;
 
 	range->op_flags &= ~OPf_KIDS;
@@ -4001,7 +3996,6 @@ OP*
 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 {
     OP *o;
-    STRLEN n_a;
 
     if (type != OP_GOTO || label->op_type == OP_CONST) {
 	/* "last()" means "last" */
@@ -4009,7 +4003,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 	    o = newOP(type, OPf_SPECIAL);
 	else {
 	    o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
-					? SvPVx(((SVOP*)label)->op_sv, n_a)
+					? SvPVx_nolen_const(((SVOP*)label)->op_sv)
 					: ""));
 	}
 	op_free(label);
@@ -4232,19 +4226,19 @@ CV *
 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
     dVAR;
-    STRLEN n_a;
     const char *aname;
     GV *gv;
-    char *ps;
+    const char *ps;
     STRLEN ps_len;
     register CV *cv=0;
     SV *const_sv;
+    I32 gv_fetch_flags;
 
-    const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+    const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
 
     if (proto) {
 	assert(proto->op_type == OP_CONST);
-	ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
+	ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
     }
     else
 	ps = Nullch;
@@ -4258,13 +4252,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
     else
 	aname = Nullch;
-    gv = name ? gv_fetchsv(cSVOPo->op_sv,
-			   GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-			   SVt_PVCV)
+
+    gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
+	? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
+    gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
 	: gv_fetchpv(aname ? aname
 		     : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
-		     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-		     SVt_PVCV);
+		     gv_fetch_flags, SVt_PVCV);
 
     if (o)
 	SAVEFREEOP(o);
@@ -4301,7 +4295,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
 #endif
 
-    if (!block || !ps || *ps || attrs)
+    if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
 	const_sv = Nullsv;
     else
 	const_sv = op_const_sv(block, Nullcv);
@@ -4644,24 +4638,32 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 	if (GvCVGEN(gv)) {
 	    /* just a cached method */
 	    SvREFCNT_dec(cv);
-	    cv = 0;
+	    cv = Nullcv;
 	}
 	else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
 	    /* already defined (or promised) */
 	    /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
-	    if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
-			    && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
-		const line_t oldline = CopLINE(PL_curcop);
-		if (PL_copline != NOLINE)
-		    CopLINE_set(PL_curcop, PL_copline);
-		Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-			    CvCONST(cv) ? "Constant subroutine %s redefined"
-					: "Subroutine %s redefined"
-			    ,name);
-		CopLINE_set(PL_curcop, oldline);
+	    if (ckWARN(WARN_REDEFINE)) {
+		GV * const gvcv = CvGV(cv);
+		if (gvcv) {
+		    HV * const stash = GvSTASH(gvcv);
+		    if (stash) {
+			const char *name = HvNAME_get(stash);
+			if ( strEQ(name,"autouse") ) {
+			    const line_t oldline = CopLINE(PL_curcop);
+			    if (PL_copline != NOLINE)
+				CopLINE_set(PL_curcop, PL_copline);
+			    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+					CvCONST(cv) ? "Constant subroutine %s redefined"
+						    : "Subroutine %s redefined"
+					,name);
+			    CopLINE_set(PL_curcop, oldline);
+			}
+		    }
+		}
 	    }
 	    SvREFCNT_dec(cv);
-	    cv = 0;
+	    cv = Nullcv;
 	}
     }
 
@@ -5486,7 +5488,7 @@ Perl_ck_fun(pTHX_ OP *o)
 					   
 				      }
 				      if (tmpstr) {
-					   name = SvPV(tmpstr, len);
+					   name = SvPV_const(tmpstr, len);
 					   sv_2mortal(tmpstr);
 				      }
 				 }
@@ -5918,21 +5920,29 @@ Perl_ck_require(pTHX_ OP *o)
 	SVOP *kid = (SVOP*)cUNOPo->op_first;
 
 	if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+	    SV *sv = kid->op_sv;
+	    U32 was_readonly = SvREADONLY(sv);
 	    char *s;
-	    for (s = SvPVX(kid->op_sv); *s; s++) {
+
+	    if (was_readonly) {
+		if (SvFAKE(sv)) {
+		    sv_force_normal_flags(sv, 0);
+		    assert(!SvREADONLY(sv));
+		    was_readonly = 0;
+		} else {
+		    SvREADONLY_off(sv);
+		}
+	    }   
+
+	    for (s = SvPVX(sv); *s; s++) {
 		if (*s == ':' && s[1] == ':') {
 		    *s = '/';
 		    Move(s+2, s+1, strlen(s+2)+1, char);
-		    SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
+		    SvCUR_set(sv, SvCUR(sv) - 1);
 		}
 	    }
-	    if (SvREADONLY(kid->op_sv)) {
-		SvREADONLY_off(kid->op_sv);
-		sv_catpvn(kid->op_sv, ".pm", 3);
-		SvREADONLY_on(kid->op_sv);
-	    }
-	    else
-		sv_catpvn(kid->op_sv, ".pm", 3);
+	    sv_catpvn(sv, ".pm", 3);
+	    SvFLAGS(sv) |= was_readonly;
 	}
     }
 
@@ -6231,7 +6241,6 @@ Perl_ck_subr(pTHX_ OP *o)
     I32 arg = 0;
     I32 contextclass = 0;
     char *e = 0;
-    STRLEN n_a;
     bool delete_op = 0;
 
     o->op_private |= OPpENTERSUB_HASTARG;
@@ -6249,7 +6258,7 @@ Perl_ck_subr(pTHX_ OP *o)
 	    else {
 		if (SvPOK(cv)) {
 		    namegv = CvANON(cv) ? gv : CvGV(cv);
-		    proto = SvPV((SV*)cv, n_a);
+		    proto = SvPV_nolen((SV*)cv);
 		}
 		if (CvASSERTION(cv)) {
 		    if (PL_hints & HINT_ASSERTING) {
@@ -6753,7 +6762,7 @@ Perl_peep(pTHX_ register OP *o)
             SV *lexname;
 	    GV **fields;
 	    SV **svp, *sv;
-	    char *key = NULL;
+	    const char *key = NULL;
 	    STRLEN keylen;
 
 	    o->op_opt = 1;
@@ -6764,7 +6773,7 @@ Perl_peep(pTHX_ register OP *o)
 	    /* Make the CONST have a shared SV */
 	    svp = cSVOPx_svp(((BINOP*)o)->op_last);
 	    if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
-		key = SvPV(sv, keylen);
+		key = SvPV_const(sv, keylen);
 		lexname = newSVpvn_share(key,
 					 SvUTF8(sv) ? -(I32)keylen : keylen,
 					 0);
@@ -6784,13 +6793,13 @@ Perl_peep(pTHX_ register OP *o)
 	    fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
 	    if (!fields || !GvHV(*fields))
 		break;
-	    key = SvPV(*svp, keylen);
+	    key = SvPV_const(*svp, keylen);
 	    if (!hv_fetch(GvHV(*fields), key,
 			SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
 	    {
 		Perl_croak(aTHX_ "No such class field \"%s\" " 
 			   "in variable %s of type %s", 
-		      key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
+		      key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
 	    }
 
             break;
@@ -6801,7 +6810,7 @@ Perl_peep(pTHX_ register OP *o)
 	    SV *lexname;
 	    GV **fields;
 	    SV **svp;
-	    char *key;
+	    const char *key;
 	    STRLEN keylen;
 	    SVOP *first_key_op, *key_op;
 
@@ -6841,7 +6850,7 @@ Perl_peep(pTHX_ register OP *o)
 		if (key_op->op_type != OP_CONST)
 		    continue;
 		svp = cSVOPx_svp(key_op);
-		key = SvPV(*svp, keylen);
+		key = SvPV_const(*svp, keylen);
 		if (!hv_fetch(GvHV(*fields), key, 
 			    SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
 		{