X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=6343a035782580116a0a69a38ef85d868a095dc0;hb=e993235624b459fbafc38390ba5ac81cb1c635b9;hp=f167a666c4e30688b1533564d2fcc6b610f7da16;hpb=d8a34499b0ed1aed7c7d5741ef20a99cbe385896;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index f167a66..6343a03 100644
--- a/op.c
+++ b/op.c
@@ -24,10 +24,10 @@
 
 /* #define PL_OP_SLAB_ALLOC */
 
-#ifdef PL_OP_SLAB_ALLOC
+#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
 #define SLAB_SIZE 8192
-static char    *PL_OpPtr  = NULL;
-static int     PL_OpSpace = 0;
+static char    *PL_OpPtr  = NULL;	/* XXX threadead */
+static int     PL_OpSpace = 0;		/* XXX threadead */
 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0)     \
                               var =  (type *)(PL_OpPtr -= c*sizeof(type));    \
                              else                                             \
@@ -813,10 +813,10 @@ Perl_op_clear(pTHX_ OP *o)
 	goto clear_pmop;
     case OP_PUSHRE:
 #ifdef USE_ITHREADS
-	if ((PADOFFSET)cPMOPo->op_pmreplroot) {
+        if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 	    if (PL_curpad) {
-		GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
-		pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
+		GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
+		pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
 		/* No GvIN_PAD_off(gv) here, because other references may still
 		 * exist on the pad */
 		SvREFCNT_dec(gv);
@@ -1024,6 +1024,9 @@ Perl_scalar(pTHX_ OP *o)
 	}
 	WITH_THR(PL_curcop = &PL_compiling);
 	break;
+    case OP_SORT:
+	if (ckWARN(WARN_VOID))
+	    Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
     }
     return o;
 }
@@ -1431,8 +1434,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 		if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
 		    Perl_croak(aTHX_
 			       "panic: unexpected lvalue entersub "
-			       "args: type/targ %ld:%ld",
-			       (long)kid->op_type,kid->op_targ);
+			       "args: type/targ %ld:%"UVuf,
+			       (long)kid->op_type, (UV)kid->op_targ);
 		kid = kLISTOP->op_first;
 	      skip_kids:
 		while (kid->op_sibling)
@@ -1462,8 +1465,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 		    if (kid->op_type != OP_RV2CV)
 			Perl_croak(aTHX_
 				   "panic: unexpected lvalue entersub "
-				   "entry via type/targ %ld:%ld",
-				   (long)kid->op_type,kid->op_targ);
+				   "entry via type/targ %ld:%"UVuf,
+				   (long)kid->op_type, (UV)kid->op_targ);
 		    kid->op_private |= OPpLVAL_INTRO;
 		    break;	/* Postpone until runtime */
 		}
@@ -1475,8 +1478,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 		if (kid->op_type == OP_NULL)		
 		    Perl_croak(aTHX_
 			       "Unexpected constant lvalue entersub "
-			       "entry via type/targ %ld:%ld",
-			       (long)kid->op_type,kid->op_targ);
+			       "entry via type/targ %ld:%"UVuf,
+			       (long)kid->op_type, (UV)kid->op_targ);
 		if (kid->op_type != OP_GV) {
 		    /* Restore RV2CV to check lvalueness */
 		  restore_2cv:
@@ -1670,6 +1673,14 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	    goto nomod;
 	break; /* mod()ing was handled by ck_return() */
     }
+
+    /* [20011101.069] File test operators interpret OPf_REF to mean that
+       their argument is a filehandle; thus \stat(".") should not set
+       it. AMS 20011102 */
+    if (type == OP_REFGEN &&
+        PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
+        return o;
+
     if (type != OP_LEAVESUBLV)
         o->op_flags |= OPf_MOD;
 
@@ -3297,7 +3308,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
 
 	/* Fake up a method call to import/unimport */
 	meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
-	sv_upgrade(meth, SVt_PVIV);
+	(void)SvUPGRADE(meth, SVt_PVIV);
 	(void)SvIOK_on(meth);
 	PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
 	imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
@@ -3553,7 +3564,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		    else if (curop->op_type == OP_PUSHRE) {
 			if (((PMOP*)curop)->op_pmreplroot) {
 #ifdef USE_ITHREADS
-			    GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
+			    GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
 #else
 			    GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
 #endif
@@ -3583,7 +3594,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		    tmpop = ((UNOP*)left)->op_first;
 		    if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
 #ifdef USE_ITHREADS
-			pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
+			pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
 			cPADOPx(tmpop)->op_padix = 0;	/* steal it */
 #else
 			pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
@@ -3687,10 +3698,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 
     if (PERLDB_LINE && PL_curstash != PL_debstash) {
 	SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
-	if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
-	    (void)SvIOK_on(*svp);
+        if (svp && *svp != &PL_sv_undef ) { 
+           (void)SvIOK_on(*svp);
 	    SvIVX(*svp) = PTR2IV(cop);
-	}
+	} 
     }
 
     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
@@ -4249,15 +4260,9 @@ Perl_cv_undef(pTHX_ CV *cv)
      * CV, they don't hold a refcount on the outside CV.  This avoids
      * the refcount loop between the outer CV (which keeps a refcount to
      * the closure prototype in the pad entry for pp_anoncode()) and the
-     * closure prototype, and the ensuing memory leak.  This does not
-     * apply to closures generated within eval"", since eval"" CVs are
-     * ephemeral. --GSAR */
-    if (!CvANON(cv) || CvCLONED(cv)
-	|| (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
-	    && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
-    {
+     * closure prototype, and the ensuing memory leak.  --GSAR */
+    if (!CvANON(cv) || CvCLONED(cv))
 	SvREFCNT_dec(CvOUTSIDE(cv));
-    }
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
 	SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
@@ -4904,17 +4909,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	}
     }
 
-    /* If a potential closure prototype, don't keep a refcount on
-     * outer CV, unless the latter happens to be a passing eval"".
+    /* If a potential closure prototype, don't keep a refcount on outer CV.
      * This is okay as the lifetime of the prototype is tied to the
      * lifetime of the outer CV.  Avoids memory leak due to reference
      * loop. --GSAR */
-    if (!name && CvOUTSIDE(cv)
-	&& !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
-	     && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
-    {
+    if (!name)
 	SvREFCNT_dec(CvOUTSIDE(cv));
-    }
 
     if (name || aname) {
 	char *s;
@@ -4957,8 +4957,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    ENTER;
 	    SAVECOPFILE(&PL_compiling);
 	    SAVECOPLINE(&PL_compiling);
-	    save_svref(&PL_rs);
-	    sv_setsv(PL_rs, PL_nrs);
 
 	    if (!PL_beginav)
 		PL_beginav = newAV();
@@ -5445,6 +5443,15 @@ Perl_ck_delete(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_die(pTHX_ OP *o)
+{
+#ifdef VMS
+    if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
+#endif
+    return ck_fun(o);
+}
+
+OP *
 Perl_ck_eof(pTHX_ OP *o)
 {
     I32 type = o->op_type;
@@ -5513,6 +5520,7 @@ Perl_ck_exit(pTHX_ OP *o)
        if (svp && *svp && SvTRUE(*svp))
            o->op_private |= OPpEXIT_VMSISH;
     }
+    if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
 #endif
     return ck_fun(o);
 }
@@ -6545,6 +6553,8 @@ Perl_ck_subr(pTHX_ OP *o)
     GV *namegv = 0;
     int optional = 0;
     I32 arg = 0;
+    I32 contextclass = 0;
+    char *e = 0;
     STRLEN n_a;
 
     o->op_private |= OPpENTERSUB_HASTARG;
@@ -6641,36 +6651,67 @@ Perl_ck_subr(pTHX_ OP *o)
 		}
 		scalar(o2);
 		break;
+	    case '[': case ']':
+		 goto oops;
+		 break;
 	    case '\\':
 		proto++;
 		arg++;
+	    again:
 		switch (*proto++) {
+		case '[':
+		     if (contextclass++ == 0) {
+		          e = strchr(proto, ']');
+			  if (!e || e == proto)
+			       goto oops;
+		     }
+		     else
+			  goto oops;
+		     goto again;
+		     break;
+		case ']':
+		     if (contextclass)
+			  contextclass = 0;
+		     else
+			  goto oops;
+		     break;
 		case '*':
-		    if (o2->op_type != OP_RV2GV)
-			bad_type(arg, "symbol", gv_ename(namegv), o2);
-		    goto wrapref;
+		     if (o2->op_type == OP_RV2GV)
+			  goto wrapref;
+		     if (!contextclass)
+			  bad_type(arg, "symbol", gv_ename(namegv), o2);
+		     break;
 		case '&':
-		    if (o2->op_type != OP_ENTERSUB)
-			bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
-		    goto wrapref;
+		     if (o2->op_type == OP_ENTERSUB)
+			  goto wrapref;
+		     if (!contextclass)
+			  bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+		     break;
 		case '$':
-		    if (o2->op_type != OP_RV2SV
-			&& o2->op_type != OP_PADSV
-			&& o2->op_type != OP_HELEM
-			&& o2->op_type != OP_AELEM
-			&& o2->op_type != OP_THREADSV)
-		    {
+		    if (o2->op_type == OP_RV2SV ||
+			o2->op_type == OP_PADSV ||
+			o2->op_type == OP_HELEM ||
+			o2->op_type == OP_AELEM ||
+			o2->op_type == OP_THREADSV)
+			 goto wrapref;
+		    if (!contextclass)
 			bad_type(arg, "scalar", gv_ename(namegv), o2);
-		    }
-		    goto wrapref;
+		     break;
 		case '@':
-		    if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+		    if (o2->op_type == OP_RV2AV ||
+			o2->op_type == OP_PADAV)
+			 goto wrapref;
+		    if (!contextclass)
 			bad_type(arg, "array", gv_ename(namegv), o2);
-		    goto wrapref;
+		    break;
 		case '%':
-		    if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
-			bad_type(arg, "hash", gv_ename(namegv), o2);
-		  wrapref:
+		    if (o2->op_type == OP_RV2HV ||
+			o2->op_type == OP_PADHV)
+			 goto wrapref;
+		    if (!contextclass)
+			 bad_type(arg, "hash", gv_ename(namegv), o2);
+		    break;
+		wrapref:
 		    {
 			OP* kid = o2;
 			OP* sib = kid->op_sibling;
@@ -6679,9 +6720,15 @@ Perl_ck_subr(pTHX_ OP *o)
 			o2->op_sibling = sib;
 			prev->op_sibling = o2;
 		    }
+		    if (contextclass && e) {
+			 proto = e + 1;
+			 contextclass = 0;
+		    }
 		    break;
 		default: goto oops;
 		}
+		if (contextclass)
+		     goto again;
 		break;
 	    case ' ':
 		proto++;
@@ -6689,7 +6736,7 @@ Perl_ck_subr(pTHX_ OP *o)
 	    default:
 	      oops:
 		Perl_croak(aTHX_ "Malformed prototype for %s: %s",
-			gv_ename(namegv), SvPV((SV*)cv, n_a));
+			   gv_ename(namegv), SvPV((SV*)cv, n_a));
 	    }
 	}
 	else
@@ -6903,10 +6950,12 @@ Perl_peep(pTHX_ register OP *o)
 		    && o->op_next->op_next->op_type == OP_CONCAT
 		    && (o->op_next->op_next->op_flags & OPf_STACKED))
 	    {
-		/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
-		o->op_next->op_type   = OP_RCATLINE;
-		o->op_next->op_flags |= OPf_STACKED;
+		/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
+		o->op_type   = OP_RCATLINE;
+		o->op_flags |= OPf_STACKED;
+		o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
 		op_null(o->op_next->op_next);
+		op_null(o->op_next);
 	    }
 
 	    o->op_seq = PL_op_seqmax++;
@@ -7104,8 +7153,9 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
-#ifdef PERL_CUSTOM_OPS
-char* custom_op_name(pTHX_ OP* o)
+
+
+char* Perl_custom_op_name(pTHX_ OP* o)
 {
     IV  index = PTR2IV(o->op_ppaddr);
     SV* keysv;
@@ -7123,7 +7173,7 @@ char* custom_op_name(pTHX_ OP* o)
     return SvPV_nolen(HeVAL(he));
 }
 
-char* custom_op_desc(pTHX_ OP* o)
+char* Perl_custom_op_desc(pTHX_ OP* o)
 {
     IV  index = PTR2IV(o->op_ppaddr);
     SV* keysv;
@@ -7140,7 +7190,7 @@ char* custom_op_desc(pTHX_ OP* o)
 
     return SvPV_nolen(HeVAL(he));
 }
-#endif
+
 
 #include "XSUB.h"