Support named closures

diff --git a/cv.h b/cv.h
index b08cf5c..d94fb45 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -47,6 +47,7 @@ struct xpvcv {
 #define CVf_CLONED     0x02    /* a clone of one of those */
 #define CVf_ANON       0x04    /* CvGV() can't be trusted */
 #define CVf_OLDSTYLE   0x08
+#define CVf_UNIQUE     0x10    /* can't be cloned */
 
 #define CvCLONE(cv)            (CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)         (CvFLAGS(cv) |= CVf_CLONE)
@@ -63,3 +64,7 @@ struct xpvcv {
 #define CvOLDSTYLE(cv)         (CvFLAGS(cv) & CVf_OLDSTYLE)
 #define CvOLDSTYLE_on(cv)      (CvFLAGS(cv) |= CVf_OLDSTYLE)
 #define CvOLDSTYLE_off(cv)     (CvFLAGS(cv) &= ~CVf_OLDSTYLE)
+
+#define CvUNIQUE(cv)           (CvFLAGS(cv) & CVf_UNIQUE)
+#define CvUNIQUE_on(cv)                (CvFLAGS(cv) |= CVf_UNIQUE)
+#define CvUNIQUE_off(cv)       (CvFLAGS(cv) &= ~CVf_UNIQUE)

diff --git a/op.c b/op.c
index 3ab85b3..eecde67 100644 (file)
--- a/op.c
+++ b/op.c
@@ -195,7 +195,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 
                depth = CvDEPTH(cv);
                if (!depth) {
-                   if (newoff && (CvANON(cv) || CvGV(cv)))
+                   if (newoff && !CvUNIQUE(cv))
                        return 0; /* don't clone inactive sub's stack frame */
                    depth = 1;
                }
@@ -210,14 +210,16 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
                    SvNVX(sv) = (double)curcop->cop_seq;
                    SvIVX(sv) = 999999999;      /* A ref, intro immediately */
                    SvFLAGS(sv) |= SVf_FAKE;
-                   /* "It's closures all the way down." */
-                   CvCLONE_on(compcv);
-                   if (cv != startcv) {
-                       CV *bcv;
-                       for (bcv = startcv;
-                            bcv && bcv != cv && !CvCLONE(bcv);
-                            bcv = CvOUTSIDE(bcv))
-                           CvCLONE_on(bcv);
+                   if (!CvUNIQUE(cv)) {
+                       /* "It's closures all the way down." */
+                       CvCLONE_on(compcv);
+                       if (cv != startcv) {
+                           CV *bcv;
+                           for (bcv = startcv;
+                                bcv && bcv != cv && !CvCLONE(bcv);
+                                bcv = CvOUTSIDE(bcv))
+                               CvCLONE_on(bcv);
+                       }
                    }
                }
                av_store(comppad, newoff, SvREFCNT_inc(oldsv));
@@ -2798,11 +2800,13 @@ CV* cv;
                  cv,
                  (CvANON(cv) ? "ANON"
                   : (cv == main_cv) ? "MAIN"
+                  : CvUNIQUE(outside) ? "UNIQUE"
                   : CvGV(cv) ? GvNAME(CvGV(cv)) : "?mystery?"),
                  outside,
                  (!outside ? "null"
                   : CvANON(outside) ? "ANON"
                   : (outside == main_cv) ? "MAIN"
+                  : CvUNIQUE(outside) ? "UNIQUE"
                   : CvGV(outside) ? GvNAME(CvGV(outside)) : "?mystery?"));
 
     for (ix = 1; ix <= AvFILL(pad); ix++) {
@@ -2830,6 +2834,8 @@ CV* outside;
     AV* comppadlist;
     CV* cv;
 
+    assert(!CvUNIQUE(proto));
+
     ENTER;
     SAVESPTR(curpad);
     SAVESPTR(comppad);

diff --git a/perl.c b/perl.c
index d4c626c..aa6a1a4 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -562,6 +562,7 @@ setuid perl scripts securely.\n");
 
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     av_push(comppad, Nullsv);

diff --git a/pp.c b/pp.c
index e071ee3..db4276e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -248,8 +248,11 @@ PP(pp_rv2cv)
     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
     /* (But not in defined().) */
     CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
-
-    if (!cv)
+    if (cv) {
+       if (CvCLONE(cv))
+           cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+    }
+    else
        cv = (CV*)&sv_undef;
     SETs((SV*)cv);
     RETURN;

diff --git a/pp_ctl.c b/pp_ctl.c
index 332ae48..1350de4 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1926,7 +1926,7 @@ int gimme;
     SAVESPTR(compcv);
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
-    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     comppad_name = newAV();
@@ -1941,6 +1941,8 @@ int gimme;
     av_store(comppadlist, 0, (SV*)comppad_name);
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(compcv) = comppadlist;
+    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
     SAVEFREESV(compcv);
 
     /* make sure we compile in the right package */

diff --git a/pp_hot.c b/pp_hot.c
index 41ad9f4..9633d54 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1682,7 +1682,8 @@ PP(pp_entersub)
     register CV *cv;
     register CONTEXT *cx;
     I32 gimme;
-    I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
+    bool hasargs = (op->op_flags & OPf_STACKED) != 0;
+    bool may_clone = TRUE;
 
     if (!sv)
        DIE("Not a CODE reference");
@@ -1702,14 +1703,17 @@ PP(pp_entersub)
            break;
        }
        cv = (CV*)SvRV(sv);
-       if (SvTYPE(cv) == SVt_PVCV)
+       if (SvTYPE(cv) == SVt_PVCV) {
+           may_clone = FALSE;
            break;
+       }
        /* FALL THROUGH */
     case SVt_PVHV:
     case SVt_PVAV:
        DIE("Not a CODE reference");
     case SVt_PVCV:
        cv = (CV*)sv;
+       may_clone = FALSE;
        break;
     case SVt_PVGV:
        if (!(cv = GvCV((GV*)sv)))
@@ -1720,6 +1724,9 @@ PP(pp_entersub)
     ENTER;
     SAVETMPS;
 
+    if (may_clone && cv && CvCLONE(cv))
+       cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+
   retry:
     if (!cv)
        DIE("Not a CODE reference");