X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=2784a54bd38974fba3d4c2138280eebf6105ff52;hb=3c10ad8e31f7d77e71c048b1746912f41cb540f0;hp=2776dda6ea05e3dfc4b20eb9246e9bf63d2b5a8a;hpb=774d564bb7dd1ed64ca0d7e534aa67e93f991f02;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 2776dda..2784a54 100644
--- a/op.c
+++ b/op.c
@@ -1,6 +1,6 @@
 /*    op.c
  *
- *    Copyright (c) 1991-1994, Larry Wall
+ *    Copyright (c) 1991-1997, 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.
@@ -177,9 +177,10 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
     int saweval;
 
     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
-	AV* curlist = CvPADLIST(cv);
-	SV** svp = av_fetch(curlist, 0, FALSE);
+	AV *curlist = CvPADLIST(cv);
+	SV **svp = av_fetch(curlist, 0, FALSE);
 	AV *curname;
+
 	if (!svp || *svp == &sv_undef)
 	    continue;
 	curname = (AV*)*svp;
@@ -197,21 +198,24 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 
 		depth = CvDEPTH(cv);
 		if (!depth) {
-		    if (newoff && !CvUNIQUE(cv))
-			return 0; /* don't clone inactive sub's stack frame */
+		    if (newoff) {
+			if (SvFAKE(sv))
+			    continue;
+			return 0; /* don't clone from inactive stack frame */
+		    }
 		    depth = 1;
 		}
 		oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
 		oldsv = *av_fetch(oldpad, off, TRUE);
 		if (!newoff) {		/* Not a mere clone operation. */
-		    SV *sv = NEWSV(1103,0);
+		    SV *namesv = NEWSV(1103,0);
 		    newoff = pad_alloc(OP_PADSV, SVs_PADMY);
-		    sv_upgrade(sv, SVt_PVNV);
-		    sv_setpv(sv, name);
-		    av_store(comppad_name, newoff, sv);
-		    SvNVX(sv) = (double)curcop->cop_seq;
-		    SvIVX(sv) = 999999999;	/* A ref, intro immediately */
-		    SvFLAGS(sv) |= SVf_FAKE;
+		    sv_upgrade(namesv, SVt_PVNV);
+		    sv_setpv(namesv, name);
+		    av_store(comppad_name, newoff, namesv);
+		    SvNVX(namesv) = (double)curcop->cop_seq;
+		    SvIVX(namesv) = 999999999;	/* A ref, intro immediately */
+		    SvFAKE_on(namesv);		/* A ref, not a real var */
 		    if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) {
 			/* "It's closures all the way down." */
 			CvCLONE_on(compcv);
@@ -233,7 +237,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 			}
 		    }
 		    else if (!CvUNIQUE(compcv)) {
-			if (dowarn && !CvUNIQUE(cv))
+			if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
 			    warn("Variable \"%s\" will not stay shared", name);
 		    }
 		}
@@ -385,7 +389,7 @@ pad_sv(PADOFFSET po)
 {
     if (!po)
 	croak("panic: pad_sv po");
-    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po));
+    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po));
     return curpad[po];		/* eventually we'll turn this into a macro */
 }
 
@@ -403,8 +407,8 @@ pad_free(PADOFFSET po)
 	croak("panic: pad_free curpad");
     if (!po)
 	croak("panic: pad_free po");
-    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
-    if (curpad[po] && curpad[po] != &sv_undef)
+    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po));
+    if (curpad[po] && !SvIMMORTAL(curpad[po]))
 	SvPADTMP_off(curpad[po]);
     if ((I32)po < padix)
 	padix = po - 1;
@@ -422,7 +426,7 @@ pad_swipe(PADOFFSET po)
 	croak("panic: pad_swipe curpad");
     if (!po)
 	croak("panic: pad_swipe po");
-    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po));
+    DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po));
     SvPADTMP_off(curpad[po]);
     curpad[po] = NEWSV(1107,0);
     SvPADTMP_on(curpad[po]);
@@ -440,7 +444,7 @@ pad_reset()
     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
     if (!tainting) {	/* Can't mix tainted and non-tainted temporaries. */
 	for (po = AvMAX(comppad); po > padix_floor; po--) {
-	    if (curpad[po] && curpad[po] != &sv_undef)
+	    if (curpad[po] && !SvIMMORTAL(curpad[po]))
 		SvPADTMP_off(curpad[po]);
 	}
 	padix = padix_floor;
@@ -691,8 +695,6 @@ OP *op;
     case OP_AELEM:
     case OP_AELEMFAST:
     case OP_ASLICE:
-    case OP_VALUES:
-    case OP_KEYS:
     case OP_HELEM:
     case OP_HSLICE:
     case OP_UNPACK:
@@ -815,6 +817,8 @@ OP *op;
 		deprecate("implicit split to @_");
 	}
 	break;
+    case OP_KEYS:
+    case OP_VALUES:
     case OP_DELETE:
 	op->op_private |= OPpLEAVE_VOID;
 	break;
@@ -1260,6 +1264,20 @@ OP *right;
 {
     OP *op;
 
+    if (dowarn &&
+	(left->op_type == OP_RV2AV ||
+	 left->op_type == OP_RV2HV ||
+	 left->op_type == OP_PADAV ||
+	 left->op_type == OP_PADHV)) {
+	char *desc = op_desc[(right->op_type == OP_SUBST ||
+			      right->op_type == OP_TRANS)
+			     ? right->op_type : OP_MATCH];
+	char *sample = ((left->op_type == OP_RV2AV ||
+			 left->op_type == OP_PADAV)
+			? "@array" : "%hash");
+	warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample);
+    }
+
     if (right->op_type == OP_MATCH ||
 	right->op_type == OP_SUBST ||
 	right->op_type == OP_TRANS) {
@@ -1368,17 +1386,26 @@ OP *op;
 	peep(eval_start);
     }
     else {
-	if (!op) {
-	    main_start = 0;
+	if (!op)
 	    return;
-	}
 	main_root = scope(sawparens(scalarvoid(op)));
 	curcop = &compiling;
 	main_start = LINKLIST(main_root);
 	main_root->op_next = 0;
 	peep(main_start);
-	main_cv = compcv;
 	compcv = 0;
+
+	/* Register with debugger */
+	if (perldb) {
+	    CV *cv = perl_get_cv("DB::postponed", FALSE);
+	    if (cv) {
+		dSP;
+		PUSHMARK(sp);
+		XPUSHs((SV*)compiling.cop_filegv);
+		PUTBACK;
+		perl_call_sv((SV*)cv, G_DISCARD);
+	    }
+	}
     }
 }
 
@@ -2366,6 +2393,9 @@ OP *op;
     }
     cop->op_flags = flags;
     cop->op_private = 0 | (flags >> 8);
+#ifdef NATIVE_HINTS
+    cop->op_private |= NATIVE_HINTS;
+#endif
     cop->op_next = (OP*)cop;
 
     if (label) {
@@ -2844,10 +2874,10 @@ CV* cv;
 {
     CV *outside = CvOUTSIDE(cv);
     AV* padlist = CvPADLIST(cv);
-    AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
-    AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
-    SV** pname = AvARRAY(pad_name);
-    SV** ppad = AvARRAY(pad);
+    AV* pad_name;
+    AV* pad;
+    SV** pname;
+    SV** ppad;
     I32 ix;
 
     PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n",
@@ -2863,10 +2893,20 @@ CV* cv;
 		   : CvUNIQUE(outside) ? "UNIQUE"
 		   : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
 
-    for (ix = 1; ix <= AvFILL(pad); ix++) {
+    if (!padlist)
+	return;
+
+    pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
+    pad = (AV*)*av_fetch(padlist, 1, FALSE);
+    pname = AvARRAY(pad_name);
+    ppad = AvARRAY(pad);
+
+    for (ix = 1; ix <= AvFILL(pad_name); ix++) {
 	if (SvPOK(pname[ix]))
-	    PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\" %ld-%ld)\n",
-			  ix, ppad[ix], SvPVX(pname[ix]),
+	    PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n",
+			  ix, ppad[ix],
+			  SvFAKE(pname[ix]) ? "FAKE " : "",
+			  SvPVX(pname[ix]),
 			  (long)I_32(SvNVX(pname[ix])),
 			  (long)SvIVX(pname[ix]));
     }
@@ -2885,6 +2925,8 @@ CV* outside;
     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
     SV** pname = AvARRAY(protopad_name);
     SV** ppad = AvARRAY(protopad);
+    I32 fname = AvFILL(protopad_name);
+    I32 fpad = AvFILL(protopad);
     AV* comppadlist;
     CV* cv;
 
@@ -2924,12 +2966,12 @@ CV* outside;
     av_store(comppad, 0, (SV*)av);
     AvFLAGS(av) = AVf_REIFY;
 
-    for (ix = AvFILL(protopad); ix > 0; ix--) {
-	SV* sv;
-	if (pname[ix] != &sv_undef) {
-	    char *name = SvPVX(pname[ix]);    /* XXX */
-	    if (SvFLAGS(pname[ix]) & SVf_FAKE) {   /* lexical from outside? */
-		I32 off = pad_findlex(name, ix, SvIVX(pname[ix]),
+    for (ix = fpad; ix > 0; ix--) {
+	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+	if (namesv && namesv != &sv_undef) {
+	    char *name = SvPVX(namesv);    /* XXX */
+	    if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
+		I32 off = pad_findlex(name, ix, SvIVX(namesv),
 				      CvOUTSIDE(cv), cxstack_ix);
 		if (!off)
 		    curpad[ix] = SvREFCNT_inc(ppad[ix]);
@@ -2937,6 +2979,7 @@ CV* outside;
 		    croak("panic: cv_clone: %s", name);
 	    }
 	    else {				/* our own lexical */
+		SV* sv;
 		if (*name == '&') {
 		    /* anon code -- we'll come back for it */
 		    sv = SvREFCNT_inc(ppad[ix]);
@@ -2953,7 +2996,7 @@ CV* outside;
 	    }
 	}
 	else {
-	    sv = NEWSV(0,0);
+	    SV* sv = NEWSV(0,0);
 	    SvPADTMP_on(sv);
 	    curpad[ix] = sv;
 	}
@@ -2961,10 +3004,12 @@ CV* outside;
 
     /* Now that vars are all in place, clone nested closures. */
 
-    for (ix = AvFILL(protopad); ix > 0; ix--) {
-	if (pname[ix] != &sv_undef
-	    && !(SvFLAGS(pname[ix]) & SVf_FAKE)
-	    && *SvPVX(pname[ix]) == '&'
+    for (ix = fpad; ix > 0; ix--) {
+	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+	if (namesv
+	    && namesv != &sv_undef
+	    && !(SvFLAGS(namesv) & SVf_FAKE)
+	    && *SvPVX(namesv) == '&'
 	    && CvCLONE(ppad[ix]))
 	{
 	    CV *kid = cv_clone2((CV*)ppad[ix], cv);
@@ -3051,6 +3096,11 @@ OP *block;
 			SvPOK(cv) ? SvPV((SV*)cv,na) : "none",
 			p ? p : "none");
 	    }
+	    if (!block) {
+		/* just a "sub foo;" when &foo is already defined */
+		SAVEFREESV(compcv);
+		goto done;
+	    }
 	    if (const_sv || dowarn) {
 		line_t oldline = curcop->cop_line;
 		curcop->cop_line = copline;
@@ -3138,11 +3188,11 @@ OP *block;
 	    gv_efullname3(tmpstr, gv, Nullch);
 	    hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
 	    if (!db_postponed) {
-		db_postponed = gv_fetchpv("DB::postponed", TRUE, SVt_PVHV);
+		db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
 	    }
 	    hv = GvHVn(db_postponed);
-	    if (HvFILL(hv) >= 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
-		&& (cv = GvCV(db_postponed))) {
+	    if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
+		  && (cv = GvCV(db_postponed))) {
 		dSP;
 		PUSHMARK(sp);
 		XPUSHs(tmpstr);
@@ -3156,6 +3206,7 @@ OP *block;
 	else
 	    s = name;
 	if (strEQ(s, "BEGIN") && !error_count) {
+	    I32 oldscope = scopestack_ix;
 	    ENTER;
 	    SAVESPTR(compiling.cop_filegv);
 	    SAVEI16(compiling.cop_line);
@@ -3168,7 +3219,7 @@ OP *block;
 	    DEBUG_x( dump_sub(gv) );
 	    av_push(beginav, (SV *)cv);
 	    GvCV(gv) = 0;
-	    calllist(beginav);
+	    calllist(oldscope, beginav);
 
 	    curcop = &compiling;
 	    LEAVE;
@@ -3182,6 +3233,7 @@ OP *block;
 	}
     }
 
+  done:
     copline = NOLINE;
     LEAVE_SCOPE(floor);
     return cv;
@@ -3779,8 +3831,8 @@ OP *op;
 		    OP *newop = newAVREF(newGVOP(OP_GV, 0,
 			gv_fetchpv(name, TRUE, SVt_PVAV) ));
 		    if (dowarn)
-			warn("Array @%s missing the @ in argument %d of %s()",
-			    name, numargs, op_desc[type]);
+			warn("Array @%s missing the @ in argument %ld of %s()",
+			    name, (long)numargs, op_desc[type]);
 		    op_free(kid);
 		    kid = newop;
 		    kid->op_sibling = sibl;
@@ -3797,8 +3849,8 @@ OP *op;
 		    OP *newop = newHVREF(newGVOP(OP_GV, 0,
 			gv_fetchpv(name, TRUE, SVt_PVHV) ));
 		    if (dowarn)
-			warn("Hash %%%s missing the %% in argument %d of %s()",
-			    name, numargs, op_desc[type]);
+			warn("Hash %%%s missing the %% in argument %ld of %s()",
+			    name, (long)numargs, op_desc[type]);
 		    op_free(kid);
 		    kid = newop;
 		    kid->op_sibling = sibl;
@@ -3880,6 +3932,8 @@ OP *op;
 						newGVOP(OP_GV, 0, gv)))));
 	return ck_subr(op);
     }
+    if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling)
+	append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv)));
     gv = newGVgen("main");
     gv_IOadd(gv);
     append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
@@ -4360,7 +4414,6 @@ OP *op;
 	}
 	else
 	    list(o);
-	mod(o, OP_ENTERSUB);
 	prev = o;
 	o = o->op_sibling;
     }