X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pad.c;h=0c00cfff6b0c2488676fd77270871a49057edcbc;hb=02c473a9139e94d6158d1e3dd9a912f3525b3b21;hp=9673c0a05e89814ffeabbc8b3e8d7da83d6aed00;hpb=8dab6df03348b64bdb09672e6ba507c8969ec2c7;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pad.c b/pad.c
index 9673c0a..0c00cff 100644
--- a/pad.c
+++ b/pad.c
@@ -1,6 +1,6 @@
 /*    pad.c
  *
- *    Copyright (C) 2002,2003 by Larry Wall and others
+ *    Copyright (C) 2002, 2003, 2004, 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.
@@ -22,6 +22,11 @@
 /*
 =head1 Pad Data Structures
 
+This file contains the functions that create and manipulate scratchpads,
+which are array-of-array data structures attached to a CV (ie a sub)
+and which store lexical variables and opcode temporary and per-thread
+values.
+
 =for apidoc m|AV *|CvPADLIST|CV *cv
 CV's can have CvPADLIST(cv) set to point to an AV.
 
@@ -91,6 +96,12 @@ become so if C<my sub foo {}> is implemented.)
 Note that formats are treated as anon subs, and are cloned each time
 write is called (if necessary).
 
+The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
+and set on scope exit. This allows the 'Variable $x is not available' warning
+to be generated in evals, such as 
+
+    { my $x = 1; sub f { eval '$x'} } f();
+
 =cut
 */
 
@@ -251,17 +262,28 @@ Perl_pad_undef(pTHX_ CV* cv)
 		CV *innercv = (CV*)curpad[ix];
 		namepad[ix] = Nullsv;
 		SvREFCNT_dec(namesv);
-		curpad[ix] = Nullsv;
-		SvREFCNT_dec(innercv);
+
+		if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
+		    curpad[ix] = Nullsv;
+		    SvREFCNT_dec(innercv);
+		}
 		if (SvREFCNT(innercv) /* in use, not just a prototype */
 		    && CvOUTSIDE(innercv) == cv)
 		{
 		    assert(CvWEAKOUTSIDE(innercv));
-		    CvWEAKOUTSIDE_off(innercv);
-		    CvOUTSIDE(innercv) = outercv;
-		    CvOUTSIDE_SEQ(innercv) = seq;
-		    SvREFCNT_inc(outercv);
+		    /* don't relink to grandfather if he's being freed */
+		    if (outercv && SvREFCNT(outercv)) {
+			CvWEAKOUTSIDE_off(innercv);
+			CvOUTSIDE(innercv) = outercv;
+			CvOUTSIDE_SEQ(innercv) = seq;
+			SvREFCNT_inc(outercv);
+		    }
+		    else {
+			CvOUTSIDE(innercv) = Nullcv;
+		    }
+
 		}
+
 	    }
 	}
     }
@@ -558,13 +580,26 @@ Perl_pad_findmy(pTHX_ char *name)
 	    && !SvFAKE(namesv)
 	    && (SvFLAGS(namesv) & SVpad_OUR)
 	    && strEQ(SvPVX(namesv), name)
-	    && (U32)I_32(SvNVX(namesv)) == PAD_MAX /* min */
+	    && U_32(SvNVX(namesv)) == PAD_MAX /* min */
 	)
 	    return offset;
     }
     return NOT_IN_PAD;
 }
 
+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */
+
+PADOFFSET
+Perl_find_rundefsvoffset(pTHX)
+{
+    SV *out_sv;
+    int out_flags;
+    return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+	    Null(SV**), &out_sv, &out_flags);
+}
 
 /*
 =for apidoc pad_findlex
@@ -631,8 +666,8 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
 	    {
 		if (SvFAKE(namesv))
 		    fake_offset = offset; /* in case we don't find a real one */
-		else if (  seq >  (U32)I_32(SvNVX(namesv))	/* min */
-			&& seq <= (U32)SvIVX(namesv))		/* max */
+		else if (  seq >  U_32(SvNVX(namesv))	/* min */
+			&& seq <= (U32)SvIVX(namesv))	/* max */
 		    break;
 	    }
 	}
@@ -656,7 +691,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
 
 		DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 		    "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
-		    PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
+		    PTR2UV(cv), (long)offset, (long)U_32(SvNVX(*out_name_sv)),
 		    (long)SvIVX(*out_name_sv)));
 	    }
 	    else { /* fake match */
@@ -925,7 +960,7 @@ Perl_intro_my(pTHX)
 	    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 		"Pad intromy: %ld \"%s\", (%ld,%ld)\n",
 		(long)i, SvPVX(sv),
-		(long)I_32(SvNVX(sv)), (long)SvIVX(sv))
+		(long)U_32(SvNVX(sv)), (long)SvIVX(sv))
 	    );
 	}
     }
@@ -973,7 +1008,7 @@ Perl_pad_leavemy(pTHX)
 	    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 		"Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
 		(long)off, SvPVX(sv),
-		(long)I_32(SvNVX(sv)), (long)SvIVX(sv))
+		(long)U_32(SvNVX(sv)), (long)SvIVX(sv))
 	    );
 	}
     }
@@ -1243,7 +1278,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
 	if (namesv) {
 	    if (SvFAKE(namesv))
 		Perl_dump_indent(aTHX_ level+1, file,
-		    "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
+		    "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
 		    (int) ix,
 		    PTR2UV(ppad[ix]),
 		    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
@@ -1258,7 +1293,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
 		    (int) ix,
 		    PTR2UV(ppad[ix]),
 		    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
-		    (long)I_32(SvNVX(namesv)),
+		    (long)U_32(SvNVX(namesv)),
 		    (long)SvIVX(namesv),
 		    SvPVX(namesv)
 		);
@@ -1375,7 +1410,9 @@ Perl_cv_clone(pTHX_ CV *proto)
 #endif
     CvGV(cv)		= CvGV(proto);
     CvSTASH(cv)		= CvSTASH(proto);
+    OP_REFCNT_LOCK;
     CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
+    OP_REFCNT_UNLOCK;
     CvSTART(cv)		= CvSTART(proto);
     CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc(outside);
     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
@@ -1506,6 +1543,9 @@ If has_args is true, give the new pad an @_ in slot zero.
 =cut
 */
 
+/* XXX pad_push is now always called with has_args == 1. Get rid of
+ * this arg at some point */
+
 void
 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
 {