[rt.cpan.org #61577] VMS doesn't support UNIX sockets

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index 5473b64..16aba15 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -333,6 +333,7 @@ Perl_cv_undef(pTHX_ CV *cv)
 {
     dVAR;
     const PADLIST *padlist = CvPADLIST(cv);
+    bool const slabbed = !!CvSLABBED(cv);
 
     PERL_ARGS_ASSERT_CV_UNDEF;
 
@@ -346,6 +347,7 @@ Perl_cv_undef(pTHX_ CV *cv)
     }
     CvFILE(cv) = NULL;
 
+    CvSLABBED_off(cv);
     if (!CvISXSUB(cv) && CvROOT(cv)) {
        if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
            Perl_croak(aTHX_ "Can't undef active subroutine");
@@ -353,11 +355,29 @@ Perl_cv_undef(pTHX_ CV *cv)
 
        PAD_SAVE_SETNULLPAD();
 
+#ifndef PL_OP_SLAB_ALLOC
+       if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
+#endif
        op_free(CvROOT(cv));
        CvROOT(cv) = NULL;
        CvSTART(cv) = NULL;
        LEAVE;
     }
+#ifndef PL_OP_SLAB_ALLOC
+    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
+#endif
     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */
     CvGV_set(cv, NULL);
 
@@ -470,6 +490,26 @@ Perl_cv_undef(pTHX_ CV *cv)
     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
 }
 
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+    const bool slabbed = !!CvSLABBED(cv);
+
+    PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+    if (!slabbed) return;
+
+    CvSLABBED_off(cv);
+
+    if      (CvROOT(cv))  OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+    else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+# ifdef DEBUGGING
+    else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+}
+#endif
+
 /*
 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
 
@@ -1404,7 +1444,9 @@ Perl_pad_block_start(pTHX_ int full)
 /*
 =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
 */
@@ -1883,29 +1925,37 @@ Perl_cv_clone(pTHX_ CV *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.
-     * Note that in general for formats, CvOUTSIDE != find_runcv; formats
-     * inside closures, however, only work if CvOUTSIDE == find_runcv.
      */
 
-    outside = CvOUTSIDE(proto);
-    if (!outside || (CvCLONE(outside) && ! CvCLONED(outside)))
+    if (SvTYPE(proto) == SVt_PVCV)
        outside = find_runcv(NULL);
-    if (SvTYPE(proto) == SVt_PVFM
-     && CvROOT(outside) != CvROOT(CvOUTSIDE(proto)))
+    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;
-    assert(CvPADLIST(outside));
+    assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
 
     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);
 
     CvFILE(cv)         = CvDYNFILE(proto) ? savepv(CvFILE(proto))
@@ -1933,18 +1983,20 @@ Perl_cv_clone(pTHX_ CV *proto)
 
     PL_curpad = AvARRAY(PL_comppad);
 
-    outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+    outpad = CvPADLIST(outside)
+       ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+       : NULL;
 
     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)];
-               /* 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 */
-               if (!sv || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
+               if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+                || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
                    Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
                                   "Variable \"%"SVf"\" is not available", namesv);
                    sv = NULL;