Remove code duplication in S_to_utf8_substr() and S_to_byte_substr()

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index 96da712..3b52c20 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1,6 +1,6 @@
 /*    pad.c
  *
 /*    pad.c
  *

- *    Copyright (c) 2002, Larry Wall
+ *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 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.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.


@@ -22,19 +22,25 @@
 /*
 =head1 Pad Data Structures
 
 /*
 =head1 Pad Data Structures
 

+This file contains the functions that create and manipulate scratchpads,
+which are array-of-array data structures attached to a CV (ie a sub)
+and which store lexical variables and opcode temporary and per-thread
+values.
+

 =for apidoc m|AV *|CvPADLIST|CV *cv
 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
 =for apidoc m|AV *|CvPADLIST|CV *cv
 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
 every entersub).
 
 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
 
 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
 every entersub).
 
 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items

-is managed "manual" (mostly in op.c) rather than normal av.c rules.
+is managed "manual" (mostly in pad.c) rather than normal av.c rules.

 The items in the AV are not SVs as for a normal AV, but other AVs:
 
 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
 The items in the AV are not SVs as for a normal AV, but other AVs:
 
 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather


@@ -46,11 +52,14 @@ The 0'th slot of a frame AV is an AV which is @_.
 other entries are storage for variables and op targets.
 
 During compilation:
 other entries are storage for variables and op targets.
 
 During compilation:

-C<PL_comppad_name> is set the the the names AV.
-C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
+C<PL_comppad_name> is set to the names AV.
+C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
+C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
+
+During execution, C<PL_comppad> and C<PL_curpad> refer to the live
+frame of the currently executing sub.

 
 

-Itterating over the names AV itterates over all possible pad
+Iterating over the names AV iterates over all possible pad

 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
 &PL_sv_undef "names" (see pad_alloc()).
 
 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
 &PL_sv_undef "names" (see pad_alloc()).
 


@@ -65,19 +74,34 @@ in PL_op->op_targ), wasting a name SV for them doesn't make sense.
 The SVs in the names AV have their PV being the name of the variable.
 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
 The SVs in the names AV have their PV being the name of the variable.
 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the

-type.  For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
-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".
-
-If the 'name' is '&' the the corresponding entry in frame AV
+type.  For C<our> lexicals, the type is also SVt_PVGV, with the MAGIC slot
+pointing at the stash of the associated global (so that duplicate C<our>
+declarations 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 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.
 (SvFAKE and name of '&' is not a meaningful combination currently but could
 become so if C<my sub foo {}> is implemented.)
 
 is a CV representing a possible closure.
 (SvFAKE and name of '&' is not a meaningful combination currently but could
 become so if C<my sub foo {}> is implemented.)
 

+Note that formats are treated as anon subs, and are cloned each time
+write is called (if necessary).
+
+The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
+and set on scope exit. This allows the 'Variable $x is not available' warning
+to be generated in evals, such as 
+
+    { my $x = 1; sub f { eval '$x'} } f();
+

 =cut
 */
 
 =cut
 */
 


@@ -85,11 +109,17 @@ become so if C<my sub foo {}> is implemented.)
 #include "EXTERN.h"
 #define PERL_IN_PAD_C
 #include "perl.h"
 #include "EXTERN.h"
 #define PERL_IN_PAD_C
 #include "perl.h"

+#include "keywords.h"

 
 
 #define PAD_MAX 999999999
 
 
 
 #define PAD_MAX 999999999
 

-
+#ifdef PERL_MAD
+void pad_peg(const char* s) {
+    static int pegcnt;
+    pegcnt++;
+}
+#endif

 
 /*
 =for apidoc pad_new
 
 /*
 =for apidoc pad_new


@@ -106,9 +136,12 @@ can be OR'ed together:
 */
 
 PADLIST *
 */
 
 PADLIST *

-Perl_pad_new(pTHX_ padnew_flags flags)
+Perl_pad_new(pTHX_ int flags)

 {
 {

-    AV *padlist, *padname, *pad, *a0;
+    dVAR;
+    AV *padlist, *padname, *pad;
+
+    ASSERT_CURPAD_LEGAL("pad_new");

 
     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
      * vars (based on flags) rather than storing vals + addresses for
 
     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
      * vars (based on flags) rather than storing vals + addresses for


@@ -119,14 +152,14 @@ Perl_pad_new(pTHX_ padnew_flags flags)
     /* save existing state, ... */
 
     if (flags & padnew_SAVE) {
     /* save existing state, ... */
 
     if (flags & padnew_SAVE) {

-       SAVEVPTR(PL_curpad);
-       SAVESPTR(PL_comppad);
+       SAVECOMPPAD();

        SAVESPTR(PL_comppad_name);
        if (! (flags & padnew_CLONE)) {
            SAVEI32(PL_padix);
            SAVEI32(PL_comppad_name_fill);
            SAVEI32(PL_min_intro_pending);
            SAVEI32(PL_max_intro_pending);
        SAVESPTR(PL_comppad_name);
        if (! (flags & padnew_CLONE)) {
            SAVEI32(PL_padix);
            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);
            }
            if (flags & padnew_SAVESUB) {
                SAVEI32(PL_pad_reset_pending);
            }


@@ -147,20 +180,13 @@ Perl_pad_new(pTHX_ padnew_flags flags)
         * dispensed with eventually ???
         */
 
         * dispensed with eventually ???
         */
 

-       a0 = newAV();                   /* will be @_ */
+        AV * const a0 = newAV();                       /* will be @_ */

        av_extend(a0, 0);
        av_store(pad, 0, (SV*)a0);
        av_extend(a0, 0);
        av_store(pad, 0, (SV*)a0);

-       AvFLAGS(a0) = AVf_REIFY;
+       AvREIFY_only(a0);

     }
     else {
     }
     else {

-#ifdef USE_5005THREADS
-       av_store(padname, 0, newSVpvn("@_", 2));
-       a0 = newAV();
-       SvPADMY_on((SV*)a0);            /* XXX Needed? */
-       av_store(pad, 0, (SV*)a0);
-#else
-       av_store(pad, 0, Nullsv);
-#endif /* USE_THREADS */
+       av_store(pad, 0, NULL);

     }
 
     AvREAL_off(padlist);
     }
 
     AvREAL_off(padlist);


@@ -177,12 +203,13 @@ Perl_pad_new(pTHX_ padnew_flags flags)
        PL_comppad_name_fill = 0;
        PL_min_intro_pending = 0;
        PL_padix             = 0;
        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,
     }
 
     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",
              " 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
        )
     );
              PTR2UV(padname), (UV)flags
        )
     );


@@ -197,73 +224,95 @@ 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
 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.
+
+(This function should really be called pad_free, but the name was already
+taken)

 
 =cut
 */
 
 void
 
 =cut
 */
 
 void

-Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
+Perl_pad_undef(pTHX_ CV* cv)

 {
 {

+    dVAR;

     I32 ix;
     I32 ix;

-    PADLIST *padlist = CvPADLIST(cv);
+    const PADLIST * const padlist = CvPADLIST(cv);

 
 

+    pad_peg("pad_undef");

     if (!padlist)
        return;
     if (!padlist)
        return;

-    if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
+    if (SvIS_FREED(padlist)) /* may be during global destruction */

        return;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
        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))

     );
 
     );
 

-    /* pads may be cleared out already during global destruction */
-    if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
-           && !PL_dirty) || CvSPECIAL(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 */
-       AV *comppad_name = (AV*)AvARRAY(padlist)[0];
-       SV **namepad = AvARRAY(comppad_name);
-       AV *comppad = (AV*)AvARRAY(padlist)[1];
-       SV **curpad = AvARRAY(comppad);
+    /* detach any '&' anon children in the pad; if afterwards they
+     * are still live, fix up their CvOUTSIDEs to point to our outside,
+     * bypassing us. */
+    /* XXX DAPM for efficiency, we should only do this if we know we have
+     * children, or integrate this loop with general cleanup */
+
+    if (!PL_dirty) { /* don't bother during global destruction */
+       CV * const outercv = CvOUTSIDE(cv);
+        const U32 seq = CvOUTSIDE_SEQ(cv);
+       AV *  const comppad_name = (AV*)AvARRAY(padlist)[0];
+       SV ** const namepad = AvARRAY(comppad_name);
+       AV *  const comppad = (AV*)AvARRAY(padlist)[1];
+       SV ** const curpad = AvARRAY(comppad);

        for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
        for (ix = AvFILLp(comppad_name); ix > 0; ix--) {

-           SV *namesv = namepad[ix];
+           SV * const namesv = namepad[ix];

            if (namesv && namesv != &PL_sv_undef
            if (namesv && namesv != &PL_sv_undef

-               && *SvPVX(namesv) == '&'
-               && ix <= AvFILLp(comppad))
+               && *SvPVX_const(namesv) == '&')

            {
            {

-               CV *innercv = (CV*)curpad[ix];
-               if (innercv && SvTYPE(innercv) == SVt_PVCV
-                   && CvOUTSIDE(innercv) == cv)
-               {
-                   CvOUTSIDE(innercv) = outercv;
-                   if (!CvANON(innercv) || CvCLONED(innercv)) {
-                       (void)SvREFCNT_inc(outercv);
-                       if (SvREFCNT(cv))
-                           SvREFCNT_dec(cv);
+               CV * const innercv = (CV*)curpad[ix];
+               U32 inner_rc = SvREFCNT(innercv);
+               assert(inner_rc);
+               namepad[ix] = NULL;
+               SvREFCNT_dec(namesv);
+
+               if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
+                   curpad[ix] = NULL;
+                   SvREFCNT_dec(innercv);
+                   inner_rc--;
+               }
+
+               /* in use, not just a prototype */
+               if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
+                   assert(CvWEAKOUTSIDE(innercv));
+                   /* don't relink to grandfather if he's being freed */
+                   if (outercv && SvREFCNT(outercv)) {
+                       CvWEAKOUTSIDE_off(innercv);
+                       CvOUTSIDE(innercv) = outercv;
+                       CvOUTSIDE_SEQ(innercv) = seq;
+                       SvREFCNT_inc_simple_void_NN(outercv);
+                   }
+                   else {
+                       CvOUTSIDE(innercv) = NULL;

                    }
                }
            }
        }
     }
                    }
                }
            }
        }
     }

+

     ix = AvFILLp(padlist);
     while (ix >= 0) {
     ix = AvFILLp(padlist);
     while (ix >= 0) {

-       SV* sv = AvARRAY(padlist)[ix--];
-       if (!sv)
-           continue;
-       if (sv == (SV*)PL_comppad_name)
-           PL_comppad_name = Nullav;
-       else if (sv == (SV*)PL_comppad) {
-           PL_comppad = Nullav;
-           PL_curpad = Null(SV**);
+       const SV* const sv = AvARRAY(padlist)[ix--];
+       if (sv) {
+           if (sv == (SV*)PL_comppad_name)
+               PL_comppad_name = NULL;
+           else if (sv == (SV*)PL_comppad) {
+               PL_comppad = NULL;
+               PL_curpad = NULL;
+           }

        }
        SvREFCNT_dec(sv);
     }
     SvREFCNT_dec((SV*)CvPADLIST(cv));
        }
        SvREFCNT_dec(sv);
     }
     SvREFCNT_dec((SV*)CvPADLIST(cv));

-    CvPADLIST(cv) = Null(PADLIST*);
+    CvPADLIST(cv) = NULL;

 }
 
 
 }
 
 


@@ -272,76 +321,69 @@ Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
 /*
 =for apidoc pad_add_name
 
 /*
 =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
 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
+OURSTASH to that value

 
 If fake, it means we're cloning an existing entry
 
 =cut
 */
 
 
 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
 PADOFFSET

-Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
+Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)

 {
 {

-    PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
-    SV* namesv = NEWSV(1102, 0);
-    U32 min, max;
+    dVAR;
+    const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
+    SV* const namesv = newSV(0);

 
 

-    if (fake) {
-       min = PL_curcop->cop_seq;
-       max = PAD_MAX;
-    }
-    else {
-       /* not yet introduced */
-       min = PAD_MAX;
-       max = 0;
-    }
+    ASSERT_CURPAD_ACTIVE("pad_add_name");

 
 

-    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-         "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
-          (long)offset, name, (unsigned long)min, (unsigned long)max,
-         (fake ? " FAKE" : "")
-         )
-    );

 
 

-    sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
+    sv_upgrade(namesv, (ourstash || typestash) ? SVt_PVMG : SVt_PVNV);

     sv_setpv(namesv, name);
 
     if (typestash) {
     sv_setpv(namesv, name);
 
     if (typestash) {

-       SvFLAGS(namesv) |= SVpad_TYPED;
-       SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
+       SvPAD_TYPED_on(namesv);
+       SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));

     }
     if (ourstash) {
     }
     if (ourstash) {

-       SvFLAGS(namesv) |= SVpad_OUR;
-       GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
+       SvPAD_OUR_on(namesv);
+       OURSTASH_set(namesv, ourstash);
+       SvREFCNT_inc_simple_void_NN(ourstash);
+    }
+    else if (state) {
+       SvPAD_STATE_on(namesv);

     }
 
     av_store(PL_comppad_name, offset, namesv);
     }
 
     av_store(PL_comppad_name, offset, namesv);

-    SvNVX(namesv) = (NV)min;
-    SvIVX(namesv) = max;
-    if (fake)
+    if (fake) {

        SvFAKE_on(namesv);
        SvFAKE_on(namesv);

+       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+           "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
+    }

     else {
     else {

+       /* not yet introduced */
+       SvNV_set(namesv, (NV)PAD_MAX);  /* min */
+       SvIV_set(namesv, 0);            /* max */
+

        if (!PL_min_intro_pending)
            PL_min_intro_pending = offset;
        PL_max_intro_pending = offset;
        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 == '@')
            av_store(PL_comppad, offset, (SV*)newAV());
        else if (*name == '%')
            av_store(PL_comppad, offset, (SV*)newHV());
        SvPADMY_on(PL_curpad[offset]);
        if (*name == '@')
            av_store(PL_comppad, offset, (SV*)newAV());
        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;
     }
 
     return offset;


@@ -355,34 +397,42 @@ Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
 
 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
 
 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards

-for a slot which has no name and and no active value.
+for a slot which has no name and no active value.

 
 =cut
 */
 
 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
  * or at least rationalise ??? */
 
 =cut
 */
 
 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
  * or at least rationalise ??? */

-
+/* And flag whether the incoming name is UTF8 or 8 bit?
+   Could do this either with the +ve/-ve hack of the HV code, or expanding
+   the flag bits. Either way, this makes proper Unicode safe pad support.
+   Also could change the sv structure to make the NV a union with 2 U32s,
+   so that SvCUR() could stop being overloaded in pad SVs.
+   NWC
+*/

 
 PADOFFSET
 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 {
 
 PADOFFSET
 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 {

+    dVAR;

     SV *sv;
     I32 retval;
 
     SV *sv;
     I32 retval;
 

+    PERL_UNUSED_ARG(optype);
+    ASSERT_CURPAD_ACTIVE("pad_alloc");
+

     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_alloc");
     if (PL_pad_reset_pending)
        pad_reset();
     if (tmptype & SVs_PADMY) {
     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_alloc");
     if (PL_pad_reset_pending)
        pad_reset();
     if (tmptype & SVs_PADMY) {

-       do {
-           sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
-       } while (SvPADBUSY(sv));                /* need a fresh one */
+       sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);

        retval = AvFILLp(PL_comppad);
     }
     else {
        retval = AvFILLp(PL_comppad);
     }
     else {

-       SV **names = AvARRAY(PL_comppad_name);
-       SSize_t names_fill = AvFILLp(PL_comppad_name);
+       SV * const * const names = AvARRAY(PL_comppad_name);
+        const SSize_t names_fill = AvFILLp(PL_comppad_name);

        for (;;) {
            /*
             * "foreach" index vars temporarily become aliases to non-"my"
        for (;;) {
            /*
             * "foreach" index vars temporarily become aliases to non-"my"


@@ -407,6 +457,10 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
          "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
          PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
          PL_op_name[optype]));
          "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
          PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
          PL_op_name[optype]));

+#ifdef DEBUG_LEAKING_SCALARS
+    sv->sv_debug_optype = optype;
+    sv->sv_debug_inpad = 1;
+#endif

     return (PADOFFSET)retval;
 }
 
     return (PADOFFSET)retval;
 }
 


@@ -421,18 +475,27 @@ Add an anon code entry to the current compiling pad
 PADOFFSET
 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 {
 PADOFFSET
 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 {

+    dVAR;

     PADOFFSET ix;
     PADOFFSET ix;

-    SV* name;
-
-    name = NEWSV(1106, 0);
+    SV* const name = newSV(0);
+    pad_peg("add_anon");

     sv_upgrade(name, SVt_PVNV);
     sv_setpvn(name, "&", 1);
     sv_upgrade(name, SVt_PVNV);
     sv_setpvn(name, "&", 1);

-    SvIVX(name) = -1;
-    SvNVX(name) = 1;
+    SvIV_set(name, -1);
+    SvNV_set(name, 1);

     ix = pad_alloc(op_type, SVs_PADMY);
     av_store(PL_comppad_name, ix, name);
     ix = pad_alloc(op_type, SVs_PADMY);
     av_store(PL_comppad_name, ix, name);

+    /* XXX DAPM use PL_curpad[] ? */

     av_store(PL_comppad, ix, sv);
     SvPADMY_on(sv);
     av_store(PL_comppad, ix, sv);
     SvPADMY_on(sv);

+
+    /* to avoid ref loops, we never have parent + child referencing each
+     * other simultaneously */
+    if (CvOUTSIDE((CV*)sv)) {
+       assert(!CvWEAKOUTSIDE((CV*)sv));
+       CvWEAKOUTSIDE_on((CV*)sv);
+       SvREFCNT_dec(CvOUTSIDE((CV*)sv));
+    }

     return ix;
 }
 
     return ix;
 }
 


@@ -453,12 +516,14 @@ C<is_our> indicates that the name to check is an 'our' declaration
 /* XXX DAPM integrate this into pad_add_name ??? */
 
 void
 /* XXX DAPM integrate this into pad_add_name ??? */
 
 void

-Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
+Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)

 {
 {

-    SV         **svp, *sv;
+    dVAR;
+    SV         **svp;

     PADOFFSET  top, off;
 
     PADOFFSET  top, off;
 

-    if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
+    ASSERT_CURPAD_ACTIVE("pad_check_dup");
+    if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))

        return; /* nothing to check */
 
     svp = AvARRAY(PL_comppad_name);
        return; /* nothing to check */
 
     svp = AvARRAY(PL_comppad_name);


@@ -467,16 +532,18 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
      * type ? */
     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
      * type ? */
     for (off = top; (I32)off > PL_comppad_name_floor; off--) {

-       if ((sv = svp[off])
+       SV * const sv = svp[off];
+       if (sv

            && sv != &PL_sv_undef
            && sv != &PL_sv_undef

+           && !SvFAKE(sv)

            && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
            && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)

-           && (!is_our
-               || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
-           && strEQ(name, SvPVX(sv)))
+           && strEQ(name, SvPVX_const(sv)))

        {
        {

+           if (is_our && (SvPAD_OUR(sv)))
+               break; /* "our" masking "our" */

            Perl_warner(aTHX_ packWARN(WARN_MISC),
                "\"%s\" variable %s masks earlier declaration in same %s",
            Perl_warner(aTHX_ packWARN(WARN_MISC),
                "\"%s\" variable %s masks earlier declaration in same %s",

-               (is_our ? "our" : "my"),
+               (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),

                name,
                (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
            --off;
                name,
                (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
            --off;


@@ -486,16 +553,19 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
     /* check the rest of the pad */
     if (is_our) {
        do {
     /* check the rest of the pad */
     if (is_our) {
        do {

-           if ((sv = svp[off])
+           SV * const sv = svp[off];
+           if (sv

                && sv != &PL_sv_undef
                && sv != &PL_sv_undef

+               && !SvFAKE(sv)

                && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
                && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)

-               && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
-               && strEQ(name, SvPVX(sv)))
+               && OURSTASH(sv) == ourstash
+               && strEQ(name, SvPVX_const(sv)))

            {
                Perl_warner(aTHX_ packWARN(WARN_MISC),
                    "\"our\" variable %s redeclared", name);
            {
                Perl_warner(aTHX_ packWARN(WARN_MISC),
                    "\"our\" variable %s redeclared", name);

-               Perl_warner(aTHX_ packWARN(WARN_MISC),
-                   "\t(Did you mean \"local\" instead of \"our\"?)\n");
+               if ((I32)off <= PL_comppad_name_floor)
+                   Perl_warner(aTHX_ packWARN(WARN_MISC),
+                       "\t(Did you mean \"local\" instead of \"our\"?)\n");

                break;
            }
        } while ( off-- > 0 );
                break;
            }
        } while ( off-- > 0 );


@@ -503,7 +573,6 @@ Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
 }
 
 
 }
 
 

-

 /*
 =for apidoc pad_findmy
 
 /*
 =for apidoc pad_findmy
 


@@ -517,286 +586,304 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure.
 */
 
 PADOFFSET
 */
 
 PADOFFSET

-Perl_pad_findmy(pTHX_ char *name)
+Perl_pad_findmy(pTHX_ const char *name)

 {
 {

-    I32 off;
-    I32 pendoff = 0;
-    SV *sv;
-    SV **svp = AvARRAY(PL_comppad_name);
-    U32 seq = PL_cop_seqmax;
-    PERL_CONTEXT *cx;
-    CV *outside;
-
-    DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy:  \"%s\"\n", name));
-
-#ifdef USE_5005THREADS
-    /*
-     * Special case to get lexical (and hence per-thread) @_.
-     * XXX I need to find out how to tell at parse-time whether use
-     * of @_ should refer to a lexical (from a sub) or defgv (global
-     * scope and maybe weird sub-ish things like formats). See
-     * startsub in perly.y.  It's possible that @_ could be lexical
-     * (at least from subs) even in non-threaded perl.
-     */
-    if (strEQ(name, "@_"))
-       return 0;               /* success. (NOT_IN_PAD indicates failure) */
-#endif /* USE_5005THREADS */
-
-    /* The one we're looking for is probably just before comppad_name_fill. */
-    for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
-       if ((sv = svp[off]) &&
-           sv != &PL_sv_undef &&
-           (!SvIVX(sv) ||
-            (seq <= (U32)SvIVX(sv) &&
-             seq > (U32)I_32(SvNVX(sv)))) &&
-           strEQ(SvPVX(sv), name))
-       {
-           if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
-               return (PADOFFSET)off;
-           pendoff = off;      /* this pending def. will override import */
-       }
-    }
-
-    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;
+    dVAR;
+    SV *out_sv;
+    int out_flags;
+    I32 offset;
+    const AV *nameav;
+    SV **name_svp;
+
+    pad_peg("pad_findmy");
+    offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
+               NULL, &out_sv, &out_flags);
+    if ((PADOFFSET)offset != NOT_IN_PAD) 
+       return offset;
+
+    /* look for an our that's being introduced; this allows
+     *    our $foo = 0 unless defined $foo;
+     * to not give a warning. (Yes, this is a hack) */
+
+    nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+    name_svp = AvARRAY(nameav);
+    for (offset = AvFILLp(nameav); offset > 0; offset--) {
+        const SV * const namesv = name_svp[offset];
+       if (namesv && namesv != &PL_sv_undef
+           && !SvFAKE(namesv)
+           && (SvPAD_OUR(namesv))
+           && strEQ(SvPVX_const(namesv), name)
+           && U_32(SvNVX(namesv)) == PAD_MAX /* min */
+       )
+           return offset;

     }
     }

-
-    /* See if it's in a nested scope */
-    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
-    if (!off)                  /* pad_findlex returns 0 for failure...*/
-       return NOT_IN_PAD;      /* ...but we return NOT_IN_PAD for failure */
-
-    /* If there is a pending local definition, this new alias must die */
-    if (pendoff)
-       SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
-    return off;
+    return NOT_IN_PAD;

 }
 
 }
 

+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */

 
 

+PADOFFSET
+Perl_find_rundefsvoffset(pTHX)
+{
+    dVAR;
+    SV *out_sv;
+    int out_flags;
+    return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+           NULL, &out_sv, &out_flags);
+}

 
 /*
 =for apidoc pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 
 /*
 =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.
+
+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
 */
 
 
 =cut
 */
 

-#define FINDLEX_NOSEARCH       1       /* don't search outer contexts */
+/* 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)
+
+/* the CV does late binding of its lexicals */
+#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+

 
 STATIC PADOFFSET
 
 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_ const char *name, const CV* cv, U32 seq, int warn,
+       SV** out_capture, SV** out_name_sv, int *out_flags)

 {
 {

-    CV *cv;
-    I32 off;
-    SV *sv;
-    register I32 i;
-    register PERL_CONTEXT *cx;
+    dVAR;
+    I32 offset, new_offset;
+    SV *new_capture;
+    SV **new_capturep;
+    const AV * const padlist = CvPADLIST(cv);
+
+    *out_flags = 0;

 
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 
     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 cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
+       PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));

 
 

-    for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
-       AV *curlist = CvPADLIST(cv);
-       SV **svp = av_fetch(curlist, 0, FALSE);
-       AV *curname;
+    /* first, search this pad */

 
 

-       DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-           "             searching: cv=0x%"UVxf"\n", PTR2UV(cv))
-       );
+    if (padlist) { /* not an undef CV */
+       I32 fake_offset = 0;
+        const AV * const nameav = (AV*)AvARRAY(padlist)[0];
+       SV * const * const name_svp = AvARRAY(nameav);

 
 

-       if (!svp || *svp == &PL_sv_undef)
-           continue;
-       curname = (AV*)*svp;
-       svp = AvARRAY(curname);
-       for (off = AvFILLp(curname); off > 0; off--) {
-           I32 depth;
-           AV *oldpad;
-           SV *oldsv;
-
-           if ( ! (
-                   (sv = svp[off]) &&
-                   sv != &PL_sv_undef &&
-                   seq <= (U32)SvIVX(sv) &&
-                   seq > (U32)I_32(SvNVX(sv)) &&
-                   strEQ(SvPVX(sv), name))
-           )
-               continue;
+       for (offset = AvFILLp(nameav); offset > 0; offset--) {
+            const SV * const namesv = name_svp[offset];
+           if (namesv && namesv != &PL_sv_undef
+                   && strEQ(SvPVX_const(namesv), name))
+           {
+               if (SvFAKE(namesv))
+                   fake_offset = offset; /* in case we don't find a real one */
+               else if (  seq >  U_32(SvNVX(namesv))   /* min */
+                       && seq <= (U32)SvIVX(namesv))   /* max */
+                   break;
+           }
+       }

 
 

-           depth = CvDEPTH(cv);
-           if (!depth) {
-               if (newoff) {
-                   if (SvFAKE(sv))
-                       continue;
-                   return 0; /* don't clone from inactive stack frame */
-               }
-               depth = 1;
+       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)U_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%lx index=%lu\n",
+                   PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
+                       (unsigned long)SvNVX(*out_name_sv) 
+               ));

            }
 
            }
 

-           oldpad = (AV*)AvARRAY(curlist)[depth];
-           oldsv = *av_fetch(oldpad, off, TRUE);
+           /* return the lex? */

 
 

-           DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-                       "             matched:   offset %ld"
-                           " %s(%lu,%lu), sv=0x%"UVxf"\n",
-                       (long)off,
-                       SvFAKE(sv) ? "FAKE " : "",
-                       (unsigned long)I_32(SvNVX(sv)),
-                       (unsigned long)SvIVX(sv),
-                       PTR2UV(oldsv)
-                   )
-           );
+           if (out_capture) {

 
 

-           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 */
-               );
+               /* our ? */
+               if (SvPAD_OUR(*out_name_sv)) {
+                   *out_capture = NULL;
+                   return offset;
+               }

 
 

-               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;
-                               AV *ocomppad = PL_comppad;
-                               SV **ocurpad = PL_curpad;
-                               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 = ocurpad;
-                               CvCLONE_on(bcv);
-                           }
-                           else {
-                               if (ckWARN(WARN_CLOSURE)
-                                   && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
-                               {
-                                   Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                                     "Variable \"%s\" may be unavailable",
-                                        name);
-                               }
-                               break;
-                           }
-                       }
-                   }
+               /* 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 = NULL;

                }
                }

-               else if (!CvUNIQUE(PL_compcv)) {
-                   if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
-                       && !(SvFLAGS(sv) & SVpad_OUR))
-                   {
+
+               /* 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);
                    }
                        Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
                            "Variable \"%s\" will not stay shared", name);
                    }

+
+                   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;
+                       (void) pad_findlex(name, CvOUTSIDE(cv),
+                           CvOUTSIDE_SEQ(cv),
+                           newwarn, out_capture, out_name_sv, out_flags);
+                       *out_name_sv = n;
+                       return offset;
+                   }
+
+                   *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), PTR2UV(*out_capture)));
+
+                   if (SvPADSTALE(*out_capture)) {
+                       if (ckWARN(WARN_CLOSURE))
+                           Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+                               "Variable \"%s\" is not available", name);
+                       *out_capture = NULL;
+                   }
+               }
+               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();

                }
            }
                }
            }

-           av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
-           DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-                       "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
-                       (long)newoff, PTR2UV(oldsv)
-                   )
-           );
-           return newoff;
+
+           return offset;

        }
     }
 
        }
     }
 

-    if (flags & FINDLEX_NOSEARCH)
-       return 0;
+    /* it's not in this pad - try above */

 
 

-    /* 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.
-     */
+    if (!CvOUTSIDE(cv))
+       return NOT_IN_PAD;

 
 

-    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);
+    /* out_capture non-null means caller wants us to capture lex; in
+     * addition we capture ourselves unless it's an ANON/format */
+    new_capturep = out_capture ? out_capture :
+               CvLATE(cv) ? NULL : &new_capture;
+
+    offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+               new_capturep, out_name_sv, out_flags);
+    if ((PADOFFSET)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 *  const ocomppad_name = PL_comppad_name;
+       PAD * const 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_const(*out_name_sv),
+           SvPAD_TYPED(*out_name_sv)
+                   ? SvSTASH(*out_name_sv) : NULL,
+           OURSTASH(*out_name_sv),
+           1,  /* fake */
+           0   /* not a state variable */
+       );
+
+       new_namesv = AvARRAY(PL_comppad_name)[new_offset];
+       SvIV_set(new_namesv, *out_flags);
+
+       SvNV_set(new_namesv, (NV)0);
+       if (SvPAD_OUR(new_namesv)) {
+           NOOP;   /* do nothing */

        }
        }

-    }
+       else if (CvLATE(cv)) {
+           /* delayed creation - just note the offset within parent pad */
+           SvNV_set(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);

 
 

-    return 0;
+       PL_comppad_name = ocomppad_name;
+       PL_comppad = ocomppad;
+       PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
+    }
+    return new_offset;

 }
 
 
 }
 
 

+#ifdef DEBUGGING

 /*
 =for apidoc pad_sv
 
 /*
 =for apidoc pad_sv
 


@@ -810,21 +897,14 @@ Use macro PAD_SV instead of calling this function directly.
 SV *
 Perl_pad_sv(pTHX_ PADOFFSET po)
 {
 SV *
 Perl_pad_sv(pTHX_ PADOFFSET po)
 {

-#ifdef DEBUGGING
-    /* for display purposes, try to guess the AV corresponding to
-     * Pl_curpad */
-    AV *cp = PL_comppad;
-    if (cp && AvARRAY(cp) != PL_curpad)
-       cp = Nullav;
-#endif
+    dVAR;
+    ASSERT_CURPAD_ACTIVE("pad_sv");

 
 

-#ifndef USE_5005THREADS

     if (!po)
        Perl_croak(aTHX_ "panic: pad_sv po");
     if (!po)
        Perl_croak(aTHX_ "panic: pad_sv po");

-#endif

     DEBUG_X(PerlIO_printf(Perl_debug_log,
        "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
     DEBUG_X(PerlIO_printf(Perl_debug_log,
        "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",

-       PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
+       PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))

     );
     return PL_curpad[po];
 }
     );
     return PL_curpad[po];
 }


@@ -839,19 +919,15 @@ Use the macro PAD_SETSV() rather than calling this function directly.
 =cut
 */
 
 =cut
 */
 

-#ifdef DEBUGGING

 void
 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 {
 void
 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 {

-    /* for display purposes, try to guess the AV corresponding to
-     * Pl_curpad */
-    AV *cp = PL_comppad;
-    if (cp && AvARRAY(cp) != PL_curpad)
-       cp = Nullav;
+    dVAR;
+    ASSERT_CURPAD_ACTIVE("pad_setsv");

 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
        "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
        "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",

-       PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
+       PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))

     );
     PL_curpad[po] = sv;
 }
     );
     PL_curpad[po] = sv;
 }


@@ -876,6 +952,8 @@ Update the pad compilation state variables on entry to a new block
 void
 Perl_pad_block_start(pTHX_ int full)
 {
 void
 Perl_pad_block_start(pTHX_ int full)
 {

+    dVAR;
+    ASSERT_CURPAD_ACTIVE("pad_block_start");

     SAVEI32(PL_comppad_name_floor);
     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
     if (full)
     SAVEI32(PL_comppad_name_floor);
     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
     if (full)


@@ -903,22 +981,25 @@ Perl_pad_block_start(pTHX_ int full)
 U32
 Perl_intro_my(pTHX)
 {
 U32
 Perl_intro_my(pTHX)
 {

+    dVAR;

     SV **svp;
     SV **svp;

-    SV *sv;

     I32 i;
 
     I32 i;
 

+    ASSERT_CURPAD_ACTIVE("intro_my");

     if (! PL_min_intro_pending)
        return PL_cop_seqmax;
 
     svp = AvARRAY(PL_comppad_name);
     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
     if (! PL_min_intro_pending)
        return PL_cop_seqmax;
 
     svp = AvARRAY(PL_comppad_name);
     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {

-       if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
-           SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
-           SvNVX(sv) = (NV)PL_cop_seqmax;
+       SV * const sv = svp[i];
+
+       if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !SvIVX(sv)) {
+           SvIV_set(sv, PAD_MAX);      /* Don't know scope end yet. */
+           SvNV_set(sv, (NV)PL_cop_seqmax);

            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,

-               "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
-               (long)i, SvPVX(sv),
-               (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+               "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
+               (long)i, SvPVX_const(sv),
+               (long)U_32(SvNVX(sv)), (long)SvIVX(sv))

            );
        }
     }
            );
        }
     }


@@ -942,27 +1023,32 @@ lexicals in this scope and warn of any lexicals that never got introduced.
 void
 Perl_pad_leavemy(pTHX)
 {
 void
 Perl_pad_leavemy(pTHX)
 {

+    dVAR;

     I32 off;
     I32 off;

-    SV **svp = AvARRAY(PL_comppad_name);
-    SV *sv;
+    SV * const * const svp = AvARRAY(PL_comppad_name);

 
     PL_pad_reset_pending = FALSE;
 
 
     PL_pad_reset_pending = FALSE;
 

+    ASSERT_CURPAD_ACTIVE("pad_leavemy");

     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
        for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
        for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {

-           if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
+           const SV * const sv = svp[off];
+           if (sv && sv != &PL_sv_undef
+                   && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))

                Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
                Perl_warner(aTHX_ packWARN(WARN_INTERNAL),

-                                       "%s never introduced", SvPVX(sv));
+                           "%"SVf" never introduced",
+                           (void*)sv);

        }
     }
     /* "Deintroduce" my variables that are leaving with this scope. */
     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
        }
     }
     /* "Deintroduce" my variables that are leaving with this scope. */
     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {

-       if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
-           SvIVX(sv) = PL_cop_seqmax;
+       const SV * const sv = svp[off];
+       if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX) {
+           SvIV_set(sv, PL_cop_seqmax);

            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,

-               "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
-               (long)off, SvPVX(sv),
-               (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
+               "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
+               (long)off, SvPVX_const(sv),
+               (long)U_32(SvNVX(sv)), (long)SvIVX(sv))

            );
        }
     }
            );
        }
     }


@@ -984,6 +1070,8 @@ new one.
 void
 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 {
 void
 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 {

+    dVAR;
+    ASSERT_CURPAD_LEGAL("pad_swipe");

     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)


@@ -1000,8 +1088,15 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
     if (refadjust)
        SvREFCNT_dec(PL_curpad[po]);
 
     if (refadjust)
        SvREFCNT_dec(PL_curpad[po]);
 

-    PL_curpad[po] = NEWSV(1107,0);
+
+    /* if pad tmps aren't shared between ops, then there's no need to
+     * create a new tmp when an existing op is freed */
+#ifdef USE_BROKEN_PAD_RESET
+    PL_curpad[po] = newSV(0);

     SvPADTMP_on(PL_curpad[po]);
     SvPADTMP_on(PL_curpad[po]);

+#else
+    PL_curpad[po] = &PL_sv_undef;
+#endif

     if ((I32)po < PL_padix)
        PL_padix = po - 1;
 }
     if ((I32)po < PL_padix)
        PL_padix = po - 1;
 }


@@ -1024,9 +1119,8 @@ Mark all the current temporaries for reuse
 void
 Perl_pad_reset(pTHX)
 {
 void
 Perl_pad_reset(pTHX)
 {

+    dVAR;

 #ifdef USE_BROKEN_PAD_RESET
 #ifdef USE_BROKEN_PAD_RESET

-    register I32 po;
-

     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_reset curpad");
 
     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_reset curpad");
 


@@ -1038,6 +1132,7 @@ Perl_pad_reset(pTHX)
     );
 
     if (!PL_tainting) {        /* Can't mix tainted and non-tainted temporaries. */
     );
 
     if (!PL_tainting) {        /* Can't mix tainted and non-tainted temporaries. */

+        register I32 po;

        for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
            if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
                SvPADTMP_off(PL_curpad[po]);
        for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
            if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
                SvPADTMP_off(PL_curpad[po]);


@@ -1068,14 +1163,40 @@ Tidy up a pad after we've finished compiling it:
 void
 Perl_pad_tidy(pTHX_ padtidy_type type)
 {
 void
 Perl_pad_tidy(pTHX_ padtidy_type type)
 {

-    PADOFFSET ix;
+    dVAR;
+
+    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) {
+        const CV *cv;
+       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))
 
     /* extend curpad to match namepad */
     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))

-       av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
+       av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);

 
     if (type == padtidy_SUBCLONE) {
 
     if (type == padtidy_SUBCLONE) {

-       SV **namep = AvARRAY(PL_comppad_name);
+       SV * const * const namep = AvARRAY(PL_comppad_name);
+       PADOFFSET ix;
+

        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            SV *namesv;
 
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            SV *namesv;
 


@@ -1083,30 +1204,30 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
                continue;
            /*
             * The only things that a clonable function needs in its
                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.
             */
             * The rest are created anew during cloning.
             */

-           if (!((namesv = namep[ix]) != Nullsv &&
+           if (!((namesv = namep[ix]) != NULL &&

                  namesv != &PL_sv_undef &&
                  namesv != &PL_sv_undef &&

-                 (SvFAKE(namesv) ||
-                  *SvPVX(namesv) == '&')))
+                  *SvPVX_const(namesv) == '&'))

            {
                SvREFCNT_dec(PL_curpad[ix]);
            {
                SvREFCNT_dec(PL_curpad[ix]);

-               PL_curpad[ix] = Nullsv;
+               PL_curpad[ix] = NULL;

            }
        }
     }
     else if (type == padtidy_SUB) {
        /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
            }
        }
     }
     else if (type == padtidy_SUB) {
        /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */

-       AV *av = newAV();                       /* Will be @_ */
+       AV * const av = newAV();                        /* Will be @_ */

        av_extend(av, 0);
        av_store(PL_comppad, 0, (SV*)av);
        av_extend(av, 0);
        av_store(PL_comppad, 0, (SV*)av);

-       AvFLAGS(av) = AVf_REIFY;
+       AvREIFY_only(av);

     }
 
     /* XXX DAPM rationalise these two similar branches */
 
     if (type == padtidy_SUB) {
     }
 
     /* XXX DAPM rationalise these two similar branches */
 
     if (type == padtidy_SUB) {

+       PADOFFSET ix;

        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
                continue;
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
                continue;


@@ -1115,18 +1236,20 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
        }
     }
     else if (type == padtidy_FORMAT) {
        }
     }
     else if (type == padtidy_FORMAT) {

+       PADOFFSET ix;

        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
                SvPADTMP_on(PL_curpad[ix]);
        }
     }
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
                SvPADTMP_on(PL_curpad[ix]);
        }
     }

+    PL_curpad = AvARRAY(PL_comppad);

 }
 
 
 /*
 =for apidoc pad_free
 
 }
 
 
 /*
 =for apidoc pad_free
 

-Free the SV at offet po in the current pad.
+Free the SV at offset po in the current pad.

 
 =cut
 */
 
 =cut
 */


@@ -1135,6 +1258,8 @@ Free the SV at offet po in the current pad.
 void
 Perl_pad_free(pTHX_ PADOFFSET po)
 {
 void
 Perl_pad_free(pTHX_ PADOFFSET po)
 {

+    dVAR;
+    ASSERT_CURPAD_LEGAL("pad_free");

     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)


@@ -1150,13 +1275,15 @@ Perl_pad_free(pTHX_ PADOFFSET po)
     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
        SvPADTMP_off(PL_curpad[po]);
 #ifdef USE_ITHREADS
     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
        SvPADTMP_off(PL_curpad[po]);
 #ifdef USE_ITHREADS

-#ifdef PERL_COPY_ON_WRITE
-       if (SvIsCOW(PL_curpad[po])) {
-           sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
-       } else
+       /* SV could be a shared hash key (eg bugid #19022) */
+       if (
+#ifdef PERL_OLD_COPY_ON_WRITE
+           !SvIsCOW(PL_curpad[po])
+#else
+           !SvFAKE(PL_curpad[po])

 #endif
 #endif

+           )

            SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
            SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */

-

 #endif
     }
     if ((I32)po < PL_padix)
 #endif
     }
     if ((I32)po < PL_padix)


@@ -1176,11 +1303,11 @@ Dump the contents of a padlist
 void
 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
 {
 void
 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
 {

-    AV *pad_name;
-    AV *pad;
+    dVAR;
+    const AV *pad_name;
+    const AV *pad;

     SV **pname;
     SV **ppad;
     SV **pname;
     SV **ppad;

-    SV *namesv;

     I32 ix;
 
     if (!padlist) {
     I32 ix;
 
     if (!padlist) {


@@ -1196,21 +1323,32 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
     );
 
     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
     );
 
     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {

-       namesv = pname[ix];
+        const SV *namesv = pname[ix];

        if (namesv && namesv == &PL_sv_undef) {
        if (namesv && namesv == &PL_sv_undef) {

-           namesv = Nullsv;
+           namesv = NULL;

        }
        if (namesv) {
        }
        if (namesv) {

-           Perl_dump_indent(aTHX_ level+1, file,
-               "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
-               (int) ix,
-               PTR2UV(ppad[ix]),
-               (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
-               SvFAKE(namesv) ? "FAKE" : "    ",
-               (unsigned long)I_32(SvNVX(namesv)),
-               (unsigned long)SvIVX(namesv),
-               SvPVX(namesv)
-           );
+           if (SvFAKE(namesv))
+               Perl_dump_indent(aTHX_ level+1, file,
+                   "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
+                   (int) ix,
+                   PTR2UV(ppad[ix]),
+                   (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
+                   SvPVX_const(namesv),
+                   (unsigned long)SvIVX(namesv),
+                   (unsigned long)SvNVX(namesv)
+
+               );
+           else
+               Perl_dump_indent(aTHX_ level+1, file,
+                   "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
+                   (int) ix,
+                   PTR2UV(ppad[ix]),
+                   (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
+                   (long)U_32(SvNVX(namesv)),
+                   (long)SvIVX(namesv),
+                   SvPVX_const(namesv)
+               );

        }
        else if (full) {
            Perl_dump_indent(aTHX_ level+1, file,
        }
        else if (full) {
            Perl_dump_indent(aTHX_ level+1, file,


@@ -1235,16 +1373,18 @@ dump the contents of a CV
 
 #ifdef DEBUGGING
 STATIC void
 
 #ifdef DEBUGGING
 STATIC void

-S_cv_dump(pTHX_ CV *cv, char *title)
+S_cv_dump(pTHX_ const CV *cv, const char *title)

 {
 {

-    CV *outside = CvOUTSIDE(cv);
-    AV* padlist = CvPADLIST(cv);
+    dVAR;
+    const CV * const outside = CvOUTSIDE(cv);
+    AV* const padlist = CvPADLIST(cv);

 
     PerlIO_printf(Perl_debug_log,
                  "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
                  title,
                  PTR2UV(cv),
                  (CvANON(cv) ? "ANON"
 
     PerlIO_printf(Perl_debug_log,
                  "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
                  title,
                  PTR2UV(cv),
                  (CvANON(cv) ? "ANON"

+                  : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"

                   : (cv == PL_main_cv) ? "MAIN"
                   : CvUNIQUE(cv) ? "UNIQUE"
                   : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
                   : (cv == PL_main_cv) ? "MAIN"
                   : CvUNIQUE(cv) ? "UNIQUE"
                   : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),


@@ -1278,127 +1418,111 @@ any outer lexicals.
 CV *
 Perl_cv_clone(pTHX_ CV *proto)
 {
 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)
-{
+    dVAR;

     I32 ix;
     I32 ix;

-    AV* protopadlist = CvPADLIST(proto);
-    AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
-    AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
-    SV** pname = AvARRAY(protopad_name);
-    SV** ppad = AvARRAY(protopad);
-    I32 fname = AvFILLp(protopad_name);
-    I32 fpad = AvFILLp(protopad);
-    AV* comppadlist;
+    AV* const protopadlist = CvPADLIST(proto);
+    const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+    const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+    SV** const pname = AvARRAY(protopad_name);
+    SV** const ppad = AvARRAY(protopad);
+    const I32 fname = AvFILLp(protopad_name);
+    const I32 fpad = AvFILLp(protopad);

     CV* cv;
     CV* cv;

+    SV** outpad;
+    CV* outside;
+    long depth;

 
     assert(!CvUNIQUE(proto));
 
 
     assert(!CvUNIQUE(proto));
 

+    /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+     * to a prototype; we instead want the cloned parent who called us.
+     * Note that in general for formats, CvOUTSIDE != find_runcv */
+
+    outside = CvOUTSIDE(proto);
+    if (outside && CvCLONE(outside) && ! CvCLONED(outside))
+       outside = find_runcv(NULL);
+    depth = CvDEPTH(outside);
+    assert(depth || SvTYPE(proto) == SVt_PVFM);
+    if (!depth)
+       depth = 1;
+    assert(CvPADLIST(outside));
+

     ENTER;
     SAVESPTR(PL_compcv);
 
     ENTER;
     SAVESPTR(PL_compcv);
 

-    cv = PL_compcv = (CV*)NEWSV(1104, 0);
+    cv = PL_compcv = (CV*)newSV(0);

     sv_upgrade((SV *)cv, SvTYPE(proto));
     sv_upgrade((SV *)cv, SvTYPE(proto));

-    CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
+    CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);

     CvCLONED_on(cv);
 
     CvCLONED_on(cv);
 

-#ifdef USE_5005THREADS
-    New(666, CvMUTEXP(cv), 1, perl_mutex);
-    MUTEX_INIT(CvMUTEXP(cv));
-    CvOWNER(cv)                = 0;
-#endif /* USE_5005THREADS */

 #ifdef USE_ITHREADS
 #ifdef USE_ITHREADS

-    CvFILE(cv)         = CvXSUB(proto) ? CvFILE(proto)
-                                       : savepv(CvFILE(proto));
+    CvFILE(cv)         = CvISXSUB(proto) ? CvFILE(proto)
+                                         : savepv(CvFILE(proto));

 #else
     CvFILE(cv)         = CvFILE(proto);
 #endif
     CvGV(cv)           = CvGV(proto);
     CvSTASH(cv)                = CvSTASH(proto);
 #else
     CvFILE(cv)         = CvFILE(proto);
 #endif
     CvGV(cv)           = CvGV(proto);
     CvSTASH(cv)                = CvSTASH(proto);

+    OP_REFCNT_LOCK;

     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));

+    OP_REFCNT_UNLOCK;

     CvSTART(cv)                = CvSTART(proto);
     CvSTART(cv)                = CvSTART(proto);

-    if (outside)
-       CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
+    CvOUTSIDE(cv)      = (CV*)SvREFCNT_inc_simple(outside);
+    CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);

 
     if (SvPOK(proto))
 
     if (SvPOK(proto))

-       sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
+       sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));

 
 

-    CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
+    CvPADLIST(cv) = 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]));
 
     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);
 
     PL_curpad = AvARRAY(PL_comppad);
 

+    outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+

     for (ix = fpad; ix > 0; ix--) {
     for (ix = fpad; ix > 0; ix--) {

-       SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
-       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);
-               if (!off)
-                   PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
-               else if (off != ix)
-                   Perl_croak(aTHX_ "panic: cv_clone: %s", name);
+       SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+       SV *sv = NULL;
+       if (namesv && namesv != &PL_sv_undef) { /* lexical */
+           if (SvFAKE(namesv)) {   /* lexical from outside? */
+               sv = outpad[(I32)SvNVX(namesv)];
+               assert(sv);
+               /* formats may have an inactive parent */
+               if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
+                   if (ckWARN(WARN_CLOSURE))
+                       Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
+                           "Variable \"%s\" is not available", SvPVX_const(namesv));
+                   sv = NULL;
+               }
+               else {
+                   assert(!SvPADSTALE(sv));
+                   SvREFCNT_inc_simple_void_NN(sv);
+               }

            }
            }

-           else {                              /* our own lexical */
-               SV* sv;
-               if (*name == '&') {
-                   /* anon code -- we'll come back for it */
+           if (!sv) {
+                const char sigil = SvPVX_const(namesv)[0];
+                if (sigil == '&')

                    sv = SvREFCNT_inc(ppad[ix]);
                    sv = SvREFCNT_inc(ppad[ix]);

-               }
-               else if (*name == '@')
+                else if (sigil == '@')

                    sv = (SV*)newAV();
                    sv = (SV*)newAV();

-               else if (*name == '%')
+                else if (sigil == '%')

                    sv = (SV*)newHV();
                else
                    sv = (SV*)newHV();
                else

-                   sv = NEWSV(0, 0);
-               if (!SvPADBUSY(sv))
-                   SvPADMY_on(sv);
-               PL_curpad[ix] = sv;
+                   sv = newSV(0);
+               SvPADMY_on(sv);

            }
        }
        else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
            }
        }
        else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {

-           PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+           sv = SvREFCNT_inc_NN(ppad[ix]);

        }
        else {
        }
        else {

-           SV* sv = NEWSV(0, 0);
+           sv = newSV(0);

            SvPADTMP_on(sv);
            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;

        }
        }

+       PL_curpad[ix] = sv;

     }
 
     DEBUG_Xv(
     }
 
     DEBUG_Xv(


@@ -1411,11 +1535,19 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     LEAVE;
 
     if (CvCONST(cv)) {
     LEAVE;
 
     if (CvCONST(cv)) {

-       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);
+       /* 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 const_sv = op_const_sv(CvSTART(cv), cv);
+       if (const_sv) {
+           SvREFCNT_dec(cv);
+           cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+       }
+       else {
+           CvCONST_off(cv);
+       }

     }
 
     return cv;
     }
 
     return cv;


@@ -1426,7 +1558,8 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 =for apidoc pad_fixup_inner_anons
 
 For any anon CVs in the pad, change CvOUTSIDE of that CV from
 =for apidoc pad_fixup_inner_anons
 
 For any anon CVs in the pad, change CvOUTSIDE of that CV from

-old_cv to new_cv if necessary.
+old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
+moved to a pre-existing CV struct.

 
 =cut
 */
 
 =cut
 */


@@ -1434,85 +1567,108 @@ old_cv to new_cv if necessary.
 void
 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 {
 void
 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 {

+    dVAR;

     I32 ix;
     I32 ix;

-    AV *comppad_name = (AV*)AvARRAY(padlist)[0];
-    AV *comppad = (AV*)AvARRAY(padlist)[1];
-    SV **namepad = AvARRAY(comppad_name);
-    SV **curpad = AvARRAY(comppad);
+    AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
+    AV * const comppad = (AV*)AvARRAY(padlist)[1];
+    SV ** const namepad = AvARRAY(comppad_name);
+    SV ** const curpad = AvARRAY(comppad);
+    PERL_UNUSED_ARG(old_cv);
+

     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {

-       SV *namesv = namepad[ix];
+        const SV * const namesv = namepad[ix];

        if (namesv && namesv != &PL_sv_undef
        if (namesv && namesv != &PL_sv_undef

-           && *SvPVX(namesv) == '&')
+           && *SvPVX_const(namesv) == '&')

        {
        {

-           CV *innercv = (CV*)curpad[ix];
-           if (CvOUTSIDE(innercv) == old_cv) {
-               CvOUTSIDE(innercv) = new_cv;
-               if (!CvANON(innercv) || CvCLONED(innercv)) {
-                   (void)SvREFCNT_inc(new_cv);
-                   SvREFCNT_dec(old_cv);
-               }
-           }
+           CV * const innercv = (CV*)curpad[ix];
+           assert(CvWEAKOUTSIDE(innercv));
+           assert(CvOUTSIDE(innercv) == old_cv);
+           CvOUTSIDE(innercv) = new_cv;

        }
     }
 }
 
        }
     }
 }
 

+

 /*
 =for apidoc pad_push
 
 Push a new pad frame onto the padlist, unless there's already a pad at
 /*
 =for apidoc pad_push
 
 Push a new pad frame onto the padlist, unless there's already a pad at

-this depth, in which case don't bother creating a new one.
-If has_args is true, give the new pad an @_ in slot zero.
+this depth, in which case don't bother creating a new one.  Then give
+the new pad an @_ in slot zero.

 
 =cut
 */
 
 void
 
 =cut
 */
 
 void

-Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
+Perl_pad_push(pTHX_ PADLIST *padlist, int depth)

 {
 {

-    if (depth <= AvFILLp(padlist))
-       return;
-
-    {
-       SV** svp = AvARRAY(padlist);
-       AV *newpad = newAV();
-       SV **oldpad = AvARRAY(svp[depth-1]);
+    dVAR;
+    if (depth > AvFILLp(padlist)) {
+       SV** const svp = AvARRAY(padlist);
+       AV* const newpad = newAV();
+       SV** const oldpad = AvARRAY(svp[depth-1]);

        I32 ix = AvFILLp((AV*)svp[1]);
        I32 ix = AvFILLp((AV*)svp[1]);

-       I32 names_fill = AvFILLp((AV*)svp[0]);
-       SV** names = AvARRAY(svp[0]);
-       SV* sv;
+        const I32 names_fill = AvFILLp((AV*)svp[0]);
+       SV** const names = AvARRAY(svp[0]);
+       AV *av;
+

        for ( ;ix > 0; ix--) {
            if (names_fill >= ix && names[ix] != &PL_sv_undef) {
        for ( ;ix > 0; ix--) {
            if (names_fill >= ix && names[ix] != &PL_sv_undef) {

-               char *name = SvPVX(names[ix]);
-               if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
+               const char sigil = SvPVX_const(names[ix])[0];
+               if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {

                    /* outer lexical or anon code */
                    av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
                }
                else {          /* our own lexical */
                    /* outer lexical or anon code */
                    av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
                }
                else {          /* our own lexical */

-                   if (*name == '@')
-                       av_store(newpad, ix, sv = (SV*)newAV());
-                   else if (*name == '%')
-                       av_store(newpad, ix, sv = (SV*)newHV());
+                   SV *sv; 
+                   if (sigil == '@')
+                       sv = (SV*)newAV();
+                   else if (sigil == '%')
+                       sv = (SV*)newHV();

                    else
                    else

-                       av_store(newpad, ix, sv = NEWSV(0, 0));
+                       sv = newSV(0);
+                   av_store(newpad, ix, sv);

                    SvPADMY_on(sv);
                }
            }
            else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
                    SvPADMY_on(sv);
                }
            }
            else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {

-               av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
+               av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));

            }
            else {
                /* save temporaries on recursion? */
            }
            else {
                /* save temporaries on recursion? */

-               av_store(newpad, ix, sv = NEWSV(0, 0));
+               SV * const sv = newSV(0);
+               av_store(newpad, ix, sv);

                SvPADTMP_on(sv);
            }
        }
                SvPADTMP_on(sv);
            }
        }

-       if (has_args) {
-           AV* av = newAV();
-           av_extend(av, 0);
-           av_store(newpad, 0, (SV*)av);
-           AvFLAGS(av) = AVf_REIFY;
-       }
+       av = newAV();
+       av_extend(av, 0);
+       av_store(newpad, 0, (SV*)av);
+       AvREIFY_only(av);
+

        av_store(padlist, depth, (SV*)newpad);
        AvFILLp(padlist) = depth;
     }
 }
        av_store(padlist, depth, (SV*)newpad);
        AvFILLp(padlist) = depth;
     }
 }

+
+
+HV *
+Perl_pad_compname_type(pTHX_ const PADOFFSET po)
+{
+    dVAR;
+    SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
+    if ( SvPAD_TYPED(*av) ) {
+        return SvSTASH(*av);
+    }
+    return NULL;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */