/* 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.
(SvFAKE and name of '&' is not a meaningful combination currently but could
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
*/
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;
+ }
+
}
+
}
}
}
{
SV *out_sv;
int out_flags;
+ I32 offset;
+ AV *nameav;
+ SV **name_svp;
- return pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
+ offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
Null(SV**), &out_sv, &out_flags);
+ if (offset != NOT_IN_PAD)
+ return offset;
+
+ /* look for an our that's being introduced; this allows
+ * our $foo = 0 unless defined $foo;
+ * to not give a warning. (Yes, this is a hack) */
+
+ nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+ name_svp = AvARRAY(nameav);
+ for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ SV *namesv = name_svp[offset];
+ if (namesv && namesv != &PL_sv_undef
+ && !SvFAKE(namesv)
+ && (SvFLAGS(namesv) & SVpad_OUR)
+ && strEQ(SvPVX(namesv), name)
+ && 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
* all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
#define CvCOMPILED(cv) CvROOT(cv)
+/* the CV does late binding of its lexicals */
+#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+
STATIC PADOFFSET
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;
}
}
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 */
*out_name_sv = name_svp[offset]; /* return the namesv */
*out_flags = SvIVX(*out_name_sv);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%x index=%lu\n",
+ "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
(unsigned long)SvNVX(*out_name_sv)
));
CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
- PTR2UV(cv), *out_capture));
+ PTR2UV(cv), PTR2UV(*out_capture)));
if (SvPADSTALE(*out_capture)) {
if (ckWARN(WARN_CLOSURE))
return NOT_IN_PAD;
/* out_capture non-null means caller wants us to capture lex; in
- * addition we capture ourselves unless its an ANON */
+ * addition we capture ourselves unless it's an ANON/format */
new_capturep = out_capture ? out_capture :
- CvANON(cv) ? Null(SV**) : &new_capture;
+ CvLATE(cv) ? Null(SV**) : &new_capture;
offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name_sv, out_flags);
if (SvFLAGS(new_namesv) & SVpad_OUR) {
/* do nothing */
}
- else if (CvANON(cv)) {
+ else if (CvLATE(cv)) {
/* delayed creation - just note the offset within parent pad */
SvNVX(new_namesv) = (NV)offset;
CvCLONE_on(cv);
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))
);
}
}
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))
);
}
}
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),
(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)
);
title,
PTR2UV(cv),
(CvANON(cv) ? "ANON"
+ : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
: (cv == PL_main_cv) ? "MAIN"
: CvUNIQUE(cv) ? "UNIQUE"
: CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
CV* cv;
SV** outpad;
CV* outside;
+ long depth;
assert(!CvUNIQUE(proto));
- outside = find_runcv(NULL);
- /* presumably whoever invoked us must be active */
- assert(outside);
- assert(CvDEPTH(outside));
+ /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+ * to a prototype; we instead want the cloned parent who called us.
+ * Note that in general for formats, CvOUTSIDE != find_runcv */
+
+ outside = CvOUTSIDE(proto);
+ if (outside && CvCLONE(outside) && ! CvCLONED(outside))
+ outside = find_runcv(NULL);
+ depth = CvDEPTH(outside);
+ assert(depth || SvTYPE(proto) == SVt_PVFM);
+ if (!depth)
+ depth = 1;
assert(CvPADLIST(outside));
ENTER;
PL_curpad = AvARRAY(PL_comppad);
- outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[CvDEPTH(outside)]);
+ outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
for (ix = fpad; ix > 0; ix--) {
SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
- SV *sv;
- if (namesv && namesv != &PL_sv_undef) {
+ SV *sv = Nullsv;
+ if (namesv && namesv != &PL_sv_undef) { /* lexical */
if (SvFAKE(namesv)) { /* lexical from outside? */
- assert(outpad[(I32)SvNVX(namesv)] &&
- !SvPADSTALE(outpad[(I32)SvNVX(namesv)]));
- PL_curpad[ix] = SvREFCNT_inc(outpad[(I32)SvNVX(namesv)]);
+ sv = outpad[(I32)SvNVX(namesv)];
+ assert(sv);
+ /* formats may have an inactive parent */
+ if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
+ if (ckWARN(WARN_CLOSURE))
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+ "Variable \"%s\" is not available", SvPVX(namesv));
+ sv = Nullsv;
+ }
+ else {
+ assert(!SvPADSTALE(sv));
+ sv = SvREFCNT_inc(sv);
+ }
}
- else {
+ if (!sv) {
char *name = SvPVX(namesv);
if (*name == '&')
sv = SvREFCNT_inc(ppad[ix]);
else
sv = NEWSV(0, 0);
SvPADMY_on(sv);
- PL_curpad[ix] = sv;
}
}
else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
- PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ sv = SvREFCNT_inc(ppad[ix]);
}
else {
sv = NEWSV(0, 0);
SvPADTMP_on(sv);
- PL_curpad[ix] = sv;
}
+ PL_curpad[ix] = sv;
}
DEBUG_Xv(
=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)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff