X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pad.c;h=e8ba1394347897ac549b05625b60d86182619f67;hb=789bd863840ef4ff6c46f7c2ee0f3f64e0b5daa6;hp=c7a18c22110b4057530b8d2c26c76778cc1fa756;hpb=6de654a5795b6f7915432ff16bcdac0688492a9b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pad.c b/pad.c
index c7a18c2..e8ba139 100644
--- a/pad.c
+++ b/pad.c
@@ -200,7 +200,6 @@ Perl_pad_new(pTHX_ int flags)
 	 */
 
         AV * const a0 = newAV();			/* will be @_ */
-	av_extend(a0, 0);
 	av_store(pad, 0, MUTABLE_SV(a0));
 	AvREIFY_only(a0);
     }
@@ -421,13 +420,13 @@ Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
 	PL_min_intro_pending = offset;
     PL_max_intro_pending = offset;
     /* if it's not a simple scalar, replace with an AV or HV */
-    /* XXX DAPM since slot has been allocated, replace
-     * av_store with PL_curpad[offset] ? */
+    assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
+    assert(SvREFCNT(PL_curpad[offset]) == 1);
     if (*name == '@')
-	av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
+	sv_upgrade(PL_curpad[offset], SVt_PVAV);
     else if (*name == '%')
-	av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
-    SvPADMY_on(PL_curpad[offset]);
+	sv_upgrade(PL_curpad[offset], SVt_PVHV);
+    assert(SvPADMY(PL_curpad[offset]));
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 			   "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
 			   (long)offset, name, PTR2UV(PL_curpad[offset])));
@@ -705,6 +704,28 @@ Perl_find_rundefsvoffset(pTHX)
 }
 
 /*
+ * Returns a lexical $_, if there is one, at run time ; or the global one
+ * otherwise.
+ */
+
+SV *
+Perl_find_rundefsv(pTHX)
+{
+    SV *namesv;
+    int flags;
+    PADOFFSET po;
+
+    po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+	    NULL, &namesv, &flags);
+
+    if (po == NOT_IN_PAD
+	|| (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+	return DEFSV;
+
+    return PAD_SVl(po);
+}
+
+/*
 =for apidoc pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries
@@ -1299,27 +1320,37 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
     else if (type == padtidy_SUB) {
 	/* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
 	AV * const av = newAV();			/* Will be @_ */
-	av_extend(av, 0);
 	av_store(PL_comppad, 0, MUTABLE_SV(av));
 	AvREIFY_only(av);
     }
 
-    /* XXX DAPM rationalise these two similar branches */
-
-    if (type == padtidy_SUB) {
+    if (type == padtidy_SUB || type == padtidy_FORMAT) {
+	SV * const * const namep = AvARRAY(PL_comppad_name);
 	PADOFFSET ix;
 	for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
 	    if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
 		continue;
-	    if (!SvPADMY(PL_curpad[ix]))
-		SvPADTMP_on(PL_curpad[ix]);
-	}
-    }
-    else if (type == padtidy_FORMAT) {
-	PADOFFSET ix;
-	for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
-	    if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
+	    if (!SvPADMY(PL_curpad[ix])) {
 		SvPADTMP_on(PL_curpad[ix]);
+	    } else if (!SvFAKE(namep[ix])) {
+		/* This is a work around for how the current implementation of
+		   ?{ } blocks in regexps interacts with lexicals.
+
+		   One of our lexicals.
+		   Can't do this on all lexicals, otherwise sub baz() won't
+		   compile in
+
+		   my $foo;
+
+		   sub bar { ++$foo; }
+
+		   sub baz { ++$foo; }
+
+		   because completion of compiling &bar calling pad_tidy()
+		   would cause (top level) $foo to be marked as stale, and
+		   "no longer available".  */
+		SvPADSTALE_on(PL_curpad[ix]);
+	    }
 	}
     }
     PL_curpad = AvARRAY(PL_comppad);
@@ -1731,7 +1762,6 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
 	    }
 	}
 	av = newAV();
-	av_extend(av, 0);
 	av_store(newpad, 0, MUTABLE_SV(av));
 	AvREIFY_only(av);
 
@@ -1781,6 +1811,7 @@ Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
 
 	I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
 	AV *pad1;
+	const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
 	const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
 	SV **oldpad = AvARRAY(srcpad1);
 	SV **names;
@@ -1812,7 +1843,53 @@ Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
 	    AvFILLp(pad1) = ix;
 
 	    for ( ;ix > 0; ix--) {
-		pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+		if (!oldpad[ix]) {
+		    pad1a[ix] = NULL;
+		} else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+		    const char sigil = SvPVX_const(names[ix])[0];
+		    if ((SvFLAGS(names[ix]) & SVf_FAKE)
+			|| (SvFLAGS(names[ix]) & SVpad_STATE)
+			|| sigil == '&')
+			{
+			    /* outer lexical or anon code */
+			    pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+			}
+		    else {		/* our own lexical */
+			if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
+			    /* This is a work around for how the current
+			       implementation of ?{ } blocks in regexps
+			       interacts with lexicals.  */
+			    pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+			} else {
+			    SV *sv; 
+			    
+			    if (sigil == '@')
+				sv = MUTABLE_SV(newAV());
+			    else if (sigil == '%')
+				sv = MUTABLE_SV(newHV());
+			    else
+				sv = newSV(0);
+			    pad1a[ix] = sv;
+			    SvPADMY_on(sv);
+			}
+		    }
+		}
+		else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+		    pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+		}
+		else {
+		    /* save temporaries on recursion? */
+		    SV * const sv = newSV(0);
+		    pad1a[ix] = sv;
+
+		    /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
+		       FIXTHAT before merging this branch.
+		       (And I know how to) */
+		    if (SvPADMY(oldpad[ix]))
+			SvPADMY_on(sv);
+		    else
+			SvPADTMP_on(sv);
+		}
 	    }
 
 	    if (oldpad[0]) {