pad.c:cv_clone: add assertions

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index 7e9dcc0..8deae8e 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -42,8 +42,9 @@ 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).
 
 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 pad.c) rather than normal av.c rules.
+The CvPADLIST AV has the REFCNT of its component items managed "manually"
+(mostly in pad.c) rather than by normal av.c rules.  So we turn off AvREAL
+just before freeing it, to let av.c know not to touch the entries.

 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


@@ -173,8 +174,8 @@ This is basically sv_eq_flags() in sv.c, but we avoid the magic
 and bytes checking.
 */
 
 and bytes checking.
 */
 

-STATIC I32
-sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const I32 pvlen, const U32 flags) {
+static bool
+sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {

     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
         const char *pv1 = SvPVX_const(sv);
         STRLEN cur1     = SvCUR(sv);
     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
         const char *pv1 = SvPVX_const(sv);
         STRLEN cur1     = SvCUR(sv);


@@ -277,7 +278,6 @@ Perl_pad_new(pTHX_ int flags)
        av_store(pad, 0, NULL);
     }
 
        av_store(pad, 0, NULL);
     }
 

-    AvREAL_off(padlist);

     /* Most subroutines never recurse, hence only need 2 entries in the padlist
        array - names, and depth=1.  The default for av_store() is to allocate
        0..3, and even an explicit call to av_extend() with <3 will be rounded
     /* Most subroutines never recurse, hence only need 2 entries in the padlist
        array - names, and depth=1.  The default for av_store() is to allocate
        0..3, and even an explicit call to av_extend() with <3 will be rounded


@@ -333,6 +333,7 @@ Perl_cv_undef(pTHX_ CV *cv)
 {
     dVAR;
     const PADLIST *padlist = CvPADLIST(cv);
 {
     dVAR;
     const PADLIST *padlist = CvPADLIST(cv);

+    bool const slabbed = !!CvSLABBED(cv);

 
     PERL_ARGS_ASSERT_CV_UNDEF;
 
 
     PERL_ARGS_ASSERT_CV_UNDEF;
 


@@ -341,14 +342,12 @@ Perl_cv_undef(pTHX_ CV *cv)
            PTR2UV(cv), PTR2UV(PL_comppad))
     );
 
            PTR2UV(cv), PTR2UV(PL_comppad))
     );
 

-#ifdef USE_ITHREADS
-    if (CvFILE(cv) && !CvISXSUB(cv)) {
-       /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+    if (CvFILE(cv) && CvDYNFILE(cv)) {

        Safefree(CvFILE(cv));
     }
     CvFILE(cv) = NULL;
        Safefree(CvFILE(cv));
     }
     CvFILE(cv) = NULL;

-#endif

 
 

+    CvSLABBED_off(cv);

     if (!CvISXSUB(cv) && CvROOT(cv)) {
        if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
            Perl_croak(aTHX_ "Can't undef active subroutine");
     if (!CvISXSUB(cv) && CvROOT(cv)) {
        if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
            Perl_croak(aTHX_ "Can't undef active subroutine");


@@ -356,12 +355,27 @@ Perl_cv_undef(pTHX_ CV *cv)
 
        PAD_SAVE_SETNULLPAD();
 
 
        PAD_SAVE_SETNULLPAD();
 

+       if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));

        op_free(CvROOT(cv));
        CvROOT(cv) = NULL;
        CvSTART(cv) = NULL;
        LEAVE;
     }
        op_free(CvROOT(cv));
        CvROOT(cv) = NULL;
        CvSTART(cv) = NULL;
        LEAVE;
     }

+    else if (slabbed && CvSTART(cv)) {
+       ENTER;
+       PAD_SAVE_SETNULLPAD();
+
+       /* discard any leaked ops */
+       opslab_force_free((OPSLAB *)CvSTART(cv));
+       CvSTART(cv) = NULL;
+
+       LEAVE;
+    }
+#ifdef DEBUGGING
+    else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif

     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */
     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */

+    sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);

     CvGV_set(cv, NULL);
 
     /* This statement and the subsequence if block was pad_undef().  */
     CvGV_set(cv, NULL);
 
     /* This statement and the subsequence if block was pad_undef().  */


@@ -403,6 +417,7 @@ Perl_cv_undef(pTHX_ CV *cv)
                        CV * const innercv = MUTABLE_CV(curpad[ix]);
                        U32 inner_rc = SvREFCNT(innercv);
                        assert(inner_rc);
                        CV * const innercv = MUTABLE_CV(curpad[ix]);
                        U32 inner_rc = SvREFCNT(innercv);
                        assert(inner_rc);

+                       assert(SvTYPE(innercv) != SVt_PVFM);

                        namepad[ix] = NULL;
                        SvREFCNT_dec(namesv);
 
                        namepad[ix] = NULL;
                        SvREFCNT_dec(namesv);
 


@@ -447,6 +462,7 @@ Perl_cv_undef(pTHX_ CV *cv)
                PL_comppad_name = NULL;
            SvREFCNT_dec(sv);
        }
                PL_comppad_name = NULL;
            SvREFCNT_dec(sv);
        }

+       AvREAL_off(CvPADLIST(cv));

        SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
        CvPADLIST(cv) = NULL;
     }
        SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
        CvPADLIST(cv) = NULL;
     }


@@ -466,8 +482,56 @@ Perl_cv_undef(pTHX_ CV *cv)
        CvXSUB(cv) = NULL;
     }
     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
        CvXSUB(cv) = NULL;
     }
     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the

-     * ref status of CvOUTSIDE and CvGV */
-    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+     * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
+     * to choose an error message */
+    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
+}
+
+/*
+=for apidoc cv_forget_slab
+
+When a CV has a reference count on its slab (CvSLABBED), it is responsible
+for making sure it is freed.  (Hence, no two CVs should ever have a
+reference count on the same slab.)  The CV only needs to reference the slab
+during compilation.  Once it is compiled and CvROOT attached, it has
+finished its job, so it can forget the slab.
+
+=cut
+*/
+
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+    const bool slabbed = !!CvSLABBED(cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+    OPSLAB *slab = NULL;
+#endif
+
+    PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+    if (!slabbed) return;
+
+    CvSLABBED_off(cv);
+
+#ifdef PERL_DEBUG_READONLY_OPS
+    if      (CvROOT(cv))  slab = OpSLAB(CvROOT(cv));
+    else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
+#else
+    if      (CvROOT(cv))  OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+    else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+#endif
+#ifdef DEBUGGING
+    else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+#endif
+
+#ifdef PERL_DEBUG_READONLY_OPS
+    if (slab) {
+       size_t refcnt;
+       refcnt = slab->opslab_refcnt;
+       OpslabREFCNT_dec(slab);
+       if (refcnt > 1) Slab_to_ro(slab);
+    }
+#endif

 }
 
 /*
 }
 
 /*


@@ -605,7 +669,7 @@ instead of a string/length pair.
 
 PADOFFSET
 Perl_pad_add_name_pv(pTHX_ const char *name,
 
 PADOFFSET
 Perl_pad_add_name_pv(pTHX_ const char *name,

-               U32 flags, HV *typestash, HV *ourstash)
+                    const U32 flags, HV *typestash, HV *ourstash)

 {
     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
 {
     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);


@@ -653,11 +717,6 @@ but is used for debugging.
 
 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
  * or at least rationalise ??? */
 
 /* 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.
-   NWC
-*/

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


@@ -670,7 +729,8 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
     ASSERT_CURPAD_ACTIVE("pad_alloc");
 
     if (AvARRAY(PL_comppad) != PL_curpad)
     ASSERT_CURPAD_ACTIVE("pad_alloc");
 
     if (AvARRAY(PL_comppad) != PL_curpad)

-       Perl_croak(aTHX_ "panic: pad_alloc");
+       Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
+                  AvARRAY(PL_comppad), PL_curpad);

     if (PL_pad_reset_pending)
        pad_reset();
     if (tmptype & SVs_PADMY) {
     if (PL_pad_reset_pending)
        pad_reset();
     if (tmptype & SVs_PADMY) {


@@ -749,12 +809,19 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
     ix = pad_alloc(optype, SVs_PADMY);
     av_store(PL_comppad_name, ix, name);
     /* XXX DAPM use PL_curpad[] ? */
     ix = pad_alloc(optype, SVs_PADMY);
     av_store(PL_comppad_name, ix, name);
     /* XXX DAPM use PL_curpad[] ? */

-    av_store(PL_comppad, ix, (SV*)func);
+    if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
+       av_store(PL_comppad, ix, (SV*)func);
+    else {
+       SV *rv = newRV_inc((SV *)func);
+       sv_rvweaken(rv);
+       assert (SvTYPE(func) == SVt_PVFM);
+       av_store(PL_comppad, ix, rv);
+    }

     SvPADMY_on((SV*)func);
 
     /* to avoid ref loops, we never have parent + child referencing each
      * other simultaneously */
     SvPADMY_on((SV*)func);
 
     /* to avoid ref loops, we never have parent + child referencing each
      * other simultaneously */

-    if (CvOUTSIDE(func)) {
+    if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {

        assert(!CvWEAKOUTSIDE(func));
        CvWEAKOUTSIDE_on(func);
        SvREFCNT_dec(CvOUTSIDE(func));
        assert(!CvWEAKOUTSIDE(func));
        CvWEAKOUTSIDE_on(func);
        SvREFCNT_dec(CvOUTSIDE(func));


@@ -763,13 +830,15 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
 }
 
 /*
 }
 
 /*

-=for apidoc m|pad_check_dup|SV *name|U32 flags|const HV *ourstash
+=for apidoc pad_check_dup

 
 Check for duplicate declarations: report any of:
 
 Check for duplicate declarations: report any of:

+

      * a my in the current scope with the same name;
      * a my in the current scope with the same name;

-     * an our (anywhere in the pad) with the same name and the same stash
-       as C<ourstash>
-C<is_our> indicates that the name to check is an 'our' declaration
+     * an our (anywhere in the pad) with the same name and the
+       same stash as C<ourstash>
+
+C<is_our> indicates that the name to check is an 'our' declaration.

 
 =cut
 */
 
 =cut
 */


@@ -996,6 +1065,24 @@ Perl_find_rundefsv(pTHX)
     return PAD_SVl(po);
 }
 
     return PAD_SVl(po);
 }
 

+SV *
+Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+{
+    SV *namesv;
+    int flags;
+    PADOFFSET po;
+
+    PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
+
+    po = pad_findlex("$_", 2, 0, cv, seq, 1,
+           NULL, &namesv, &flags);
+
+    if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
+       return DEFSV;
+
+    return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
+}
+

 /*
 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
 
 /*
 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
 


@@ -1047,7 +1134,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
 
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
        "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
 
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
        "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",

-       PTR2UV(cv), namelen, namepv, (int)seq,
+                          PTR2UV(cv), (int)namelen, namepv, (int)seq,

        out_capture ? " capturing" : "" ));
 
     /* first, search this pad */
        out_capture ? " capturing" : "" ));
 
     /* first, search this pad */


@@ -1381,7 +1468,9 @@ Perl_pad_block_start(pTHX_ int full)
 /*
 =for apidoc m|U32|intro_my
 
 /*
 =for apidoc m|U32|intro_my
 

-"Introduce" my variables to visible status.
+"Introduce" my variables to visible status.  This is called during parsing
+at the end of each statement to make lexical variables visible to
+subsequent statements.

 
 =cut
 */
 
 =cut
 */


@@ -1494,9 +1583,11 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)

-       Perl_croak(aTHX_ "panic: pad_swipe curpad");
-    if (!po)
-       Perl_croak(aTHX_ "panic: pad_swipe po");
+       Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
+                  AvARRAY(PL_comppad), PL_curpad);
+    if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
+       Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
+                  (long)po, (long)AvFILLp(PL_comppad));

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


@@ -1540,7 +1631,8 @@ S_pad_reset(pTHX)
     dVAR;
 #ifdef USE_BROKEN_PAD_RESET
     if (AvARRAY(PL_comppad) != PL_curpad)
     dVAR;
 #ifdef USE_BROKEN_PAD_RESET
     if (AvARRAY(PL_comppad) != PL_curpad)

-       Perl_croak(aTHX_ "panic: pad_reset curpad");
+       Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
+                  AvARRAY(PL_comppad), PL_curpad);

 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
            "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
            "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",


@@ -1606,6 +1698,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
                DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                    "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
                CvCLONE_on(cv);
                DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                    "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
                CvCLONE_on(cv);

+               CvHASEVAL_on(cv);

            }
        }
     }
            }
        }
     }


@@ -1693,7 +1786,8 @@ Perl_pad_free(pTHX_ PADOFFSET po)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)

-       Perl_croak(aTHX_ "panic: pad_free curpad");
+       Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
+                  AvARRAY(PL_comppad), PL_curpad);

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


@@ -1703,7 +1797,7 @@ Perl_pad_free(pTHX_ PADOFFSET po)
     );
 
     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
     );
 
     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {

-       SvPADTMP_off(PL_curpad[po]);
+       SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */

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


@@ -1855,43 +1949,55 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     assert(!CvUNIQUE(proto));
 
 
     assert(!CvUNIQUE(proto));
 

-    /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+    /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
+     * reliable.  The currently-running sub is always the one we need to
+     * close over.
+     * Note that in general for formats, CvOUTSIDE != find_runcv.
+     * Since formats may be nested inside closures, CvOUTSIDE may point

      * to a prototype; we instead want the cloned parent who called us.
      * 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))
+    if (SvTYPE(proto) == SVt_PVCV)

        outside = find_runcv(NULL);
        outside = find_runcv(NULL);

+    else {
+       outside = CvOUTSIDE(proto);
+       if (CvCLONE(outside) && ! CvCLONED(outside)) {
+           CV * const runcv = find_runcv_where(
+               FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+           );
+           if (runcv) outside = runcv;
+       }
+    }

     depth = CvDEPTH(outside);
     assert(depth || SvTYPE(proto) == SVt_PVFM);
     if (!depth)
        depth = 1;
     depth = CvDEPTH(outside);
     assert(depth || SvTYPE(proto) == SVt_PVFM);
     if (!depth)
        depth = 1;

-    assert(CvPADLIST(outside));
+    assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);

 
     ENTER;
     SAVESPTR(PL_compcv);
 
     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
 
     ENTER;
     SAVESPTR(PL_compcv);
 
     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));

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

     CvCLONED_on(cv);
 
     CvCLONED_on(cv);
 

-#ifdef USE_ITHREADS
-    CvFILE(cv)         = CvISXSUB(proto) ? CvFILE(proto)
-                                         : savepv(CvFILE(proto));
-#else
-    CvFILE(cv)         = CvFILE(proto);
-#endif
+    CvFILE(cv)         = CvDYNFILE(proto) ? savepv(CvFILE(proto))
+                                          : CvFILE(proto);

     CvGV_set(cv,CvGV(proto));
     CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;
     CvSTART(cv)                = CvSTART(proto);
     CvGV_set(cv,CvGV(proto));
     CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;
     CvSTART(cv)                = CvSTART(proto);

-    CvOUTSIDE(cv)      = MUTABLE_CV(SvREFCNT_inc_simple(outside));
+    if (CvHASEVAL(cv))
+       CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));

     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
 
     if (SvPOK(proto))
        sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
 
     if (SvPOK(proto))
        sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));

+    if (SvMAGIC(proto))
+       mg_copy((SV *)proto, (SV *)cv, 0, 0);

 
     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
 
 
     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
 


@@ -1901,19 +2007,23 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     PL_curpad = AvARRAY(PL_comppad);
 
 
     PL_curpad = AvARRAY(PL_comppad);
 

-    outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+    outpad = CvPADLIST(outside)
+       ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+       : NULL;
+    assert(outpad || SvTYPE(cv) == SVt_PVFM);

 
     for (ix = fpad; ix > 0; ix--) {
        SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
        SV *sv = NULL;
        if (namesv && namesv != &PL_sv_undef) { /* lexical */
            if (SvFAKE(namesv)) {   /* lexical from outside? */
 
     for (ix = fpad; ix > 0; ix--) {
        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[PARENT_PAD_INDEX(namesv)];
-               assert(sv);
-               /* formats may have an inactive parent,
+               /* formats may have an inactive, or even undefined, parent,

                   while my $x if $false can leave an active var marked as
                   stale. And state vars are always available */
                   while my $x if $false can leave an active var marked as
                   stale. And state vars are always available */

-               if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
+               if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+                || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
+                   && !CvDEPTH(outside))  ) {
+                   assert(SvTYPE(cv) == SVt_PVFM);

                    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
                                   "Variable \"%"SVf"\" is not available", namesv);
                    sv = NULL;
                    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
                                   "Variable \"%"SVf"\" is not available", namesv);
                    sv = NULL;


@@ -2003,10 +2113,23 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
        if (namesv && namesv != &PL_sv_undef
            && *SvPVX_const(namesv) == '&')
        {
        if (namesv && namesv != &PL_sv_undef
            && *SvPVX_const(namesv) == '&')
        {

+         if (SvTYPE(curpad[ix]) == SVt_PVCV) {

            CV * const innercv = MUTABLE_CV(curpad[ix]);
            assert(CvWEAKOUTSIDE(innercv));
            assert(CvOUTSIDE(innercv) == old_cv);
            CvOUTSIDE(innercv) = new_cv;
            CV * const innercv = MUTABLE_CV(curpad[ix]);
            assert(CvWEAKOUTSIDE(innercv));
            assert(CvOUTSIDE(innercv) == old_cv);
            CvOUTSIDE(innercv) = new_cv;

+         }
+         else { /* format reference */
+           SV * const rv = curpad[ix];
+           CV *innercv;
+           if (!SvOK(rv)) continue;
+           assert(SvROK(rv));
+           assert(SvWEAKREF(rv));
+           innercv = (CV *)SvRV(rv);
+           assert(!CvWEAKOUTSIDE(innercv));
+           SvREFCNT_dec(CvOUTSIDE(innercv));
+           CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
+         }

        }
     }
 }
        }
     }
 }


@@ -2120,15 +2243,9 @@ Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
     if (!srcpad)
        return NULL;
 
     if (!srcpad)
        return NULL;
 

-    assert(!AvREAL(srcpad));
-

     if (param->flags & CLONEf_COPY_STACKS
        || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
     if (param->flags & CLONEf_COPY_STACKS
        || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {

-       /* XXX padlists are real, but pretend to be not */
-       AvREAL_on(srcpad);

        dstpad = av_dup_inc(srcpad, param);
        dstpad = av_dup_inc(srcpad, param);

-       AvREAL_off(srcpad);
-       AvREAL_off(dstpad);

        assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
     } else {
        /* CvDEPTH() on our subroutine will be set to 0, so there's no need
        assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
     } else {
        /* CvDEPTH() on our subroutine will be set to 0, so there's no need


@@ -2142,17 +2259,16 @@ Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
        SV **names;
        SV **pad1a;
        AV *args;
        SV **names;
        SV **pad1a;
        AV *args;

-       /* look for it in the table first.
-          I *think* that it shouldn't be possible to find it there.
-          Well, except for how Perl_sv_compile_2op() "works" :-(   */
+       /* Look for it in the table first, as the padlist may have ended up
+          as an element of @DB::args (or theoretically even @_), so it may
+          may have been cloned already. */

        dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
 
        if (dstpad)
        dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
 
        if (dstpad)

-           return dstpad;
+           return (AV *)SvREFCNT_inc_simple_NN(dstpad);

 
        dstpad = newAV();
        ptr_table_store(PL_ptr_table, srcpad, dstpad);
 
        dstpad = newAV();
        ptr_table_store(PL_ptr_table, srcpad, dstpad);

-       AvREAL_off(dstpad);

        av_extend(dstpad, 1);
        AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
        names = AvARRAY(AvARRAY(dstpad)[0]);
        av_extend(dstpad, 1);
        AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
        names = AvARRAY(AvARRAY(dstpad)[0]);


@@ -2234,8 +2350,8 @@ Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4

- * indent-tabs-mode: t
+ * indent-tabs-mode: nil

  * End:
  *
  * End:
  *

- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:

  */
  */