-STATIC CV *su_cv_clone(pTHX_ CV *old_cv) {
-#define su_cv_clone(C) su_cv_clone(aTHX_ (C))
- CV *new_cv;
-
- /* Starting from commit b5c19bd7 (first made public with perl 5.9.0),
- * cv_clone() has an assert that checks whether CvDEPTH(CvOUTSIDE(proto)) > 0.
- * If this perl has DEBUGGING enabled, we have to fool cv_clone() with a
- * little dance. */
-#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
- I32 old_depth;
- CV *outside = CvOUTSIDE(old_cv);
-
- if (outside && CvCLONE(outside) && !CvCLONED(outside))
- outside = find_runcv(NULL);
- old_depth = CvDEPTH(outside);
- if (!old_depth)
- CvDEPTH(outside) = 1;
-#endif
-
- new_cv = cv_clone(old_cv);
-
-#if defined(DEBUGGING) && SU_HAS_PERL(5, 9, 0)
- CvDEPTH(outside) = old_depth;
-#endif
-
- /* Still from commit b5c19bd7, cv_clone() is no longer able to clone named
- * subs propery. With this commit, pad_findlex() stores the parent index of a
- * fake pad entry in the NV slot of the corresponding pad name SV, but only
- * for anonymous subs (since named subs aren't supposed to be cloned in pure
- * Perl land). To fix this, we just manually relink the new fake pad entries
- * to the new ones.
- * For some reason perl 5.8 crashes too without this, supposedly because of
- * other closure bugs. Hence we enable it everywhere. */
- if (!CvCLONE(old_cv)) {
- const AV *old_padname = (const AV *) AvARRAY(CvPADLIST(old_cv))[0];
- AV *old_pad = (AV *) AvARRAY(CvPADLIST(old_cv))[1];
- AV *new_pad = (AV *) AvARRAY(CvPADLIST(new_cv))[1];
- const SV **old_aryname = (const SV **) AvARRAY(old_padname);
- SV **old_ary = AvARRAY(old_pad);
- SV **new_ary = AvARRAY(new_pad);
- I32 fname = AvFILLp(old_padname);
- I32 fpad = AvFILLp(old_pad);
- I32 ix;
-
- for (ix = fpad; ix > 0; ix--) {
- const SV *namesv = (ix <= fname) ? old_aryname[ix] : NULL;
-
- if (namesv && namesv != &PL_sv_undef && SvFAKE(namesv)) {
- SvREFCNT_dec(new_ary[ix]);
- new_ary[ix] = SvREFCNT_inc(old_ary[ix]);
- }
- }
+#endif
+
+static CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
+#define su_cv_clone(P, G) su_cv_clone(aTHX_ (P), (G))
+ dVAR;
+ CV *cv;
+
+ cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+
+ CvFLAGS(cv) = CvFLAGS(proto);
+#ifdef CVf_CVGV_RC
+ CvFLAGS(cv) &= ~CVf_CVGV_RC;
+#endif
+ CvDEPTH(cv) = CvDEPTH(proto);
+#ifdef USE_ITHREADS
+ CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto) : savepv(CvFILE(proto));
+#else
+ CvFILE(cv) = CvFILE(proto);
+#endif
+
+ CvGV_set(cv, gv);
+#if SU_RELEASE && XSH_HAS_PERL_EXACT(5, 21, 4)
+ CvNAMED_off(cv);
+#endif
+ CvSTASH_set(cv, CvSTASH(proto));
+ /* Commit 4c74a7df, publicized with perl 5.13.3, began to add backrefs to
+ * stashes. CvSTASH_set() started to do it as well with commit c68d95645
+ * (which was part of perl 5.13.7). */
+#if XSH_HAS_PERL(5, 13, 3) && !XSH_HAS_PERL(5, 13, 7)
+ if (CvSTASH(proto))
+ Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
+#endif
+
+ if (CvISXSUB(proto)) {
+ CvXSUB(cv) = CvXSUB(proto);
+ CvXSUBANY(cv) = CvXSUBANY(proto);
+ } else {
+ OP_REFCNT_LOCK;
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
+ CvSTART(cv) = CvSTART(proto);
+ CvPADLIST(cv) = CvPADLIST(proto);
+ }
+ CvOUTSIDE(cv) = CvOUTSIDE(proto);
+#ifdef CVf_WEAKOUTSIDE
+ if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
+#endif
+ SvREFCNT_inc_simple_void(CvOUTSIDE(cv));
+#ifdef CvOUTSIDE_SEQ
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
+#endif
+
+ if (SvPOK(proto))
+ sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
+
+#ifdef CvCONST
+ if (CvCONST(cv))
+ CvCONST_off(cv);
+#endif
+
+ return cv;
+}
+
+#if SU_HAS_NEW_CXT
+
+/* this one-shot runops "loop" is designed to be called just before
+ * execution of the first op following an uplevel()'s entersub. It gets a
+ * chance to fix up the args as seen by caller(), before immediately
+ * falling through to the previous runops loop. Note that pp_entersub is
+ * called directly by call_sv() rather than being called from a runops
+ * loop.
+ */
+
+static int su_uplevel_runops_hook_entersub(pTHX) {
+ OP *op = PL_op;
+ dXSH_CXT;
+ su_uplevel_ud *sud = XSH_CXT.uplevel_storage.top;
+
+ /* Create a new array containing a copy of the original sub's call args,
+ * then stick it in PL_curpad[0] of the current running sub so that
+ * thay will be seen by caller().
+ */
+ assert(sud);
+ if (sud->argarray) {
+ AV *av = newAV();
+ AvREAL_off(av);
+ AvREIFY_on(av);
+ av_extend(av, AvMAX(sud->argarray));
+ AvFILLp(av) = AvFILLp(sud->argarray);
+ Copy(AvARRAY(sud->argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
+
+ /* should be referenced by PL_curpad[0] and *_ */
+ assert(SvREFCNT(PL_curpad[0]) > 1);
+ SvREFCNT_dec(PL_curpad[0]);
+
+ PL_curpad[0] = (SV*)av;
+ }
+
+ /* undo the temporary runops hook and fall through to a real runops loop. */
+ assert(sud->old_runops != su_uplevel_runops_hook_entersub);
+ PL_runops = sud->old_runops;
+ CALLRUNOPS(aTHX);
+ return 0;
+}
+
+static I32 su_uplevel_new(pTHX_ CV *callback, I32 cxix, I32 args) {
+ su_uplevel_ud *sud;
+ U8 *saved_cxtypes;
+ I32 i, ret;
+ I32 gimme;
+ CV *base_cv = cxstack[cxix].blk_sub.cv;
+ dSP;
+
+ assert(CxTYPE(&cxstack[cxix]) == CXt_SUB);
+
+ ENTER;
+
+ gimme = GIMME_V;
+
+ /* At this point SP points to the top arg.
+ * Shuffle the args down by one, eliminating the CV slot */
+ Move(SP - args + 1, SP - args, args, SV*);
+ SP--;
+ PUSHMARK(SP - args);
+ PUTBACK;
+
+ sud = su_uplevel_storage_new(cxix);
+
+ sud->cxix = cxix;
+ sud->callback = (CV*)SvREFCNT_inc_simple(callback);
+ sud->renamed = NULL;
+ sud->gap = cxstack_ix - cxix + 1;
+ sud->argarray = NULL;
+
+ Newx(saved_cxtypes, sud->gap, U8);
+ sud->cxtypes = saved_cxtypes;
+
+ SAVEDESTRUCTOR_X(su_uplevel_restore_new, sud);
+ SU_UPLEVEL_SAVE(curcop, cxstack[cxix].blk_oldcop);
+
+/* temporarily change the type of any contexts to NULL, so they're
+ * invisible to caller() etc. */
+ for (i = 0; i < sud->gap; i++) {
+ PERL_CONTEXT *cx = cxstack + cxix + i;
+ saved_cxtypes[i] = cx->cx_type; /* save type and flags */
+ XSH_D(su_debug_log("su_uplevel: i=%d cxix=%d type %-11s => %s\n",
+ i, cx-cxstack, SU_CX_TYPENAME(CxTYPE(cx)), SU_CX_TYPENAME(CXt_NULL)));
+ cx->cx_type = (CXt_NULL | CXp_SU_UPLEVEL_NULLED);
+ }
+
+ /* create a copy of the callback with a doctored name (as seen by
+ * caller). It shares the padlist with callback */
+ sud->renamed = su_cv_clone(callback, CvGV(base_cv));
+ sud->old_runops = PL_runops;
+
+ if (!CvISXSUB(sud->renamed) && CxHASARGS(&cxstack[cxix])) {
+ sud->argarray = (AV*)su_at_underscore(base_cv);
+ assert(PL_runops != su_uplevel_runops_hook_entersub);
+ /* set up a one-shot runops hook so that we can fake up the
+ * args as seen by caller() on return from pp_entersub */
+ PL_runops = su_uplevel_runops_hook_entersub;