Change 18220 by [EMAIL PROTECTED] on 2002/12/02 00:58:54
Subject: [PATCH 2nd attempt] allow evals to see the full lexical scope
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Sun, 24 Nov 2002 22:19:06 +0000
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/cop.h#72 edit
.... //depot/perl/cv.h#39 edit
.... //depot/perl/dump.c#127 edit
.... //depot/perl/embed.fnc#56 edit
.... //depot/perl/embed.h#372 edit
.... //depot/perl/ext/B/B.pm#49 edit
.... //depot/perl/ext/B/B.xs#80 edit
.... //depot/perl/ext/B/B/Bytecode.pm#28 edit
.... //depot/perl/ext/B/B/C.pm#68 edit
.... //depot/perl/ext/B/B/Debug.pm#18 edit
.... //depot/perl/ext/Devel/Peek/Peek.t#19 edit
.... //depot/perl/op.c#529 edit
.... //depot/perl/pad.c#5 edit
.... //depot/perl/pod/perlintern.pod#24 edit
.... //depot/perl/pp_ctl.c#328 edit
.... //depot/perl/pp_hot.c#296 edit
.... //depot/perl/proto.h#415 edit
.... //depot/perl/sv.c#601 edit
.... //depot/perl/sv.h#127 edit
.... //depot/perl/t/op/eval.t#21 edit
.... //depot/perl/toke.c#451 edit
Differences ...
==== //depot/perl/cop.h#72 (text) ====
Index: perl/cop.h
--- perl/cop.h#71~18048~ Tue Oct 22 10:04:26 2002
+++ perl/cop.h Sun Dec 1 16:58:54 2002
@@ -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 {
==== //depot/perl/cv.h#39 (text) ====
Index: perl/cv.h
--- perl/cv.h#38~18030~ Sat Oct 19 07:10:21 2002
+++ perl/cv.h Sun Dec 1 16:58:54 2002
@@ -30,6 +30,9 @@
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 @@
#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 */
==== //depot/perl/dump.c#127 (text) ====
Index: perl/dump.c
--- perl/dump.c#126~18177~ Sun Nov 24 18:37:07 2002
+++ perl/dump.c Sun Dec 1 16:58:54 2002
@@ -1287,6 +1287,7 @@
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)));
==== //depot/perl/embed.fnc#56 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#55~18102~ Mon Nov 4 13:43:53 2002
+++ perl/embed.fnc Sun Dec 1 16:58:54 2002
@@ -1070,7 +1070,7 @@
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 @@
#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_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
==== //depot/perl/embed.h#372 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#371~18102~ Mon Nov 4 13:43:53 2002
+++ perl/embed.h Sun Dec 1 16:58:54 2002
@@ -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)
==== //depot/perl/ext/B/B.pm#49 (text) ====
Index: perl/ext/B/B.pm
--- perl/ext/B/B.pm#48~18114~ Wed Nov 6 12:08:53 2002
+++ perl/ext/B/B.pm Sun Dec 1 16:58:54 2002
@@ -843,6 +843,8 @@
=item OUTSIDE
+=item OUTSIDE_SEQ
+
=item XSUB
=item XSUBANY
==== //depot/perl/ext/B/B.xs#80 (text) ====
Index: perl/ext/B/B.xs
--- perl/ext/B/B.xs#79~18030~ Sat Oct 19 07:10:21 2002
+++ perl/ext/B/B.xs Sun Dec 1 16:58:54 2002
@@ -1412,6 +1412,10 @@
CvOUTSIDE(cv)
B::CV cv
+U32
+CvOUTSIDE_SEQ(cv)
+ B::CV cv
+
void
CvXSUB(cv)
B::CV cv
==== //depot/perl/ext/B/B/Bytecode.pm#28 (text) ====
Index: perl/ext/B/B/Bytecode.pm
--- perl/ext/B/B/Bytecode.pm#27~13034~ Thu Nov 15 16:38:41 2001
+++ perl/ext/B/B/Bytecode.pm Sun Dec 1 16:58:54 2002
@@ -652,7 +652,8 @@
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).
==== //depot/perl/ext/B/B/C.pm#68 (text) ====
Index: perl/ext/B/B/C.pm
--- perl/ext/B/B/C.pm#67~18056~ Thu Oct 24 15:48:06 2002
+++ perl/ext/B/B/C.pm Sun Dec 1 16:58:54 2002
@@ -1012,10 +1012,11 @@
$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 @@
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
==== //depot/perl/ext/B/B/Debug.pm#18 (text) ====
Index: perl/ext/B/B/Debug.pm
--- perl/ext/B/B/Debug.pm#17~13034~ Thu Nov 15 16:38:41 2001
+++ perl/ext/B/B/Debug.pm Sun Dec 1 16:58:54 2002
@@ -198,7 +198,7 @@
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 @@
DEPTH %d
PADLIST 0x%x
OUTSIDE 0x%x
+ OUTSIDE_SEQ %d
EOT
$start->debug if $start;
$root->debug if $root;
==== //depot/perl/ext/Devel/Peek/Peek.t#19 (text) ====
Index: perl/ext/Devel/Peek/Peek.t
--- perl/ext/Devel/Peek/Peek.t#18~18216~ Fri Nov 29 02:00:54 2002
+++ perl/ext/Devel/Peek/Peek.t Sun Dec 1 16:58:54 2002
@@ -221,6 +221,7 @@
(?: MUTEXP = $ADDR
OWNER = $ADDR
)? FLAGS = 0x4
+ OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
OUTSIDE = $ADDR \\(MAIN\\)');
@@ -247,6 +248,7 @@
(?: MUTEXP = $ADDR
OWNER = $ADDR
)? FLAGS = 0x0
+ OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
\\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
==== //depot/perl/op.c#529 (text) ====
Index: perl/op.c
--- perl/op.c#528~18166~ Tue Nov 19 15:02:31 2002
+++ perl/op.c Sun Dec 1 16:58:54 2002
@@ -3756,7 +3756,6 @@
void
Perl_cv_undef(pTHX_ CV *cv)
{
- CV *outsidecv;
CV *freecv = Nullcv;
#ifdef USE_ITHREADS
@@ -3780,20 +3779,21 @@
}
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 @@
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;
==== //depot/perl/pad.c#5 (text) ====
Index: perl/pad.c
--- perl/pad.c#4~18048~ Tue Oct 22 10:04:26 2002
+++ perl/pad.c Sun Dec 1 16:58:54 2002
@@ -194,13 +194,13 @@
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 @@
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 @@
&& 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 @@
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 @@
}
}
- 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 @@
=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 @@
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 @@
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 @@
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 @@
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);
==== //depot/perl/pod/perlintern.pod#24 (text+w) ====
Index: perl/pod/perlintern.pod
--- perl/pod/perlintern.pod#23~18048~ Tue Oct 22 10:04:26 2002
+++ perl/pod/perlintern.pod Sun Dec 1 16:58:54 2002
@@ -216,6 +216,23 @@
=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 @@
=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 @@
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
==== //depot/perl/pp_ctl.c#328 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#327~18176~ Sun Nov 24 18:31:10 2002
+++ perl/pp_ctl.c Sun Dec 1 16:58:54 2002
@@ -2572,6 +2572,8 @@
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
+ int runtime;
+ CV* runcv;
ENTER;
lex_start(sv);
@@ -2610,12 +2612,21 @@
#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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
char *safestr;
STRLEN len;
OP *ret;
+ CV* runcv;
if (!SvPV(sv,len))
RETPUSHUNDEF;
@@ -3239,6 +3269,7 @@
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 @@
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. */
==== //depot/perl/pp_hot.c#296 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#295~18159~ Tue Nov 19 03:48:30 2002
+++ perl/pp_hot.c Sun Dec 1 16:58:54 2002
@@ -2624,8 +2624,8 @@
CvDEPTH(cv)++;
/* XXX This would be a natural place to set C<PL_compcv = cv> 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);
==== //depot/perl/proto.h#415 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#414~18113~ Tue Nov 5 12:11:55 2002
+++ perl/proto.h Sun Dec 1 16:58:54 2002
@@ -1112,7 +1112,7 @@
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 @@
#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_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);
==== //depot/perl/sv.c#601 (text) ====
Index: perl/sv.c
--- perl/sv.c#600~18186~ Tue Nov 26 16:57:18 2002
+++ perl/sv.c Sun Dec 1 16:58:54 2002
@@ -9602,10 +9602,12 @@
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;
==== //depot/perl/sv.h#127 (text) ====
Index: perl/sv.h
--- perl/sv.h#126~18151~ Sat Nov 16 12:45:26 2002
+++ perl/sv.h Sun Dec 1 16:58:54 2002
@@ -318,7 +318,9 @@
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;
};
==== //depot/perl/t/op/eval.t#21 (xtext) ====
Index: perl/t/op/eval.t
--- perl/t/op/eval.t#20~17443~ Tue Jul 9 08:41:57 2002
+++ perl/t/op/eval.t Sun Dec 1 16:58:54 2002
@@ -1,6 +1,6 @@
#!./perl
-print "1..46\n";
+print "1..77\n";
eval 'print "ok 1\n";';
@@ -118,19 +118,20 @@
# 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 @@
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(); }
+
+
==== //depot/perl/toke.c#451 (text) ====
Index: perl/toke.c
--- perl/toke.c#450~18072~ Tue Oct 29 12:37:31 2002
+++ perl/toke.c Sun Dec 1 16:58:54 2002
@@ -7568,6 +7568,7 @@
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;
}
End of Patch.
