X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=eb60ec1876fb93cce64ba1583f6cc58a442d1663;hb=c9fcc6c44229e7c36dee08e5d883d12284a44f17;hp=fdfdf27b93b6bf50de266e6cd84c4a2eceae92e9;hpb=7e2040f0b7c6fc88ec07b6e169aa2f75fc0130a4;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index fdfdf27..eb60ec1 100644
--- a/op.c
+++ b/op.c
@@ -1,6 +1,6 @@
 /*    op.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -1412,18 +1412,19 @@ Perl_mod(pTHX_ OP *o, I32 type)
 		    if (kid->op_type == OP_METHOD_NAMED
 			|| kid->op_type == OP_METHOD)
 		    {
-			OP *newop;
+			UNOP *newop;
 
 			if (kid->op_sibling || kid->op_next != kid) {
 			    yyerror("panic: unexpected optree near method call");
 			    break;
 			}
 			
-			NewOp(1101, newop, 1, OP);
+			NewOp(1101, newop, 1, UNOP);
 			newop->op_type = OP_RV2CV;
 			newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
-			newop->op_next = newop;
-			kid->op_sibling = newop;
+			newop->op_first = Nullop;
+                        newop->op_next = (OP*)newop;
+			kid->op_sibling = (OP*)newop;
 			newop->op_private |= OPpLVAL_INTRO;
 			break;
 		    }
@@ -2867,7 +2868,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 	    p = SvPV(pat, plen);
 	    pm->op_pmflags |= PMf_SKIPWHITE;
 	}
-	else if (DO_UTF8(pat))
+	if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
 	    pm->op_pmdynflags |= PMdf_UTF8;
 	pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
 	if (strEQ("\\s+", pm->op_pmregexp->precomp))
@@ -2875,6 +2876,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 	op_free(expr);
     }
     else {
+	if (PL_hints & HINT_UTF8)
+	    pm->op_pmdynflags |= PMdf_UTF8;
 	if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
 	    expr = newUNOP((!(PL_hints & HINT_RE_EVAL) 
 			    ? OP_REGCRESET
@@ -3103,7 +3106,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)) {
@@ -3111,6 +3114,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");
@@ -3119,29 +3123,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 */
@@ -3401,7 +3414,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 	cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
     }
     cop->op_flags = flags;
-    cop->op_private = (PL_hints & HINT_UTF8);
+    cop->op_private = (PL_hints & HINT_BYTE);
 #ifdef NATIVE_HINTS
     cop->op_private |= NATIVE_HINTS;
 #endif
@@ -3502,9 +3515,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	}
     }
     if (first->op_type == OP_CONST) {
-	if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
-	    Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s", 
-			PL_op_desc[type]);
+	if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
+	    Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
 	if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
 	    op_free(first);
 	    *firstp = Nullop;
@@ -4082,8 +4094,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     assert(!CvUNIQUE(proto));
 
     ENTER;
-    SAVEVPTR(PL_curpad);
-    SAVESPTR(PL_comppad);
+    SAVECOMPPAD();
     SAVESPTR(PL_comppad_name);
     SAVESPTR(PL_compcv);
 
@@ -4246,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) {
@@ -4304,14 +4315,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
     dTHR;
     STRLEN n_a;
-    char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
-    GV *gv = gv_fetchpv(name ? name : "__ANON__",
-			GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-			SVt_PVCV);
+    char *name;
+    char *aname;
+    GV *gv;
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
 
+    name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+    if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
+	SV *sv = sv_newmortal();
+	Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
+		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+	aname = SvPVX(sv);
+    }
+    else
+	aname = Nullch;
+    gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+		    GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+		    SVt_PVCV);
+
     if (o)
 	SAVEFREEOP(o);
     if (proto)
@@ -4357,13 +4380,14 @@ 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))
 					&& HvNAME(GvSTASH(CvGV(cv)))
 					&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
-						 "autouse"))) {
+						 "autouse")))
+	    {
 		line_t oldline = CopLINE(PL_curcop);
 		CopLINE_set(PL_curcop, PL_copline);
 		Perl_warner(aTHX_ WARN_REDEFINE,
@@ -4518,15 +4542,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	}
     }
 
-    if (name) {
+    if (name || aname) {
 	char *s;
+	char *tname = (name ? name : aname);
 
 	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
 	    SV *sv = NEWSV(0,0);
 	    SV *tmpstr = sv_newmortal();
 	    GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
-	    CV *cv;
+	    CV *pcv;
 	    HV *hv;
+	    char *t;
 
 	    Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
 			   CopFILE(PL_curcop),
@@ -4535,19 +4561,20 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
 	    hv = GvHVn(db_postponed);
 	    if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
-		  && (cv = GvCV(db_postponed))) {
+		&& (pcv = GvCV(db_postponed)))
+	    {
 		dSP;
 		PUSHMARK(SP);
 		XPUSHs(tmpstr);
 		PUTBACK;
-		call_sv((SV*)cv, G_DISCARD);
+		call_sv((SV*)pcv, G_DISCARD);
 	    }
 	}
 
-	if ((s = strrchr(name,':')))
+	if ((s = strrchr(tname,':')))
 	    s++;
 	else
-	    s = name;
+	    s = tname;
 
 	if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
 	    goto done;
@@ -5692,7 +5719,9 @@ Perl_ck_sassign(pTHX_ OP *o)
     OP *kid = cLISTOPo->op_first;
     /* has a disposable target? */
     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
-	&& !(kid->op_flags & OPf_STACKED))
+	&& !(kid->op_flags & OPf_STACKED)
+	/* Cannot steal the second time! */
+	&& !(kid->op_private & OPpTARGET_MY))
     {
 	OP *kkid = kid->op_sibling;
 
@@ -5939,7 +5968,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;
@@ -6429,11 +6458,12 @@ Perl_peep(pTHX_ register OP *o)
 	    UNOP *rop;
 	    SV *lexname;
 	    GV **fields;
-	    SV **svp, **indsvp;
+	    SV **svp, **indsvp, *sv;
 	    I32 ind;
 	    char *key;
 	    STRLEN keylen;
 	
+	    o->op_seq = PL_op_seqmax++;
 	    if ((o->op_private & (OPpLVAL_INTRO))
 		|| ((BINOP*)o)->op_last->op_type != OP_CONST)
 		break;
@@ -6460,8 +6490,76 @@ Perl_peep(pTHX_ register OP *o)
 	    rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
 	    o->op_type = OP_AELEM;
 	    o->op_ppaddr = PL_ppaddr[OP_AELEM];
+	    sv = newSViv(ind);
+	    if (SvREADONLY(*svp))
+		SvREADONLY_on(sv);
+	    SvFLAGS(sv) |= (SvFLAGS(*svp)
+			    & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
 	    SvREFCNT_dec(*svp);
-	    *svp = newSViv(ind);
+	    *svp = sv;
+	    break;
+	}
+	
+	case OP_HSLICE: {
+	    UNOP *rop;
+	    SV *lexname;
+	    GV **fields;
+	    SV **svp, **indsvp, *sv;
+	    I32 ind;
+	    char *key;
+	    STRLEN keylen;
+	    SVOP *first_key_op, *key_op;
+
+	    o->op_seq = PL_op_seqmax++;
+	    if ((o->op_private & (OPpLVAL_INTRO))
+		/* I bet there's always a pushmark... */
+		|| ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+		/* hmmm, no optimization if list contains only one key. */
+		break;
+	    rop = (UNOP*)((LISTOP*)o)->op_last;
+	    if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+		break;
+	    lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+	    if (!SvOBJECT(lexname))
+		break;
+	    fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+	    if (!fields || !GvHV(*fields))
+		break;
+	    /* Again guessing that the pushmark can be jumped over.... */
+	    first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+		->op_first->op_sibling;
+	    /* Check that the key list contains only constants. */
+	    for (key_op = first_key_op; key_op;
+		 key_op = (SVOP*)key_op->op_sibling)
+		if (key_op->op_type != OP_CONST)
+		    break;
+	    if (key_op)
+		break;
+	    rop->op_type = OP_RV2AV;
+	    rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
+	    o->op_type = OP_ASLICE;
+	    o->op_ppaddr = PL_ppaddr[OP_ASLICE];
+	    for (key_op = first_key_op; key_op;
+		 key_op = (SVOP*)key_op->op_sibling) {
+		svp = cSVOPx_svp(key_op);
+		key = SvPV(*svp, keylen);
+		indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+		if (!indsvp) {
+		    Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
+			       "in variable %s of type %s",
+			  key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
+		}
+		ind = SvIV(*indsvp);
+		if (ind < 1)
+		    Perl_croak(aTHX_ "Bad index while coercing array into hash");
+		sv = newSViv(ind);
+		if (SvREADONLY(*svp))
+		    SvREADONLY_on(sv);
+		SvFLAGS(sv) |= (SvFLAGS(*svp)
+				& (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
+		SvREFCNT_dec(*svp);
+		*svp = sv;
+	    }
 	    break;
 	}