X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=efb94b68d1ae0ed0c6372243fef77a04fca77f55;hb=eda6e075b0c0944056eda3d4a7d8ace8624d5b26;hp=9d44230fd7e29624cd7084c406961e95790bfafc;hpb=88d95a4d17f786d117305f530290cdd81b2df059;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 9d44230..efb94b6 100644
--- a/op.c
+++ b/op.c
@@ -1,6 +1,7 @@
 /*    op.c
  *
- *    Copyright (c) 1991-2003, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -887,10 +888,23 @@ S_modkids(pTHX_ OP *o, I32 type)
     return o;
 }
 
+/* Propagate lvalue ("modifiable") context to an op and it's children.
+ * 'type' represents the context type, roughly based on the type of op that
+ * would do the modifying, although local() is represented by OP_NULL.
+ * It's responsible for detecting things that can't be modified,  flag
+ * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
+ * might have to vivify a reference in $x), and so on.
+ *
+ * For example, "$a+1 = 2" would cause mod() to be called with o being
+ * OP_ADD and type being OP_SASSIGN, and would output an error.
+ */
+
 OP *
 Perl_mod(pTHX_ OP *o, I32 type)
 {
     OP *kid;
+    /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
+    int localize = -1;
 
     if (!o || PL_error_count)
 	return o;
@@ -903,6 +917,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 
     switch (o->op_type) {
     case OP_UNDEF:
+	localize = 0;
 	PL_modcount++;
 	return o;
     case OP_CONST:
@@ -1059,6 +1074,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	break;
 
     case OP_COND_EXPR:
+	localize = 1;
 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 	    mod(kid, type);
 	break;
@@ -1079,6 +1095,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_HSLICE:
 	if (type == OP_LEAVESUBLV)
 	    o->op_private |= OPpMAYBE_LVSUB;
+	localize = 1;
 	/* FALL THROUGH */
     case OP_AASSIGN:
     case OP_NEXTSTATE:
@@ -1087,6 +1104,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	break;
     case OP_RV2SV:
 	ref(cUNOPo->op_first, o->op_type);
+	localize = 1;
 	/* FALL THROUGH */
     case OP_GV:
     case OP_AV2ARYLEN:
@@ -1095,7 +1113,11 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_ANDASSIGN:
     case OP_ORASSIGN:
     case OP_DORASSIGN:
+	PL_modcount++;
+	break;
+
     case OP_AELEMFAST:
+	localize = 1;
 	PL_modcount++;
 	break;
 
@@ -1111,17 +1133,13 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	/* FALL THROUGH */
     case OP_PADSV:
 	PL_modcount++;
-	if (!type)
-	{   /* XXX DAPM 2002.08.25 tmp assert test */
-	    /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
-	    /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
-
+	if (!type) /* local() */
 	    Perl_croak(aTHX_ "Can't localize lexical variable %s",
 		 PAD_COMPNAME_PV(o->op_targ));
-	}
 	break;
 
     case OP_PUSHMARK:
+	localize = 0;
 	break;
 
     case OP_KEYS:
@@ -1152,6 +1170,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	    o->op_private |= OPpLVAL_DEFER;
 	if (type == OP_LEAVESUBLV)
 	    o->op_private |= OPpMAYBE_LVSUB;
+	localize = 1;
 	PL_modcount++;
 	break;
 
@@ -1159,11 +1178,13 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_LEAVE:
     case OP_ENTER:
     case OP_LINESEQ:
+	localize = 0;
 	if (o->op_flags & OPf_KIDS)
 	    mod(cLISTOPo->op_last, type);
 	break;
 
     case OP_NULL:
+	localize = 0;
 	if (o->op_flags & OPf_SPECIAL)		/* do BLOCK */
 	    goto nomod;
 	else if (!(o->op_flags & OPf_KIDS))
@@ -1174,6 +1195,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	}
 	/* FALL THROUGH */
     case OP_LIST:
+	localize = 0;
 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 	    mod(kid, type);
 	break;
@@ -1196,10 +1218,21 @@ Perl_mod(pTHX_ OP *o, I32 type)
 
     if (type == OP_AASSIGN || type == OP_SASSIGN)
 	o->op_flags |= OPf_SPECIAL|OPf_REF;
-    else if (!type) {
-	o->op_private |= OPpLVAL_INTRO;
-	o->op_flags &= ~OPf_SPECIAL;
-	PL_hints |= HINT_BLOCK_SCOPE;
+    else if (!type) { /* local() */
+	switch (localize) {
+	case 1:
+	    o->op_private |= OPpLVAL_INTRO;
+	    o->op_flags &= ~OPf_SPECIAL;
+	    PL_hints |= HINT_BLOCK_SCOPE;
+	    break;
+	case 0:
+	    break;
+	case -1:
+	    if (ckWARN(WARN_SYNTAX)) {
+		Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+		    "Useless localization of %s", OP_DESC(o));
+	    }
+	}
     }
     else if (type != OP_GREPSTART && type != OP_ENTERSUB
              && type != OP_LEAVESUBLV)
@@ -1837,14 +1870,23 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	    && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
 	{
 	    char *s = PL_bufptr;
+	    int sigil = 0;
 
-	    while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
+	    /* some heuristics to detect a potential error */
+	    while (*s && (strchr(", \t\n", *s)
+			|| (strchr("@$%*", *s) && ++sigil) ))
 		s++;
-
-	    if (*s == ';' || *s == '=')
-		Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
-			    "Parentheses missing around \"%s\" list",
-			    lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
+	    if (sigil) {
+		while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
+			    || strchr("@$%*, \t\n", *s)))
+		    s++;
+
+		if (*s == ';' || *s == '=')
+		    Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
+				"Parentheses missing around \"%s\" list",
+				lex ? (PL_in_my == KEY_our ? "our" : "my")
+				: "local");
+	    }
 	}
     }
     if (lex)
@@ -2611,6 +2653,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 			   : OPf_KIDS);
 	rcop->op_private = 1;
 	rcop->op_other = o;
+	/* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
+	PL_cv_has_eval = 1;
 
 	/* establish postfix order */
 	if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
@@ -3576,11 +3620,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
 	if (!next)
 	    next = unstack;
 	cont = append_elem(OP_LINESEQ, cont, unstack);
-	if ((line_t)whileline != NOLINE) {
-	    PL_copline = (line_t)whileline;
-	    cont = append_elem(OP_LINESEQ, cont,
-			       newSTATEOP(0, Nullch, Nullop));
-	}
     }
 
     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
@@ -3633,13 +3672,16 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     OP *wop;
     PADOFFSET padoff = 0;
     I32 iterflags = 0;
+    I32 iterpflags = 0;
 
     if (sv) {
 	if (sv->op_type == OP_RV2SV) {	/* symbol table variable */
+	    iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
 	    sv->op_type = OP_RV2GV;
 	    sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
 	}
 	else if (sv->op_type == OP_PADSV) { /* private variable */
+	    iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
 	    padoff = sv->op_targ;
 	    sv->op_targ = 0;
 	    op_free(sv);
@@ -3698,6 +3740,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
 			       append_elem(OP_LIST, expr, scalar(sv))));
     assert(!loop->op_next);
+    /* for my  $x () sets OPpLVAL_INTRO;
+     * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
+    loop->op_private = iterpflags;
 #ifdef PL_OP_SLAB_ALLOC
     {
 	LOOP *tmp;
@@ -3843,6 +3888,26 @@ Perl_cv_const_sv(pTHX_ CV *cv)
     return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
+/* op_const_sv:  examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * 	look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ * 	examine the clone prototype, and if contains only a single
+ * 	OP_CONST referencing a pad const, or a single PADSV referencing
+ * 	an outer lexical, return a non-zero value to indicate the CV is
+ * 	a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ *	We have just cloned an anon prototype that was marked as a const
+ *	candidiate. Try to grab the current value, and in the case of
+ *	PADSV, ignore it if it has multiple references. Return the value.
+ */
+
 SV *
 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
@@ -3871,26 +3936,31 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 	    return Nullsv;
 	if (type == OP_CONST && cSVOPo->op_sv)
 	    sv = cSVOPo->op_sv;
-	else if ((type == OP_PADSV || type == OP_CONST) && cv) {
+	else if (cv && type == OP_CONST) {
 	    sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
 	    if (!sv)
 		return Nullsv;
-	    if (CvCONST(cv)) {
-		/* We get here only from cv_clone2() while creating a closure.
-		   Copy the const value here instead of in cv_clone2 so that
-		   SvREADONLY_on doesn't lead to problems when leaving
-		   scope.
-		*/
+	}
+	else if (cv && type == OP_PADSV) {
+	    if (CvCONST(cv)) { /* newly cloned anon */
+		sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+		/* the candidate should have 1 ref from this pad and 1 ref
+		 * from the parent */
+		if (!sv || SvREFCNT(sv) != 2)
+		    return Nullsv;
 		sv = newSVsv(sv);
+		SvREADONLY_on(sv);
+		return sv;
+	    }
+	    else {
+		if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+		    sv = &PL_sv_undef; /* an arbitrary non-null value */
 	    }
-	    if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
-		return Nullsv;
 	}
-	else
+	else {
 	    return Nullsv;
+	}
     }
-    if (sv)
-	SvREADONLY_on(sv);
     return sv;
 }
 
@@ -4092,6 +4162,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
 	/* ... before we throw it away */
 	SvREFCNT_dec(PL_compcv);
+	PL_compcv = cv;
 	if (PERLDB_INTER)/* Advice debugger on the new sub. */
 	  ++PL_sub_generation;
     }
@@ -4609,9 +4680,12 @@ Perl_ck_bitop(pTHX_ OP *o)
 	    || o->op_type == OP_BIT_AND
 	    || o->op_type == OP_BIT_XOR)
     {
-	OPCODE typfirst = cBINOPo->op_first->op_type;
-	OPCODE typlast  = cBINOPo->op_first->op_sibling->op_type;
-	if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
+	OP * left = cBINOPo->op_first;
+	OP * right = left->op_sibling;
+	if ((OP_IS_NUMCOMPARE(left->op_type) &&
+		(left->op_flags & OPf_PARENS) == 0) ||
+	    (OP_IS_NUMCOMPARE(right->op_type) &&
+		(right->op_flags & OPf_PARENS) == 0))
 	    if (ckWARN(WARN_PRECEDENCE))
 		Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
 			"Possible precedence problem on bitwise %c operator",
@@ -4738,8 +4812,10 @@ Perl_ck_eval(pTHX_ OP *o)
 	    enter->op_other = o;
 	    return o;
 	}
-	else
+	else {
 	    scalar((OP*)kid);
+	    PL_cv_has_eval = 1;
+	}
     }
     else {
 	op_free(o);
@@ -4932,6 +5008,11 @@ Perl_ck_ftst(pTHX_ OP *o)
 	    op_free(o);
 	    o = newop;
 	}
+	else {
+	  if ((PL_hints & HINT_FILETEST_ACCESS) &&
+	      OP_IS_FILETEST_ACCESS(o))
+	    o->op_private |= OPpFT_ACCESS;
+	}
     }
     else {
 	op_free(o);
@@ -5086,10 +5167,6 @@ Perl_ck_fun(pTHX_ OP *o)
 			     */
 			    priv = OPpDEREF;
 			    if (kid->op_type == OP_PADSV) {
-				/*XXX DAPM 2002.08.25 tmp assert test */
-				/*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
-				/*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
-
 				name = PAD_COMPNAME_PV(kid->op_targ);
 				/* SvCUR of a pad namesv can't be trusted
 				 * (see PL_generation), so calc its length