This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
allow evals to see the full lexical scope
authorDave Mitchell <davem@fdisolutions.com>
Sun, 24 Nov 2002 22:19:06 +0000 (22:19 +0000)
committerhv <hv@crypt.org>
Mon, 2 Dec 2002 00:58:54 +0000 (00:58 +0000)
Message-ID: <20021124221906.A25386@fdgroup.com>

p4raw-id: //depot/perl@18220

21 files changed:
cop.h
cv.h
dump.c
embed.fnc
embed.h
ext/B/B.pm
ext/B/B.xs
ext/B/B/Bytecode.pm
ext/B/B/C.pm
ext/B/B/Debug.pm
ext/Devel/Peek/Peek.t
op.c
pad.c
pod/perlintern.pod
pp_ctl.c
pp_hot.c
proto.h
sv.c
sv.h
t/op/eval.t
toke.c

diff --git a/cop.h b/cop.h
index fe0ca8a..870225c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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)));
index c115249..08a8f9d 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #  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
 #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
 #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)
 #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)
index c1bd852..f75e54b 100644 (file)
@@ -843,6 +843,8 @@ IoIFP($io) == PerlIO_stdin() ).
 
 =item OUTSIDE
 
+=item OUTSIDE_SEQ
+
 =item XSUB
 
 =item XSUBANY
index f24d070..9001031 100644 (file)
@@ -1412,6 +1412,10 @@ B::CV
 CvOUTSIDE(cv)
        B::CV   cv
 
+U32
+CvOUTSIDE_SEQ(cv)
+       B::CV   cv
+
 void
 CvXSUB(cv)
        B::CV   cv
index dd49c02..d1125bd 100644 (file)
@@ -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).
index 77582d2..9ae2359 100644 (file)
@@ -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
index f9f8c09..da8b147 100644 (file)
@@ -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;
index 1230026..529d3c9 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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);
index de1f4b2..0ec74e0 100644 (file)
@@ -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
index a43e629..76a2466 100644 (file)
--- 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. */
index 0b3d622..03855f3 100644 (file)
--- 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<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);
diff --git a/proto.h b/proto.h
index 5a48fd3..b5ade02 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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;
 };
 
index 5897b2b..6487b9e 100755 (executable)
@@ -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 (file)
--- 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;
 }