From: Dave Mitchell Date: Sun, 24 Nov 2002 22:19:06 +0000 (+0000) Subject: allow evals to see the full lexical scope X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a3985cdcc04b13974afc5f4635645003847806e4;p=p5sagit%2Fp5-mst-13.2.git allow evals to see the full lexical scope Message-ID: <20021124221906.A25386@fdgroup.com> p4raw-id: //depot/perl@18220 --- diff --git a/cop.h b/cop.h index fe0ca8a..870225c 100644 --- a/cop.h +++ b/cop.h @@ -5,6 +5,11 @@ * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * + * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE, + * and OP_SETSTATE that (loosely speaking) separate statements. They hold + * imformation important for lexical state and error reporting. At run + * time, PL_curcop is set to point to the most recently executed cop, + * and thus can be used to determine our current state. */ struct cop { diff --git a/cv.h b/cv.h index cb47c0f..4611387 100644 --- a/cv.h +++ b/cv.h @@ -30,6 +30,9 @@ struct xpvcv { PADLIST * xcv_padlist; CV * xcv_outside; cv_flags_t xcv_flags; + U32 xcv_outside_seq; /* the COP sequence (at the point of our + * compilation) in the lexically enclosing + * sub */ }; /* @@ -65,6 +68,7 @@ Returns the stash of the CV. #define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist #define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside #define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags +#define CvOUTSIDE_SEQ(sv) ((XPVCV*)SvANY(sv))->xcv_outside_seq #define CVf_CLONE 0x0001 /* anon CV uses external lexicals */ #define CVf_CLONED 0x0002 /* a clone of one of those */ diff --git a/dump.c b/dump.c index 45d7494..d874d32 100644 --- a/dump.c +++ b/dump.c @@ -1287,6 +1287,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); + Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); if (type == SVt_PVFM) Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv)); Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); diff --git a/embed.fnc b/embed.fnc index c115249..08a8f9d 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1070,7 +1070,7 @@ s |I32 |dopoptoloop |I32 startingblock s |I32 |dopoptosub |I32 startingblock s |I32 |dopoptosub_at |PERL_CONTEXT* cxstk|I32 startingblock s |void |save_lines |AV *array|SV *sv -s |OP* |doeval |int gimme|OP** startop +s |OP* |doeval |int gimme|OP** startop|CV* outside|U32 seq s |PerlIO *|doopen_pmc |const char *name|const char *mode s |bool |path_is_absolute|char *name #endif @@ -1329,7 +1329,7 @@ s |void |deb_stack_n |SV** stack_base|I32 stack_min \ #endif pd |PADLIST*|pad_new |padnew_flags flags -pd |void |pad_undef |CV* cv|CV* outercv +pd |void |pad_undef |CV* cv pd |PADOFFSET|pad_add_name |char *name\ |HV* typestash|HV* ourstash \ |bool clone @@ -1347,13 +1347,13 @@ pd |void |pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv pd |void |pad_push |PADLIST *padlist|int depth|int has_args #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) -sd |PADOFFSET|pad_findlex |char* name|PADOFFSET newoff|U32 seq \ - |CV* startcv|I32 cx_ix|I32 saweval|U32 flags +sd |PADOFFSET|pad_findlex |char* name|PADOFFSET newoff|CV* innercv # if defined(DEBUGGING) sd |void |cv_dump |CV *cv|char *title # endif s |CV* |cv_clone2 |CV *proto|CV *outside #endif +pd |CV* |find_runcv diff --git a/embed.h b/embed.h index 9dde007..828746e 100644 --- a/embed.h +++ b/embed.h @@ -1211,6 +1211,7 @@ # endif #define cv_clone2 S_cv_clone2 #endif +#define find_runcv Perl_find_runcv #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -2513,7 +2514,7 @@ #define dopoptosub(a) S_dopoptosub(aTHX_ a) #define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b) #define save_lines(a,b) S_save_lines(aTHX_ a,b) -#define doeval(a,b) S_doeval(aTHX_ a,b) +#define doeval(a,b,c,d) S_doeval(aTHX_ a,b,c,d) #define doopen_pmc(a,b) S_doopen_pmc(aTHX_ a,b) #define path_is_absolute(a) S_path_is_absolute(aTHX_ a) #endif @@ -2740,7 +2741,7 @@ #define deb_stack_n(a,b,c,d,e) S_deb_stack_n(aTHX_ a,b,c,d,e) #endif #define pad_new(a) Perl_pad_new(aTHX_ a) -#define pad_undef(a,b) Perl_pad_undef(aTHX_ a,b) +#define pad_undef(a) Perl_pad_undef(aTHX_ a) #define pad_add_name(a,b,c,d) Perl_pad_add_name(aTHX_ a,b,c,d) #define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b) #define pad_check_dup(a,b,c) Perl_pad_check_dup(aTHX_ a,b,c) @@ -2753,12 +2754,13 @@ #define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c) #define pad_push(a,b,c) Perl_pad_push(aTHX_ a,b,c) #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) -#define pad_findlex(a,b,c,d,e,f,g) S_pad_findlex(aTHX_ a,b,c,d,e,f,g) +#define pad_findlex(a,b,c) S_pad_findlex(aTHX_ a,b,c) # if defined(DEBUGGING) #define cv_dump(a,b) S_cv_dump(aTHX_ a,b) # endif #define cv_clone2(a,b) S_cv_clone2(aTHX_ a,b) #endif +#define find_runcv() Perl_find_runcv(aTHX) #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/ext/B/B.pm b/ext/B/B.pm index c1bd852..f75e54b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -843,6 +843,8 @@ IoIFP($io) == PerlIO_stdin() ). =item OUTSIDE +=item OUTSIDE_SEQ + =item XSUB =item XSUBANY diff --git a/ext/B/B.xs b/ext/B/B.xs index f24d070..9001031 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1412,6 +1412,10 @@ B::CV CvOUTSIDE(cv) B::CV cv +U32 +CvOUTSIDE_SEQ(cv) + B::CV cv + void CvXSUB(cv) B::CV cv diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index dd49c02..d1125bd 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -652,7 +652,8 @@ sub B::CV::bytecode { for ($i = 0; $i < @ixes; $i++) { asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + asmf "xcv_depth %d\nxcv_flags 0x%x\nxcv_outside_seq 0x%x", + $cv->DEPTH, $cv->CvFLAGS, $cv->OUTSIDE_SEQ; asmf "xcv_file %d\n", $fileix; # Now save all the subfields (except for CvROOT which was handled # above) and CvSTART (now the initial element of @subfields). diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 77582d2..9ae2359 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -1012,10 +1012,11 @@ sub B::CV::save { $cvstashname, $cvname); # debug } $pv = '' unless defined $pv; # Avoid use of undef warnings - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); + $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS, + $cv->OUTSIDE_SEQ)); if (${$cv->OUTSIDE} == ${main_cv()}){ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); @@ -1436,6 +1437,9 @@ typedef struct { AV * xcv_padlist; CV * xcv_outside; cv_flags_t xcv_flags; + U32 xcv_outside_seq; /* the COP sequence (at the point of our + * compilation) in the lexically enclosing + * sub */ } XPVCV_or_similar; #define ANYINIT(i) i #else diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm index f9f8c09..da8b147 100644 --- a/ext/B/B/Debug.pm +++ b/ext/B/B/Debug.pm @@ -198,7 +198,7 @@ sub B::CV::debug { my ($padlist) = $sv->PADLIST; my ($file) = $sv->FILE; my ($gv) = $sv->GV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; STASH 0x%x START 0x%x ROOT 0x%x @@ -207,6 +207,7 @@ sub B::CV::debug { DEPTH %d PADLIST 0x%x OUTSIDE 0x%x + OUTSIDE_SEQ %d EOT $start->debug if $start; $root->debug if $root; diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t index 1230026..529d3c9 100644 --- a/ext/Devel/Peek/Peek.t +++ b/ext/Devel/Peek/Peek.t @@ -221,6 +221,7 @@ do_test(13, (?: MUTEXP = $ADDR OWNER = $ADDR )? FLAGS = 0x4 + OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) OUTSIDE = $ADDR \\(MAIN\\)'); @@ -247,6 +248,7 @@ do_test(14, (?: MUTEXP = $ADDR OWNER = $ADDR )? FLAGS = 0x0 + OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" diff --git a/op.c b/op.c index c3aee1e..c46bbfc 100644 --- a/op.c +++ b/op.c @@ -3756,7 +3756,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - CV *outsidecv; CV *freecv = Nullcv; #ifdef USE_ITHREADS @@ -3780,20 +3779,21 @@ Perl_cv_undef(pTHX_ CV *cv) } SvPOK_off((SV*)cv); /* forget prototype */ CvGV(cv) = Nullgv; - outsidecv = CvOUTSIDE(cv); + + pad_undef(cv); + /* Since closure prototypes have the same lifetime as the containing * CV, they don't hold a refcount on the outside CV. This avoids * the refcount loop between the outer CV (which keeps a refcount to * the closure prototype in the pad entry for pp_anoncode()) and the * closure prototype, and the ensuing memory leak. --GSAR */ if (!CvANON(cv) || CvCLONED(cv)) - freecv = outsidecv; + freecv = CvOUTSIDE(cv); CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - pad_undef(cv, outsidecv); if (freecv) SvREFCNT_dec(freecv); if (CvXSUB(cv)) { @@ -4086,9 +4086,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } + /* transfer PL_compcv to cv */ cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; diff --git a/pad.c b/pad.c index 590aad8..0dfc989 100644 --- a/pad.c +++ b/pad.c @@ -194,13 +194,13 @@ Free the padlist associated with a CV. If parts of it happen to be current, we null the relevant PL_*pad* global vars so that we don't have any dangling references left. We also repoint the CvOUTSIDE of any about-to-be-orphaned -inner subs to outercv. +inner subs to the outer of this cv. =cut */ void -Perl_pad_undef(pTHX_ CV* cv, CV* outercv) +Perl_pad_undef(pTHX_ CV* cv) { I32 ix; PADLIST *padlist = CvPADLIST(cv); @@ -218,10 +218,12 @@ Perl_pad_undef(pTHX_ CV* cv, CV* outercv) if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */ && !PL_dirty) || CvSPECIAL(cv)) { + CV *outercv = CvOUTSIDE(cv); + U32 seq = CvOUTSIDE_SEQ(cv); /* XXX DAPM the following code is very similar to * pad_fixup_inner_anons(). Merge??? */ - /* inner references to eval's cv must be fixed up */ + /* inner references to eval's/BEGIN's/etc cv must be fixed up */ AV *comppad_name = (AV*)AvARRAY(padlist)[0]; SV **namepad = AvARRAY(comppad_name); AV *comppad = (AV*)AvARRAY(padlist)[1]; @@ -237,6 +239,8 @@ Perl_pad_undef(pTHX_ CV* cv, CV* outercv) && CvOUTSIDE(innercv) == cv) { CvOUTSIDE(innercv) = outercv; + CvOUTSIDE_SEQ(innercv) = seq; + /* anon prototypes aren't refcounted */ if (!CvANON(innercv) || CvCLONED(innercv)) { (void)SvREFCNT_inc(outercv); if (SvREFCNT(cv)) @@ -529,8 +533,6 @@ Perl_pad_findmy(pTHX_ char *name) SV *sv; SV **svp = AvARRAY(PL_comppad_name); U32 seq = PL_cop_seqmax; - PERL_CONTEXT *cx; - CV *outside; ASSERT_CURPAD_ACTIVE("pad_findmy"); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name)); @@ -550,20 +552,8 @@ Perl_pad_findmy(pTHX_ char *name) } } - outside = CvOUTSIDE(PL_compcv); - - /* Check if if we're compiling an eval'', and adjust seq to be the - * eval's seq number. This depends on eval'' having a non-null - * CvOUTSIDE() while it is being compiled. The eval'' itself is - * identified by CvEVAL being true and CvGV being null. */ - if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) { - cx = &cxstack[cxstack_ix]; - if (CxREALEVAL(cx)) - seq = cx->blk_oldcop->cop_seq; - } - /* See if it's in a nested scope */ - off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0); + off = pad_findlex(name, 0, PL_compcv); if (!off) /* pad_findlex returns 0 for failure...*/ return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */ @@ -579,41 +569,40 @@ Perl_pad_findmy(pTHX_ char *name) =for apidoc pad_findlex Find a named lexical anywhere in a chain of nested pads. Add fake entries -in the inner pads if its found in an outer one. - -If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts. +in the inner pads if it's found in an outer one. innercv is the CV *inside* +the chain of outer CVs to be searched. If newoff is non-null, this is a +run-time cloning: don't add fake entries, just find the lexical and add a +ref to it at newoff in the current pad. =cut */ -#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */ - STATIC PADOFFSET -S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, - I32 cx_ix, I32 saweval, U32 flags) +S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv) { CV *cv; I32 off; SV *sv; - register I32 i; - register PERL_CONTEXT *cx; + CV* startcv; + U32 seq; ASSERT_CURPAD_ACTIVE("pad_findlex"); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf - " ix=%ld saweval=%d flags=%lu\n", - name, (long)newoff, (unsigned long)seq, PTR2UV(startcv), - (long)cx_ix, (int)saweval, (unsigned long)flags - ) + "Pad findlex: \"%s\" off=%ld startcv=0x%"UVxf"\n", + name, (long)newoff, PTR2UV(innercv)) ); - for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { + seq = CvOUTSIDE_SEQ(innercv); + startcv = CvOUTSIDE(innercv); + + for (cv = startcv; cv; seq = CvOUTSIDE_SEQ(cv), cv = CvOUTSIDE(cv)) { AV *curlist = CvPADLIST(cv); SV **svp = av_fetch(curlist, 0, FALSE); AV *curname; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - " searching: cv=0x%"UVxf"\n", PTR2UV(cv)) + " searching: cv=0x%"UVxf" seq=%d\n", + PTR2UV(cv), (int) seq ) ); if (!svp || *svp == &PL_sv_undef) @@ -735,59 +724,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, return newoff; } } - - if (flags & FINDLEX_NOSEARCH) - return 0; - - /* Nothing in current lexical context--try eval's context, if any. - * This is necessary to let the perldb get at lexically scoped variables. - * XXX This will also probably interact badly with eval tree caching. - */ - - for (i = cx_ix; i >= 0; i--) { - cx = &cxstack[i]; - switch (CxTYPE(cx)) { - default: - if (i == 0 && saweval) { - return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0); - } - break; - case CXt_EVAL: - switch (cx->blk_eval.old_op_type) { - case OP_ENTEREVAL: - if (CxREALEVAL(cx)) { - PADOFFSET off; - saweval = i; - seq = cxstack[i].blk_oldcop->cop_seq; - startcv = cxstack[i].blk_eval.cv; - if (startcv && CvOUTSIDE(startcv)) { - off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv), - i - 1, saweval, 0); - if (off) /* continue looking if not found here */ - return off; - } - } - break; - case OP_DOFILE: - case OP_REQUIRE: - /* require/do must have their own scope */ - return 0; - } - break; - case CXt_FORMAT: - case CXt_SUB: - if (!saweval) - return 0; - cv = cx->blk_sub.cv; - if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */ - saweval = i; /* so we know where we were called from */ - seq = cxstack[i].blk_oldcop->cop_seq; - continue; - } - return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH); - } - } - return 0; } @@ -1315,8 +1251,10 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); CvSTART(cv) = CvSTART(proto); - if (outside) + if (outside) { CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); + } if (SvPOK(proto)) sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto)); @@ -1334,8 +1272,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) if (namesv && namesv != &PL_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, 0, 0); + I32 off = pad_findlex(name, ix, cv); if (!off) PL_curpad[ix] = SvREFCNT_inc(ppad[ix]); else if (off != ix) @@ -1432,6 +1369,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) CV *innercv = (CV*)curpad[ix]; if (CvOUTSIDE(innercv) == old_cv) { CvOUTSIDE(innercv) = new_cv; + /* anon prototypes aren't refcounted */ if (!CvANON(innercv) || CvCLONED(innercv)) { (void)SvREFCNT_inc(new_cv); SvREFCNT_dec(old_cv); diff --git a/pod/perlintern.pod b/pod/perlintern.pod index de1f4b2..0ec74e0 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -216,6 +216,23 @@ Found in file pad.h =back +=head1 Functions in file pp_ctl.c + + +=over 8 + +=item find_runcv + +Locate the CV corresponding to the currently executing sub or eval. + + CV* find_runcv() + +=for hackers +Found in file pp_ctl.c + + +=back + =head1 Global Variables =over 8 @@ -505,11 +522,12 @@ Found in file pad.c =item pad_findlex Find a named lexical anywhere in a chain of nested pads. Add fake entries -in the inner pads if its found in an outer one. - -If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts. +in the inner pads if it's found in an outer one. innercv is the CV *inside* +the chain of outer CVs to be searched. If newoff is non-null, this is a +run-time cloning: don't add fake entries, just find the lexical and add a +ref to it at newoff in the current pad. - PADOFFSET pad_findlex(char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags) + PADOFFSET pad_findlex(char* name, PADOFFSET newoff, CV* innercv) =for hackers Found in file pad.c @@ -629,9 +647,9 @@ Free the padlist associated with a CV. If parts of it happen to be current, we null the relevant PL_*pad* global vars so that we don't have any dangling references left. We also repoint the CvOUTSIDE of any about-to-be-orphaned -inner subs to outercv. +inner subs to the outer of this cv. - void pad_undef(CV* cv, CV* outercv) + void pad_undef(CV* cv) =for hackers Found in file pad.c diff --git a/pp_ctl.c b/pp_ctl.c index a43e629..76a2466 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2572,6 +2572,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; + int runtime; + CV* runcv; ENTER; lex_start(sv); @@ -2610,12 +2612,21 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) #endif PL_hints &= HINT_UTF8; + /* we get here either during compilation, or via pp_regcomp at runtime */ + runtime = PL_op && (PL_op->op_type == OP_REGCOMP); + if (runtime) + runcv = find_runcv(); + PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); - rop = doeval(G_SCALAR, startop); + + if (runtime) + rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + else + rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2633,14 +2644,47 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) return rop; } + +/* +=for apidoc find_runcv + +Locate the CV corresponding to the currently executing sub or eval. + +=cut +*/ + +CV* +Perl_find_runcv(pTHX) +{ + I32 ix; + PERL_SI *si; + PERL_CONTEXT *cx; + + for (si = PL_curstackinfo; si; si = si->si_prev) { + for (ix = si->si_cxix; ix >= 0; ix--) { + cx = &(si->si_cxstack[ix]); + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) + return cx->blk_sub.cv; + else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) + return PL_compcv; + } + } + return PL_main_cv; +} + + +/* Compile a require/do, an eval '', or a /(?{...})/. + * In the last case, startop is non-null, and contains the address of + * a pointer that should be set to the just-compiled code. + * outside is the lexically enclosing CV (if any) that invoked us. + */ + /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * -S_doeval(pTHX_ int gimme, OP** startop) +S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dSP; OP *saveop = PL_op; - CV *caller; - I32 i; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -2648,17 +2692,6 @@ S_doeval(pTHX_ int gimme, OP** startop) PUSHMARK(SP); - caller = PL_compcv; - for (i = cxstack_ix - 1; i >= 0; i--) { - PERL_CONTEXT *cx = &cxstack[i]; - if (CxTYPE(cx) == CXt_EVAL) - break; - else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - caller = cx->blk_sub.cv; - break; - } - } - SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); @@ -2666,15 +2699,13 @@ S_doeval(pTHX_ int gimme, OP** startop) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; + CvOUTSIDE_SEQ(PL_compcv) = seq; + CvOUTSIDE(PL_compcv) = outside ? (CV*)SvREFCNT_inc(outside) : outside; + /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); - if (!saveop || - (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) - { - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); - } SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ @@ -2743,8 +2774,6 @@ S_doeval(pTHX_ int gimme, OP** startop) CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; - SvREFCNT_dec(CvOUTSIDE(PL_compcv)); - CvOUTSIDE(PL_compcv) = Nullcv; } else SAVEFREEOP(PL_eval_root); if (gimme & G_VOID) @@ -3168,7 +3197,7 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = Nullsv; - op = DOCATCH(doeval(gimme, NULL)); + op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); /* Restore encoding. */ PL_encoding = encoding; @@ -3192,6 +3221,7 @@ PP(pp_entereval) char *safestr; STRLEN len; OP *ret; + CV* runcv; if (!SvPV(sv,len)) RETPUSHUNDEF; @@ -3239,6 +3269,7 @@ PP(pp_entereval) PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); SAVEFREESV(PL_compiling.cop_io); } + runcv = find_runcv(); push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); @@ -3249,7 +3280,7 @@ PP(pp_entereval) if (PERLDB_LINE && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_linestr); PUTBACK; - ret = doeval(gimme, NULL); + ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ && ret != PL_op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ diff --git a/pp_hot.c b/pp_hot.c index 0b3d622..03855f3 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2624,8 +2624,8 @@ try_autoload: CvDEPTH(cv)++; /* XXX This would be a natural place to set C so * that eval'' ops within this sub know the correct lexical space. - * Owing the speed considerations, we choose to search for the cv - * in doeval() instead. + * Owing the speed considerations, we choose instead to search for + * the cv using find_runcv() when calling doeval(). */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); diff --git a/proto.h b/proto.h index 5a48fd3..b5ade02 100644 --- a/proto.h +++ b/proto.h @@ -1112,7 +1112,7 @@ STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub(pTHX_ I32 startingblock); STATIC I32 S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock); STATIC void S_save_lines(pTHX_ AV *array, SV *sv); -STATIC OP* S_doeval(pTHX_ int gimme, OP** startop); +STATIC OP* S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq); STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode); STATIC bool S_path_is_absolute(pTHX_ char *name); #endif @@ -1360,7 +1360,7 @@ STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I #endif PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ padnew_flags flags); -PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv, CV* outercv); +PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv); PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool clone); PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type); PERL_CALLCONV void Perl_pad_check_dup(pTHX_ char* name, bool is_our, HV* ourstash); @@ -1375,12 +1375,13 @@ PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv PERL_CALLCONV void Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args); #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) -STATIC PADOFFSET S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags); +STATIC PADOFFSET S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, CV* innercv); # if defined(DEBUGGING) STATIC void S_cv_dump(pTHX_ CV *cv, char *title); # endif STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside); #endif +PERL_CALLCONV CV* Perl_find_runcv(pTHX); diff --git a/sv.c b/sv.c index 4d48bc7..9597a8a 100644 --- a/sv.c +++ b/sv.c @@ -9602,10 +9602,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) CvDEPTH(dstr) = 0; } PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + /* anon prototypes aren't refcounted */ if (!CvANON(sstr) || CvCLONED(sstr)) CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param); else CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); + CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); CvFLAGS(dstr) = CvFLAGS(sstr); CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; diff --git a/sv.h b/sv.h index a77a193..393f88f 100644 --- a/sv.h +++ b/sv.h @@ -318,7 +318,9 @@ struct xpvfm { AV * xcv_padlist; CV * xcv_outside; cv_flags_t xcv_flags; - + U32 xcv_outside_seq; /* the COP sequence (at the point of our + * compilation) in the lexically enclosing + * sub */ IV xfm_lines; }; diff --git a/t/op/eval.t b/t/op/eval.t index 5897b2b..6487b9e 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -1,6 +1,6 @@ #!./perl -print "1..46\n"; +print "1..77\n"; eval 'print "ok 1\n";'; @@ -118,19 +118,20 @@ EOT # calls outside eval'' should NOT clone lexicals from called context -$main::x = 'ok'; +$main::ok = 'not ok'; +my $ok = 'ok'; eval <<'EOT'; die if $@; # $x unbound here sub do_eval3 { eval $_[0]; die if $@; } EOT -do_eval3('print "$x ' . $x . '\n"'); -$x++; -do_eval3('eval q[print "$x ' . $x . '\n"]'); -$x++; -do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()'); -$x++; +{ + my $ok = 'not ok'; + do_eval3('print "$ok ' . $x++ . '\n"'); + do_eval3('eval q[print "$ok ' . $x++ . '\n"]'); + do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()'); +} # can recursive subroutine-call inside eval'' see its own lexicals? sub recurse { @@ -241,3 +242,104 @@ print $@; eval q{}; print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n"; } + +# DAPM Nov-2002. Perl should now capture the full lexical context during +# evals. + +$::zzz = $::zzz = 0; +my $zzz = 1; + +eval q{ + sub fred1 { + eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"} + } + fred1(47); + { my $zzz = 2; fred1(48) } +}; + +eval q{ + sub fred2 { + print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n"; + } +}; +fred2(49); +{ my $zzz = 2; fred2(50) } + +# sort() starts a new context stack. Make sure we can still find +# the lexically enclosing sub + +sub do_sort { + my $zzz = 2; + my @a = sort + { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b } + 2, 1; +} +do_sort(); + +# more recursion and lexical scope leak tests + +eval q{ + my $r = -1; + my $yyy = 9; + sub fred3 { + my $l = shift; + my $r = -2; + return 1 if $l < 1; + return 0 if eval '$zzz' != 1; + return 0 if $yyy != 9; + return 0 if eval '$yyy' != 9; + return 0 if eval '$l' != $l; + return $l * fred3($l-1); + } + my $r = fred3(5); + print $r == 120 ? 'ok' : 'not ok', " 52\n"; + $r = eval'fred3(5)'; + print $r == 120 ? 'ok' : 'not ok', " 53\n"; + $r = 0; + eval '$r = fred3(5)'; + print $r == 120 ? 'ok' : 'not ok', " 54\n"; + $r = 0; + { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; + print $r == 120 ? 'ok' : 'not ok', " 55\n"; +}; +my $r = fred3(5); +print $r == 120 ? 'ok' : 'not ok', " 56\n"; +$r = eval'fred3(5)'; +print $r == 120 ? 'ok' : 'not ok', " 57\n"; +$r = 0; +eval'$r = fred3(5)'; +print $r == 120 ? 'ok' : 'not ok', " 58\n"; +$r = 0; +{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; +print $r == 120 ? 'ok' : 'not ok', " 59\n"; + +# check that goto &sub within evals doesn't leak lexical scope + +my $yyy = 2; + +my $test = 60; +sub fred4 { + my $zzz = 3; + print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n"; + $test++; + print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; + $test++; +} + +eval q{ + fred4(); + sub fred5 { + my $zzz = 4; + print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n"; + $test++; + print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n"; + $test++; + goto &fred4; + } + fred5(); +}; +fred5(); +{ my $yyy = 88; my $zzz = 99; fred5(); } +eval q{ my $yyy = 888; my $zzz = 999; fred5(); } + + diff --git a/toke.c b/toke.c index aff4549..7d73497 100644 --- a/toke.c +++ b/toke.c @@ -7568,6 +7568,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) PL_subline = CopLINE(PL_curcop); CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv); + CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; return oldsavestack_ix; }