X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pad.c;h=8b5f86a03ed0dc5d3b5fafb46527883c1ec6ec93;hb=b0bc38e63ed7e7e448fb07e45ee093d3b3d54be8;hp=8e78c736ac6f80b414564f2b01f96085bd7b1799;hpb=b5c19bd7c15bd02a18c3c2b80b6f602827ecdbcc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pad.c b/pad.c index 8e78c73..8b5f86a 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. @@ -88,6 +88,15 @@ is a CV representing a possible closure. (SvFAKE and name of '&' is not a meaningful combination currently but could become so if C 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 */ @@ -248,17 +257,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; + } + } + } } } @@ -534,11 +554,47 @@ Perl_pad_findmy(pTHX_ char *name) { 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 @@ -572,6 +628,9 @@ the parent pad. * 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, @@ -602,8 +661,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; } } @@ -627,7 +686,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 */ @@ -635,7 +694,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, *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) )); @@ -691,7 +750,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, 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)) @@ -720,9 +779,9 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, 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); @@ -760,7 +819,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, 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); @@ -896,7 +955,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)) ); } } @@ -944,7 +1003,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)) ); } } @@ -1214,7 +1273,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), @@ -1229,7 +1288,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) ); @@ -1267,6 +1326,7 @@ S_cv_dump(pTHX_ CV *cv, char *title) 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"), @@ -1312,13 +1372,21 @@ Perl_cv_clone(pTHX_ CV *proto) 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; @@ -1353,18 +1421,28 @@ Perl_cv_clone(pTHX_ CV *proto) 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]); @@ -1375,17 +1453,16 @@ Perl_cv_clone(pTHX_ CV *proto) 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( @@ -1459,6 +1536,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) {