jumbo closure fix
Dave Mitchell [Wed, 26 Feb 2003 14:49:47 +0000 (14:49 +0000)]
Message-ID: <20030226144947.A14444@fdgroup.com>

p4raw-id: //depot/perl@19637

15 files changed:
embed.fnc
embed.h
embedvar.h
ext/Devel/Peek/Peek.t
intrpvar.h
op.c
pad.c
perlapi.h
pod/perldiag.pod
pod/perlintern.pod
pod/perlref.pod
proto.h
regcomp.c
t/lib/warnings/pad
t/op/closure.t

index b28230e..be08619 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1375,11 +1375,12 @@ 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|CV* innercv
+sd     |PADOFFSET|pad_findlex  |char *name|CV* cv|U32 seq|int warn \
+                               |SV** out_capture|SV** out_name_sv \
+                               |int *out_flags
 #  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     |U32 *db_seqp
 p      |void   |free_tied_hv_pool
diff --git a/embed.h b/embed.h
index 71270d8..5907e20 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define cv_dump                        S_cv_dump
 #endif
 #  endif
-#ifdef PERL_CORE
-#define cv_clone2              S_cv_clone2
-#endif
 #endif
 #ifdef PERL_CORE
 #define find_runcv             Perl_find_runcv
 #endif
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define pad_findlex(a,b,c)     S_pad_findlex(aTHX_ a,b,c)
+#define pad_findlex(a,b,c,d,e,f,g)     S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
 #endif
 #  if defined(DEBUGGING)
 #ifdef PERL_CORE
 #define cv_dump(a,b)           S_cv_dump(aTHX_ a,b)
 #endif
 #  endif
-#ifdef PERL_CORE
-#define cv_clone2(a,b)         S_cv_clone2(aTHX_ a,b)
-#endif
 #endif
 #ifdef PERL_CORE
 #define find_runcv(a)          Perl_find_runcv(aTHX_ a)
index 7bf5499..a1b5720 100644 (file)
 #define PL_curstname           (vTHX->Icurstname)
 #define PL_custom_op_descs     (vTHX->Icustom_op_descs)
 #define PL_custom_op_names     (vTHX->Icustom_op_names)
+#define PL_cv_has_eval         (vTHX->Icv_has_eval)
 #define PL_dbargs              (vTHX->Idbargs)
 #define PL_debstash            (vTHX->Idebstash)
 #define PL_debug               (vTHX->Idebug)
 #define PL_Icurstname          PL_curstname
 #define PL_Icustom_op_descs    PL_custom_op_descs
 #define PL_Icustom_op_names    PL_custom_op_names
+#define PL_Icv_has_eval                PL_cv_has_eval
 #define PL_Idbargs             PL_dbargs
 #define PL_Idebstash           PL_debstash
 #define PL_Idebug              PL_debug
index 30d4e62..77c468d 100644 (file)
@@ -252,7 +252,7 @@ do_test(14,
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
-      \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"
+      \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
     OUTSIDE = $ADDR \\(MAIN\\)');
 
index 5206c06..f412e9f 100644 (file)
@@ -527,6 +527,8 @@ PERLVAR(IDBassertion,   SV *)
 
 /* Don't forget to add your variable also to perl_clone()! */
 
+PERLVARI(Icv_has_eval, I32, 0) /* PL_compcv includes an entereval or similar */
+
 /* New variables must be added to the very end, before this comment,
  * for binary compatibility (the offsets of the old members must not change).
  * XSUB.h provides wrapper functions via perlapi.h that make this
diff --git a/op.c b/op.c
index 80a0e9b..efb94b6 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2653,6 +2653,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
                           : OPf_KIDS);
        rcop->op_private = 1;
        rcop->op_other = o;
+       /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
+       PL_cv_has_eval = 1;
 
        /* establish postfix order */
        if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
@@ -3886,6 +3888,26 @@ Perl_cv_const_sv(pTHX_ CV *cv)
     return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
+/* op_const_sv:  examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ *     look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ *     examine the clone prototype, and if contains only a single
+ *     OP_CONST referencing a pad const, or a single PADSV referencing
+ *     an outer lexical, return a non-zero value to indicate the CV is
+ *     a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ *     We have just cloned an anon prototype that was marked as a const
+ *     candidiate. Try to grab the current value, and in the case of
+ *     PADSV, ignore it if it has multiple references. Return the value.
+ */
+
 SV *
 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
@@ -3914,26 +3936,31 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
            return Nullsv;
        if (type == OP_CONST && cSVOPo->op_sv)
            sv = cSVOPo->op_sv;
-       else if ((type == OP_PADSV || type == OP_CONST) && cv) {
+       else if (cv && type == OP_CONST) {
            sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
            if (!sv)
                return Nullsv;
-           if (CvCONST(cv)) {
-               /* We get here only from cv_clone2() while creating a closure.
-                  Copy the const value here instead of in cv_clone2 so that
-                  SvREADONLY_on doesn't lead to problems when leaving
-                  scope.
-               */
+       }
+       else if (cv && type == OP_PADSV) {
+           if (CvCONST(cv)) { /* newly cloned anon */
+               sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+               /* the candidate should have 1 ref from this pad and 1 ref
+                * from the parent */
+               if (!sv || SvREFCNT(sv) != 2)
+                   return Nullsv;
                sv = newSVsv(sv);
+               SvREADONLY_on(sv);
+               return sv;
+           }
+           else {
+               if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+                   sv = &PL_sv_undef; /* an arbitrary non-null value */
            }
-           if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
-               return Nullsv;
        }
-       else
+       else {
            return Nullsv;
+       }
     }
-    if (sv)
-       SvREADONLY_on(sv);
     return sv;
 }
 
@@ -4135,6 +4162,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
        /* ... before we throw it away */
        SvREFCNT_dec(PL_compcv);
+       PL_compcv = cv;
        if (PERLDB_INTER)/* Advice debugger on the new sub. */
          ++PL_sub_generation;
     }
@@ -4784,8 +4812,10 @@ Perl_ck_eval(pTHX_ OP *o)
            enter->op_other = o;
            return o;
        }
-       else
+       else {
            scalar((OP*)kid);
+           PL_cv_has_eval = 1;
+       }
     }
     else {
        op_free(o);
diff --git a/pad.c b/pad.c
index 3856b47..8e78c73 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1,6 +1,6 @@
 /*    pad.c
  *
- *    Copyright (C) 2002, by Larry Wall and others
+ *    Copyright (C) 2002,2003 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -27,7 +27,8 @@ CV's can have CvPADLIST(cv) set to point to an AV.
 
 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
 not callable at will and are always thrown away after the eval"" is done
-executing).
+executing). Require'd files are simply evals without any outer lexical
+scope.
 
 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
 but that is really the callers pad (a slot of which is allocated by
@@ -73,10 +74,14 @@ stash of the associated global (so that duplicate C<our> delarations in the
 same package can be detected).  SvCUR is sometimes hijacked to
 store the generation number during compilation.
 
-If SvFAKE is set on the name SV then slot in the frame AVs are
-a REFCNT'ed references to a lexical from "outside". In this case,
-the name SV does not have a cop_seq range, since it is in scope
-throughout.
+If SvFAKE is set on the name SV, then that slot in the frame AV is
+a REFCNT'ed reference to a lexical from "outside". In this case,
+the name SV does not use NVX and IVX to store a cop_seq range, since it is
+in scope throughout. Instead IVX stores some flags containing info about
+the real lexical (is it declared in an anon, and is it capable of being
+instantiated multiple times?), and for fake ANONs, NVX contains the index
+within the parent's pad where the lexical's value is stored, to make
+cloning quicker.
 
 If the 'name' is '&' the corresponding entry in frame AV
 is a CV representing a possible closure.
@@ -133,6 +138,7 @@ Perl_pad_new(pTHX_ int flags)
            SAVEI32(PL_comppad_name_fill);
            SAVEI32(PL_min_intro_pending);
            SAVEI32(PL_max_intro_pending);
+           SAVEI32(PL_cv_has_eval);
            if (flags & padnew_SAVESUB) {
                SAVEI32(PL_pad_reset_pending);
            }
@@ -176,12 +182,13 @@ Perl_pad_new(pTHX_ int flags)
        PL_comppad_name_fill = 0;
        PL_min_intro_pending = 0;
        PL_padix             = 0;
+       PL_cv_has_eval       = 0;
     }
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
-         "Pad 0x%"UVxf"[0x%"UVxf"] new:       padlist=0x%"UVxf
+         "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
              " name=0x%"UVxf" flags=0x%"UVxf"\n",
-         PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
+         PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
              PTR2UV(padname), (UV)flags
        )
     );
@@ -216,7 +223,8 @@ Perl_pad_undef(pTHX_ CV* cv)
        return;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
-         "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
+         "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
+           PTR2UV(cv), PTR2UV(padlist))
     );
 
     /* detach any '&' anon children in the pad; if afterwards they
@@ -278,26 +286,18 @@ Perl_pad_undef(pTHX_ CV* cv)
 /*
 =for apidoc pad_add_name
 
-Create a new name in the current pad at the specified offset.
+Create a new name and associated PADMY SV in the current pad; return the
+offset.
 If C<typestash> is valid, the name is for a typed lexical; set the
 name's stash to that value.
 If C<ourstash> is valid, it's an our lexical, set the name's
 GvSTASH to that value
 
-Also, if the name is @.. or %.., create a new array or hash for that slot
-
 If fake, it means we're cloning an existing entry
 
 =cut
 */
 
-/*
- * XXX DAPM this doesn't seem the right place to create a new array/hash.
- * Whatever we do, we should be consistent - create scalars too, and
- * create even if fake. Really need to integrate better the whole entry
- * creation business - when + where does the name and value get created?
- */
-
 PADOFFSET
 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
 {
@@ -307,12 +307,6 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
     ASSERT_CURPAD_ACTIVE("pad_add_name");
 
 
-    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-         "Pad addname: %ld \"%s\"%s\n",
-          (long)offset, name, (fake ? " FAKE" : "")
-         )
-    );
-
     sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
     sv_setpv(namesv, name);
 
@@ -326,8 +320,11 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
     }
 
     av_store(PL_comppad_name, offset, namesv);
-    if (fake)
+    if (fake) {
        SvFAKE_on(namesv);
+       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+           "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
+    }
     else {
        /* not yet introduced */
        SvNVX(namesv) = (NV)PAD_MAX;    /* min */
@@ -336,6 +333,7 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
        if (!PL_min_intro_pending)
            PL_min_intro_pending = offset;
        PL_max_intro_pending = offset;
+       /* if it's not a simple scalar, replace with an AV or HV */
        /* XXX DAPM since slot has been allocated, replace
         * av_store with PL_curpad[offset] ? */
        if (*name == '@')
@@ -343,6 +341,9 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
        else if (*name == '%')
            av_store(PL_comppad, offset, (SV*)newHV());
        SvPADMY_on(PL_curpad[offset]);
+       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+           "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
+           (long)offset, name, PTR2UV(PL_curpad[offset])));
     }
 
     return offset;
@@ -516,7 +517,6 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
 }
 
 
-
 /*
 =for apidoc pad_findmy
 
@@ -532,234 +532,257 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure.
 PADOFFSET
 Perl_pad_findmy(pTHX_ char *name)
 {
-    I32 off;
-    I32 fake_off = 0;
-    SV *sv;
-    SV **svp = AvARRAY(PL_comppad_name);
-    U32 seq = PL_cop_seqmax;
-
-    ASSERT_CURPAD_ACTIVE("pad_findmy");
-    DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy:  \"%s\"\n", name));
-
-    /* The one we're looking for is probably just before comppad_name_fill. */
-    for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
-       sv = svp[off];
-       if (!sv || sv == &PL_sv_undef || !strEQ(SvPVX(sv), name))
-           continue;
-       if (SvFAKE(sv)) {
-           /* we'll use this later if we don't find a real entry */
-           fake_off = off;
-           continue;
-       }
-       else {
-           if (   seq >  (U32)I_32(SvNVX(sv))  /* min */
-               && seq <= (U32)SvIVX(sv))       /* max */
-               return off;
-       }
-    }
-    if (fake_off)
-       return fake_off;
+    SV *out_sv;
+    int out_flags;
 
-    /* See if it's in a nested scope */
-    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 */
-
-    return off;
+    return pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
+               Null(SV**), &out_sv, &out_flags);
 }
 
 
-
 /*
 =for apidoc pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries
-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.
+in the inner pads if it's found in an outer one.
+
+Returns the offset in the bottom pad of the lex or the fake lex.
+cv is the CV in which to start the search, and seq is the current cop_seq
+to match against. If warn is true, print appropriate warnings.  The out_*
+vars return values, and so are pointers to where the returned values
+should be stored. out_capture, if non-null, requests that the innermost
+instance of the lexical is captured; out_name_sv is set to the innermost
+matched namesv or fake namesv; out_flags returns the flags normally
+associated with the IVX field of a fake namesv.
+
+Note that pad_findlex() is recursive; it recurses up the chain of CVs,
+then comes back down, adding fake entries as it goes. It has to be this way
+because fake namesvs in anon protoypes have to store in NVX the index into
+the parent pad.
 
 =cut
 */
 
+/* Flags set in the SvIVX field of FAKE namesvs */
+
+#define PAD_FAKELEX_ANON   1 /* the lex is declared in an ANON, or ... */
+#define PAD_FAKELEX_MULTI  2 /* the lex can be instantiated multiple times */
+
+/* the CV has finished being compiled. This is not a sufficient test for
+ * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
+#define CvCOMPILED(cv) CvROOT(cv)
+
+
 STATIC PADOFFSET
-S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv)
+S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
+       SV** out_capture, SV** out_name_sv, int *out_flags)
 {
-    CV *cv;
-    I32 off = 0;
-    SV *sv;
-    CV* startcv;
-    U32 seq;
-    I32 depth;
-    AV *oldpad;
-    SV *oldsv;
-    AV *curlist;
-
-    ASSERT_CURPAD_ACTIVE("pad_findlex");
-    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-       "Pad findlex: \"%s\" off=%ld startcv=0x%"UVxf"\n",
-           name, (long)newoff, PTR2UV(innercv))
-    );
+    I32 offset, new_offset;
+    SV *new_capture;
+    SV **new_capturep;
+    AV *padlist = CvPADLIST(cv);
 
-    seq = CvOUTSIDE_SEQ(innercv);
-    startcv = CvOUTSIDE(innercv);
+    *out_flags = 0;
 
-    for (cv = startcv; cv; seq = CvOUTSIDE_SEQ(cv), cv = CvOUTSIDE(cv)) {
-       SV **svp;
-       AV *curname;
-       I32 fake_off = 0;
+    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+       "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
+       PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
 
-       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-           "             searching: cv=0x%"UVxf" seq=%d\n",
-           PTR2UV(cv), (int) seq )
-       );
+    /* first, search this pad */
 
-       curlist = CvPADLIST(cv);
-       if (!curlist)
-           continue; /* an undef CV */
-       svp = av_fetch(curlist, 0, FALSE);
-       if (!svp || *svp == &PL_sv_undef)
-           continue;
-       curname = (AV*)*svp;
-       svp = AvARRAY(curname);
+    if (padlist) { /* not an undef CV */
+       I32 fake_offset = 0;
+       AV *nameav = (AV*)AvARRAY(padlist)[0];
+       SV **name_svp = AvARRAY(nameav);
 
-       depth = CvDEPTH(cv);
-       for (off = AvFILLp(curname); off > 0; off--) {
-           sv = svp[off];
-           if (!sv || sv == &PL_sv_undef || !strEQ(SvPVX(sv), name))
-               continue;
-           if (SvFAKE(sv)) {
-               /* we'll use this later if we don't find a real entry */
-               fake_off = off;
-               continue;
-           }
-           else {
-               if (   seq >  (U32)I_32(SvNVX(sv))      /* min */
-                   && seq <= (U32)SvIVX(sv)            /* max */
-                   && !(newoff && !depth) /* ignore inactive when cloning */
-               )
-                   goto found;
+       for (offset = AvFILLp(nameav); offset > 0; offset--) {
+           SV *namesv = name_svp[offset];
+           if (namesv && namesv != &PL_sv_undef
+                   && strEQ(SvPVX(namesv), name))
+           {
+               if (SvFAKE(namesv))
+                   fake_offset = offset; /* in case we don't find a real one */
+               else if (  seq >  (U32)I_32(SvNVX(namesv))      /* min */
+                       && seq <= (U32)SvIVX(namesv))           /* max */
+                   break;
            }
        }
 
-       /* no real entry - but did we find a fake one? */
-       if (fake_off) {
-           if (newoff && !depth)
-               return 0; /* don't clone from inactive stack frame */
-           off = fake_off;
-           sv = svp[off];
-           goto found;
-       }
-    }
-    return 0;
+       if (offset > 0 || fake_offset > 0 ) { /* a match! */
+           if (offset > 0) { /* not fake */
+               fake_offset = 0;
+               *out_name_sv = name_svp[offset]; /* return the namesv */
+
+               /* set PAD_FAKELEX_MULTI if this lex can have multiple
+                * instances. For now, we just test !CvUNIQUE(cv), but
+                * ideally, we should detect my's declared within loops
+                * etc - this would allow a wider range of 'not stayed
+                * shared' warnings. We also treated alreadly-compiled
+                * lexes as not multi as viewed from evals. */
+
+               *out_flags = CvANON(cv) ?
+                       PAD_FAKELEX_ANON :
+                           (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
+                               ? PAD_FAKELEX_MULTI : 0;
+
+               DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+                   "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
+                   PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
+                   (long)SvIVX(*out_name_sv)));
+           }
+           else { /* fake match */
+               offset = fake_offset;
+               *out_name_sv = name_svp[offset]; /* return the namesv */
+               *out_flags = SvIVX(*out_name_sv);
+               DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+                   "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%x index=%lu\n",
+                   PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
+                       (unsigned long)SvNVX(*out_name_sv) 
+               ));
+           }
 
-found:
+           /* return the lex? */
 
-    if (!depth) 
-       depth = 1;
+           if (out_capture) {
 
-    oldpad = (AV*)AvARRAY(curlist)[depth];
-    oldsv = *av_fetch(oldpad, off, TRUE);
+               /* our ? */
+               if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) {
+                   *out_capture = Nullsv;
+                   return offset;
+               }
 
-#ifdef DEBUGGING
-    if (SvFAKE(sv))
-       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-               "             matched:   offset %ld"
-                   " FAKE, sv=0x%"UVxf"\n",
-               (long)off,
-               PTR2UV(oldsv)
-           )
-       );
-    else
-       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-               "             matched:   offset %ld"
-                   " (%lu,%lu), sv=0x%"UVxf"\n",
-               (long)off,
-               (unsigned long)I_32(SvNVX(sv)),
-               (unsigned long)SvIVX(sv),
-               PTR2UV(oldsv)
-           )
-       );
-#endif
+               /* trying to capture from an anon prototype? */
+               if (CvCOMPILED(cv)
+                       ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
+                       : *out_flags & PAD_FAKELEX_ANON)
+               {
+                   if (warn && ckWARN(WARN_CLOSURE))
+                       Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+                           "Variable \"%s\" is not available", name);
+                   *out_capture = Nullsv;
+               }
 
-    if (!newoff) {             /* Not a mere clone operation. */
-       newoff = pad_add_name(
-           SvPVX(sv),
-           (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
-           (SvFLAGS(sv) & SVpad_OUR)   ? GvSTASH(sv) : Nullhv,
-           1  /* fake */
-       );
+               /* real value */
+               else {
+                   int newwarn = warn;
+                   if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
+                        && warn && ckWARN(WARN_CLOSURE)) {
+                       newwarn = 0;
+                       Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+                           "Variable \"%s\" will not stay shared", name);
+                   }
 
-       if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
-           /* "It's closures all the way down." */
-           CvCLONE_on(PL_compcv);
-           if (cv == startcv) {
-               if (CvANON(PL_compcv))
-                   oldsv = Nullsv; /* no need to keep ref */
-           }
-           else {
-               CV *bcv;
-               for (bcv = startcv;
-                    bcv && bcv != cv && !CvCLONE(bcv);
-                    bcv = CvOUTSIDE(bcv))
-               {
-                   if (CvANON(bcv)) {
-                       /* install the missing pad entry in intervening
-                        * nested subs and mark them cloneable. */
-                       AV *ocomppad_name = PL_comppad_name;
-                       PAD *ocomppad = PL_comppad;
-                       AV *padlist = CvPADLIST(bcv);
-                       PL_comppad_name = (AV*)AvARRAY(padlist)[0];
-                       PL_comppad = (AV*)AvARRAY(padlist)[1];
-                       PL_curpad = AvARRAY(PL_comppad);
-                       pad_add_name(
-                           SvPVX(sv),
-                           (SvFLAGS(sv) & SVpad_TYPED)
-                               ? SvSTASH(sv) : Nullhv,
-                           (SvFLAGS(sv) & SVpad_OUR)
-                               ? GvSTASH(sv) : Nullhv,
-                           1  /* fake */
-                       );
-
-                       PL_comppad_name = ocomppad_name;
-                       PL_comppad = ocomppad;
-                       PL_curpad = ocomppad ?
-                               AvARRAY(ocomppad) : Null(SV **);
-                       CvCLONE_on(bcv);
+                   if (fake_offset && CvANON(cv)
+                           && CvCLONE(cv) &&!CvCLONED(cv))
+                   {
+                       SV *n;
+                       /* not yet caught - look further up */
+                       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+                           "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
+                           PTR2UV(cv)));
+                       n = *out_name_sv;
+                       pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv),
+                           newwarn, out_capture, out_name_sv, out_flags);
+                       *out_name_sv = n;
+                       return offset;
                    }
-                   else {
-                       if (ckWARN(WARN_CLOSURE)
-                           && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
-                       {
+
+                   *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
+                                   CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
+                   DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+                       "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
+                       PTR2UV(cv), *out_capture));
+
+                   if (SvPADSTALE(*out_capture)) {
+                       if (ckWARN(WARN_CLOSURE))
                            Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                             "Variable \"%s\" may be unavailable",
-                                name);
-                       }
-                       break;
+                               "Variable \"%s\" is not available", name);
+                       *out_capture = Nullsv;
                    }
                }
+               if (!*out_capture) {
+                   if (*name == '@')
+                       *out_capture = sv_2mortal((SV*)newAV());
+                   else if (*name == '%')
+                       *out_capture = sv_2mortal((SV*)newHV());
+                   else
+                       *out_capture = sv_newmortal();
+               }
            }
+
+           return offset;
        }
-       else if (!CvUNIQUE(PL_compcv)) {
-           if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
-               && !(SvFLAGS(sv) & SVpad_OUR))
-           {
-               Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                   "Variable \"%s\" will not stay shared", name);
-           }
+    }
+
+    /* it's not in this pad - try above */
+
+    if (!CvOUTSIDE(cv))
+       return NOT_IN_PAD;
+    
+    /* out_capture non-null means caller wants us to capture lex; in
+     * addition we capture ourselves unless its an ANON */
+    new_capturep = out_capture ? out_capture :
+               CvANON(cv) ? Null(SV**) : &new_capture;
+
+    offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+               new_capturep, out_name_sv, out_flags);
+    if (offset == NOT_IN_PAD)
+       return NOT_IN_PAD;
+    
+    /* found in an outer CV. Add appropriate fake entry to this pad */
+
+    /* don't add new fake entries (via eval) to CVs that we have already
+     * finished compiling, or to undef CVs */
+    if (CvCOMPILED(cv) || !padlist)
+       return 0; /* this dummy (and invalid) value isnt used by the caller */
+
+    {
+       SV *new_namesv;
+       AV *ocomppad_name = PL_comppad_name;
+       PAD *ocomppad = PL_comppad;
+       PL_comppad_name = (AV*)AvARRAY(padlist)[0];
+       PL_comppad = (AV*)AvARRAY(padlist)[1];
+       PL_curpad = AvARRAY(PL_comppad);
+
+       new_offset = pad_add_name(
+           SvPVX(*out_name_sv),
+           (SvFLAGS(*out_name_sv) & SVpad_TYPED)
+                   ? SvSTASH(*out_name_sv) : Nullhv,
+           (SvFLAGS(*out_name_sv) & SVpad_OUR)
+                   ? GvSTASH(*out_name_sv) : Nullhv,
+           1  /* fake */
+       );
+
+       new_namesv = AvARRAY(PL_comppad_name)[new_offset];
+       SvIVX(new_namesv) = *out_flags;
+
+       SvNVX(new_namesv) = (NV)0;
+       if (SvFLAGS(new_namesv) & SVpad_OUR) {
+          /* do nothing */
+       }
+       else if (CvANON(cv)) {
+           /* delayed creation - just note the offset within parent pad */
+           SvNVX(new_namesv) = (NV)offset;
+           CvCLONE_on(cv);
        }
+       else {
+           /* immediate creation - capture outer value right now */
+           av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
+           DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+               "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
+               PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
+       }
+       *out_name_sv = new_namesv;
+       *out_flags = SvIVX(new_namesv);
+
+       PL_comppad_name = ocomppad_name;
+       PL_comppad = ocomppad;
+       PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **);
     }
-    av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
-    ASSERT_CURPAD_ACTIVE("pad_findlex 2");
-    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-               "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
-               (long)newoff, PTR2UV(oldsv)
-           )
-    );
-    return newoff;
+    return new_offset;
 }
 
-
+               
 /*
 =for apidoc pad_sv
 
@@ -871,9 +894,9 @@ Perl_intro_my(pTHX)
            SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
            SvNVX(sv) = (NV)PL_cop_seqmax;
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-               "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
+               "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
                (long)i, SvPVX(sv),
-               (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+               (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
            );
        }
     }
@@ -919,9 +942,9 @@ Perl_pad_leavemy(pTHX)
        {
            SvIVX(sv) = PL_cop_seqmax;
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-               "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
+               "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
                (long)off, SvPVX(sv),
-               (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+               (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
            );
        }
     }
@@ -1029,14 +1052,38 @@ void
 Perl_pad_tidy(pTHX_ padtidy_type type)
 {
     PADOFFSET ix;
+    CV *cv;
 
     ASSERT_CURPAD_ACTIVE("pad_tidy");
+
+    /* If this CV has had any 'eval-capable' ops planted in it
+     * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
+     * anon prototypes in the chain of CVs should be marked as cloneable,
+     * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
+     * the right CvOUTSIDE.
+     * If running with -d, *any* sub may potentially have an eval
+     * excuted within it.
+     */
+
+    if (PL_cv_has_eval || PL_perldb) {
+       for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
+           if (cv != PL_compcv && CvCOMPILED(cv))
+               break; /* no need to mark already-compiled code */
+           if (CvANON(cv)) {
+               DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+                   "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
+               CvCLONE_on(cv);
+           }
+       }
+    }
+
     /* extend curpad to match namepad */
     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
        av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
 
     if (type == padtidy_SUBCLONE) {
        SV **namep = AvARRAY(PL_comppad_name);
+
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            SV *namesv;
 
@@ -1044,13 +1091,12 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
                continue;
            /*
             * The only things that a clonable function needs in its
-            * pad are references to outer lexicals and anonymous subs.
+            * pad are anonymous subs.
             * The rest are created anew during cloning.
             */
            if (!((namesv = namep[ix]) != Nullsv &&
                  namesv != &PL_sv_undef &&
-                 (SvFAKE(namesv) ||
-                  *SvPVX(namesv) == '&')))
+                  *SvPVX(namesv) == '&'))
            {
                SvREFCNT_dec(PL_curpad[ix]);
                PL_curpad[ix] = Nullsv;
@@ -1168,20 +1214,23 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
        if (namesv) {
            if (SvFAKE(namesv))
                Perl_dump_indent(aTHX_ level+1, file,
-                   "%2d. 0x%"UVxf"<%lu> FAKE \"%s\"\n",
+                   "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
                    (int) ix,
                    PTR2UV(ppad[ix]),
                    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
-                   SvPVX(namesv)
+                   SvPVX(namesv),
+                   (unsigned long)SvIVX(namesv),
+                   (unsigned long)SvNVX(namesv)
+
                );
            else
                Perl_dump_indent(aTHX_ level+1, file,
-                   "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
+                   "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
                    (int) ix,
                    PTR2UV(ppad[ix]),
                    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
-                   (unsigned long)I_32(SvNVX(namesv)),
-                   (unsigned long)SvIVX(namesv),
+                   (long)I_32(SvNVX(namesv)),
+                   (long)SvIVX(namesv),
                    SvPVX(namesv)
                );
        }
@@ -1251,22 +1300,6 @@ any outer lexicals.
 CV *
 Perl_cv_clone(pTHX_ CV *proto)
 {
-    CV *cv;
-
-    LOCK_CRED_MUTEX;                   /* XXX create separate mutex */
-    cv = cv_clone2(proto, CvOUTSIDE(proto));
-    UNLOCK_CRED_MUTEX;                 /* XXX create separate mutex */
-    return cv;
-}
-
-
-/* XXX DAPM separate out cv and paddish bits ???
- * ideally the CV-related stuff shouldn't be in pad.c - how about
- * a cv.c? */
-
-STATIC CV *
-S_cv_clone2(pTHX_ CV *proto, CV *outside)
-{
     I32 ix;
     AV* protopadlist = CvPADLIST(proto);
     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
@@ -1277,9 +1310,17 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     I32 fpad = AvFILLp(protopad);
     AV* comppadlist;
     CV* cv;
+    SV** outpad;
+    CV* outside;
 
     assert(!CvUNIQUE(proto));
 
+    outside = find_runcv(NULL);
+    /* presumably whoever invoked us must be active */
+    assert(outside);
+    assert(CvDEPTH(outside));
+    assert(CvPADLIST(outside));
+
     ENTER;
     SAVESPTR(PL_compcv);
 
@@ -1298,39 +1339,35 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     CvSTASH(cv)                = CvSTASH(proto);
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)                = CvSTART(proto);
-    if (outside) {
-       CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
-       CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
-    }
+    CvOUTSIDE(cv)      = (CV*)SvREFCNT_inc(outside);
+    CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
 
     if (SvPOK(proto))
        sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
 
     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
 
+    av_fill(PL_comppad, fpad);
     for (ix = fname; ix >= 0; ix--)
        av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
 
-    av_fill(PL_comppad, fpad);
     PL_curpad = AvARRAY(PL_comppad);
 
+    outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[CvDEPTH(outside)]);
+
     for (ix = fpad; ix > 0; ix--) {
        SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+       SV *sv;
        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, cv);
-               if (!off)
-                   PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
-               else if (off != ix)
-                   Perl_croak(aTHX_ "panic: cv_clone: %s", name);
+           if (SvFAKE(namesv)) {   /* lexical from outside? */
+               assert(outpad[(I32)SvNVX(namesv)] &&
+                       !SvPADSTALE(outpad[(I32)SvNVX(namesv)]));
+               PL_curpad[ix] = SvREFCNT_inc(outpad[(I32)SvNVX(namesv)]);
            }
-           else {                              /* our own lexical */
-               SV* sv;
-               if (*name == '&') {
-                   /* anon code -- we'll come back for it */
+           else {
+               char *name = SvPVX(namesv);
+               if (*name == '&')
                    sv = SvREFCNT_inc(ppad[ix]);
-               }
                else if (*name == '@')
                    sv = (SV*)newAV();
                else if (*name == '%')
@@ -1345,33 +1382,12 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
            PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
        }
        else {
-           SV* sv = NEWSV(0, 0);
+           sv = NEWSV(0, 0);
            SvPADTMP_on(sv);
            PL_curpad[ix] = sv;
        }
     }
 
-    /* Now that vars are all in place, clone nested closures. */
-
-    for (ix = fpad; ix > 0; ix--) {
-       SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
-       if (namesv
-           && namesv != &PL_sv_undef
-           && !(SvFLAGS(namesv) & SVf_FAKE)
-           && *SvPVX(namesv) == '&'
-           && CvCLONE(ppad[ix]))
-       {
-           CV *kid = cv_clone2((CV*)ppad[ix], cv);
-           SvREFCNT_dec(ppad[ix]);
-           CvCLONE_on(kid);
-           SvPADMY_on(kid);
-           PL_curpad[ix] = (SV*)kid;
-           /* '&' entry points to child, so child mustn't refcnt parent */
-           CvWEAKOUTSIDE_on(kid);
-           SvREFCNT_dec(cv);
-       }
-    }
-
     DEBUG_Xv(
        PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
        cv_dump(outside, "Outside");
@@ -1382,11 +1398,19 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     LEAVE;
 
     if (CvCONST(cv)) {
+       /* Constant sub () { $x } closing over $x - see lib/constant.pm:
+        * The prototype was marked as a candiate for const-ization,
+        * so try to grab the current const value, and if successful,
+        * turn into a const sub:
+        */
        SV* const_sv = op_const_sv(CvSTART(cv), cv);
-       assert(const_sv);
-       /* constant sub () { $x } closing over $x - see lib/constant.pm */
-       SvREFCNT_dec(cv);
-       cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+       if (const_sv) {
+           SvREFCNT_dec(cv);
+           cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+       }
+       else {
+           CvCONST_off(cv);
+       }
     }
 
     return cv;
index b4c8287..e18dfbb 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -196,6 +196,8 @@ END_EXTERN_C
 #define PL_custom_op_descs     (*Perl_Icustom_op_descs_ptr(aTHX))
 #undef  PL_custom_op_names
 #define PL_custom_op_names     (*Perl_Icustom_op_names_ptr(aTHX))
+#undef  PL_cv_has_eval
+#define PL_cv_has_eval         (*Perl_Icv_has_eval_ptr(aTHX))
 #undef  PL_dbargs
 #define PL_dbargs              (*Perl_Idbargs_ptr(aTHX))
 #undef  PL_debstash
index 603dfc8..e2728d1 100644 (file)
@@ -4350,26 +4350,35 @@ instance.  This is almost always a typographical error.  Note that the
 earlier variable will still exist until the end of the scope or until
 all closure referents to it are destroyed.
 
-=item Variable "%s" may be unavailable
+=item Variable "%s" is not available
 
-(W closure) An inner (nested) I<anonymous> subroutine is inside a
-I<named> subroutine, and outside that is another subroutine; and the
-anonymous (innermost) subroutine is referencing a lexical variable
-defined in the outermost subroutine.  For example:
+(W closure) During compilation, an inner named subroutine or eval is
+attempting to capture an outer lexical that is not currently available.
+This can be happen for one of two reasons. First, the outer lexical may be
+declared in an outer anonymous subroutine that has not yet been created.
+(Remember that named subs are created at compile time, while anonymous
+subs are created at run-time. For example,
 
-   sub outermost { my $a; sub middle { sub { $a } } }
+    sub { my $a; sub f { $a } }
 
-If the anonymous subroutine is called or referenced (directly or
-indirectly) from the outermost subroutine, it will share the variable as
-you would expect.  But if the anonymous subroutine is called or
-referenced when the outermost subroutine is not active, it will see the
-value of the shared variable as it was before and during the *first*
-call to the outermost subroutine, which is probably not what you want.
+At the time that f is created, it can't capture the current value of $a,
+since the anonymous subroutine hasn't been created yet. Conversely,
+the following won't give a warning since the anonymous subroutine has by
+now been created and is live:
 
-In these circumstances, it is usually best to make the middle subroutine
-anonymous, using the C<sub {}> syntax.  Perl has specific support for
-shared variables in nested anonymous subroutines; a named subroutine in
-between interferes with this feature.
+    sub { my $a; eval 'sub f { $a }' }->();
+
+The second situation is caused by an eval accessing a variable that has
+gone out of scope, for example,
+
+    sub f {
+       my $a;
+       sub { eval '$a' }
+    }
+    f()->();
+
+Here, when the '$a' in the eval is being compiled, f() is not currently being
+executed, so its $a is not available for capture.
 
 =item Variable syntax
 
@@ -4380,22 +4389,18 @@ Perl yourself.
 =item Variable "%s" will not stay shared
 
 (W closure) An inner (nested) I<named> subroutine is referencing a
-lexical variable defined in an outer subroutine.
+lexical variable defined in an outer named subroutine.
 
-When the inner subroutine is called, it will probably see the value of
+When the inner subroutine is called, it will see the value of
 the outer subroutine's variable as it was before and during the *first*
 call to the outer subroutine; in this case, after the first call to the
 outer subroutine is complete, the inner and outer subroutines will no
 longer share a common value for the variable.  In other words, the
 variable will no longer be shared.
 
-Furthermore, if the outer subroutine is anonymous and references a
-lexical variable outside itself, then the outer and inner subroutines
-will I<never> share the given variable.
-
 This problem can usually be solved by making the inner subroutine
 anonymous, using the C<sub {}> syntax.  When inner anonymous subs that
-reference variables in outer subroutines are called or referenced, they
+reference variables in outer subroutines are created, they
 are automatically rebound to the current values of such variables.
 
 =item Version number must be a constant number
index c4bb1d5..2ae4a65 100644 (file)
@@ -428,7 +428,8 @@ CV's can have CvPADLIST(cv) set to point to an AV.
 
 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
 not callable at will and are always thrown away after the eval"" is done
-executing).
+executing). Require'd files are simply evals without any outer lexical
+scope.
 
 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
 but that is really the callers pad (a slot of which is allocated by
@@ -474,10 +475,14 @@ stash of the associated global (so that duplicate C<our> delarations in the
 same package can be detected).  SvCUR is sometimes hijacked to
 store the generation number during compilation.
 
-If SvFAKE is set on the name SV then slot in the frame AVs are
-a REFCNT'ed references to a lexical from "outside". In this case,
-the name SV does not have a cop_seq range, since it is in scope
-throughout.
+If SvFAKE is set on the name SV, then that slot in the frame AV is
+a REFCNT'ed reference to a lexical from "outside". In this case,
+the name SV does not use NVX and IVX to store a cop_seq range, since it is
+in scope throughout. Instead IVX stores some flags containing info about
+the real lexical (is it declared in an anon, and is it capable of being
+instantiated multiple times?), and for fake ANONs, NVX contains the index
+within the parent's pad where the lexical's value is stored, to make
+cloning quicker.
 
 If the 'name' is '&' the corresponding entry in frame AV
 is a CV representing a possible closure.
@@ -538,14 +543,13 @@ Found in file pad.c
 
 =item pad_add_name
 
-Create a new name in the current pad at the specified offset.
+Create a new name and associated PADMY SV in the current pad; return the
+offset.
 If C<typestash> is valid, the name is for a typed lexical; set the
 name's stash to that value.
 If C<ourstash> is valid, it's an our lexical, set the name's
 GvSTASH to that value
 
-Also, if the name is @.. or %.., create a new array or hash for that slot
-
 If fake, it means we're cloning an existing entry
 
        PADOFFSET       pad_add_name(char *name, HV* typestash, HV* ourstash, bool clone)
@@ -589,12 +593,23 @@ 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 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, CV* innercv)
+in the inner pads if it's found in an outer one.
+
+Returns the offset in the bottom pad of the lex or the fake lex.
+cv is the CV in which to start the search, and seq is the current cop_seq
+to match against. If warn is true, print appropriate warnings.  The out_*
+vars return values, and so are pointers to where the returned values
+should be stored. out_capture, if non-null, requests that the innermost
+instance of the lexical is captured; out_name_sv is set to the innermost
+matched namesv or fake namesv; out_flags returns the flags normally
+associated with the IVX field of a fake namesv.
+
+Note that pad_findlex() is recursive; it recurses up the chain of CVs,
+then comes back down, adding fake entries as it goes. It has to be this way
+because fake namesvs in anon protoypes have to store in NVX the index into
+the parent pad.
+
+       PADOFFSET       pad_findlex(char *name, CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
 
 =for hackers
 Found in file pad.c
index 7f9b638..07b2f82 100644 (file)
@@ -542,10 +542,10 @@ remains available.
 
 =head2 Function Templates
 
-As explained above, a closure is an anonymous function with access to the
-lexical variables visible when that function was compiled.  It retains
-access to those variables even though it doesn't get run until later,
-such as in a signal handler or a Tk callback.
+As explained above, an anonymous function with access to the lexical
+variables visible when that function was compiled, creates a closure.  It
+retains access to those variables even though it doesn't get run until
+later, such as in a signal handler or a Tk callback.
 
 Using a closure as a function template allows us to generate many functions
 that act similarly.  Suppose you wanted functions named after the colors
@@ -585,11 +585,13 @@ to occur during compilation.
 Access to lexicals that change over type--like those in the C<for> loop
 above--only works with closures, not general subroutines.  In the general
 case, then, named subroutines do not nest properly, although anonymous
-ones do.  If you are accustomed to using nested subroutines in other
-programming languages with their own private variables, you'll have to
-work at it a bit in Perl.  The intuitive coding of this type of thing
-incurs mysterious warnings about ``will not stay shared''.  For example,
-this won't work:
+ones do. Thus is because named subroutines are created (and capture any
+outer lexicals) only once at compile time, whereas anonymous subroutines
+get to capture each time you execute the 'sub' operator.  If you are
+accustomed to using nested subroutines in other programming languages with
+their own private variables, you'll have to work at it a bit in Perl.  The
+intuitive coding of this type of thing incurs mysterious warnings about
+``will not stay shared''.  For example, this won't work:
 
     sub outer {
         my $x = $_[0] + 35;
diff --git a/proto.h b/proto.h
index 97844a5..1f03b3b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1317,11 +1317,10 @@ 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, CV* innercv);
+STATIC PADOFFSET       S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags);
 #  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_ U32 *db_seqp);
 PERL_CALLCONV void     Perl_free_tied_hv_pool(pTHX);
index 8f52e28..3b69817 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -2259,8 +2259,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
                        FAIL("Eval-group not allowed at runtime, use re 'eval'");
                    if (PL_tainting && PL_tainted)
                        FAIL("Eval-group in insecure regular expression");
+                   if (PL_curcop == &PL_compiling)
+                       PL_cv_has_eval = 1;
                }
-               
+
                nextchar(pRExC_state);
                if (logical) {
                    ret = reg_node(pRExC_state, LOGICAL);
index 7dd2876..71f683e 100644 (file)
@@ -4,21 +4,21 @@
        my $x;
        my $x ;
 
-     Variable "%s" may be unavailable 
+     Variable "%s" will not stay shared 
        sub x {
            my $x;
            sub y {
-               $x
+               sub { $x }
            }
        }
 
-     Variable "%s" will not stay shared 
        sub x {
            my $x;
            sub y {
-               sub { $x }
+               $x
            }
        }
+
     "our" variable %s redeclared       (Did you mean "local" instead of "our"?)
        our $x;
        {
@@ -65,24 +65,89 @@ EXPECT
 # pad.c
 use warnings 'closure' ;
 sub x {
-      our $x;
+      my $x;
       sub y {
-         $x
+         sub { $x }
       }
    }
 EXPECT
+Variable "$x" will not stay shared at - line 6.
+########
+# pad.c
+use warnings 'closure' ;
+sub x {
+    my $x;
+    sub {
+       $x;
+       sub y {
+           $x
+       }
+    }->();
+}
+EXPECT
+Variable "$x" will not stay shared at - line 9.
+########
+# pad.c
+use warnings 'closure' ;
+my $x;
+sub {
+    $x;
+    sub f {
+       sub { $x }->();
+    }
+}->();
+EXPECT
 
 ########
 # pad.c
 use warnings 'closure' ;
+sub {
+    my $x;
+    sub f { $x }
+}->();
+EXPECT
+Variable "$x" is not available at - line 5.
+########
+# pad.c
+use warnings 'closure' ;
+sub {
+    my $x;
+    eval 'sub f { $x }';
+}->();
+EXPECT
+
+########
+# pad.c
+use warnings 'closure' ;
+sub {
+    my $x;
+    sub f { eval '$x' }
+}->();
+f();
+EXPECT
+Variable "$x" is not available at (eval 1) line 2.
+########
+# pad.c
+use warnings 'closure' ;
 sub x {
-      my $x;
+      our $x;
       sub y {
-         sub { $x }
+         $x
       }
    }
 EXPECT
-Variable "$x" may be unavailable at - line 6.
+
+########
+# pad.c
+# see bugid 1754
+use warnings 'closure' ;
+sub f {
+    my $x;
+    sub { eval '$x' };
+}
+f()->();
+EXPECT
+Variable "$x" is not available at (eval 1) line 2.
 ########
 # pad.c
 no warnings 'closure' ;
index 6a81a44..dd7b50c 100755 (executable)
@@ -13,7 +13,7 @@ BEGIN {
 
 use Config;
 
-print "1..181\n";
+print "1..184\n";
 
 my $test = 1;
 sub test (&) {
@@ -255,7 +255,7 @@ END_MARK_ONE
 
          $code .=  <<"END_MARK_TWO" if $nc_attempt;
     return if index(\$msg, 'will not stay shared') != -1;
-    return if index(\$msg, 'may be unavailable') != -1;
+    return if index(\$msg, 'is not available') != -1;
 END_MARK_TWO
 
          $code .= <<"END_MARK_THREE";          # Backwhack a lot!
@@ -604,3 +604,41 @@ sub linger {
     linger(\$watch);
     test { $watch eq '12' }
 }
+
+# bugid 10085
+# obj not freed early enough
+
+sub linger2 { 
+    my $obj = Watch->new($_[0], '2');
+    sub { sub { $obj } };
+}   
+{
+    my $watch = '1';
+    linger2(\$watch);
+    test { $watch eq '12' }
+}
+
+# bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
+
+{
+    my $x = 1;
+    sub f16302 {
+       sub {
+           test { defined $x and $x == 1 }
+       }->();
+    }
+}
+f16302();
+
+# The presence of an eval should turn cloneless anon subs into clonable
+# subs - otherwise the CvOUTSIDE of that sub may be wrong
+
+{
+    my %a;
+    for my $x (7,11) {
+       $a{$x} = sub { $x=$x; sub { eval '$x' } };
+    }
+    test { $a{7}->()->() + $a{11}->()->() == 18 };
+}
+
+