From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Wed, 2 Nov 2005 13:39:35 +0000 (+0000)
Subject: Add missing file from change 25953
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dfa6ead803b241e0d119ee4f98a1ac0b0acb4c23;p=p5sagit%2Fp5-mst-13.2.git

Add missing file from change 25953

p4raw-id: //depot/perl@25955
---

diff --git a/ext/List/Util/multicall.h b/ext/List/Util/multicall.h
new file mode 100644
index 0000000..eabb449
--- /dev/null
+++ b/ext/List/Util/multicall.h
@@ -0,0 +1,164 @@
+/*    multicall.h		(version 1.0)
+ *
+ * Implements a poor-man's MULTICALL interface for old versions
+ * of perl that don't offer a proper one. Intended to be compatible
+ * with 5.6.0 and later.
+ *
+ */
+
+#ifdef dMULTICALL
+#define REAL_MULTICALL
+#else
+#undef REAL_MULTICALL
+
+/* In versions of perl where MULTICALL is not defined (i.e. prior
+ * to 5.9.4), Perl_pad_push is not exported either. It also has
+ * an extra argument in older versions; certainly in the 5.8 series.
+ * So we redefine it here.
+ */
+
+#ifndef AVf_REIFY
+#  ifdef SVpav_REIFY
+#    define AVf_REIFY SVpav_REIFY
+#  else
+#    error Neither AVf_REIFY nor SVpav_REIFY is defined
+#  endif
+#endif
+
+#ifndef AvFLAGS
+#  define AvFLAGS SvFLAGS
+#endif
+
+static void
+multicall_pad_push(pTHX_ AV *padlist, int depth)
+{
+    if (depth <= AvFILLp(padlist))
+	return;
+
+    {
+	SV** const svp = AvARRAY(padlist);
+	AV* const newpad = newAV();
+	SV** const oldpad = AvARRAY(svp[depth-1]);
+	I32 ix = AvFILLp((AV*)svp[1]);
+        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) {
+		const char sigil = SvPVX(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 */
+		    SV *sv; 
+		    if (sigil == '@')
+			sv = (SV*)newAV();
+		    else if (sigil == '%')
+			sv = (SV*)newHV();
+		    else
+			sv = NEWSV(0, 0);
+		    av_store(newpad, ix, sv);
+		    SvPADMY_on(sv);
+		}
+	    }
+	    else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+		av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
+	    }
+	    else {
+		/* save temporaries on recursion? */
+		SV * const sv = NEWSV(0, 0);
+		av_store(newpad, ix, sv);
+		SvPADTMP_on(sv);
+	    }
+	}
+	av = newAV();
+	av_extend(av, 0);
+	av_store(newpad, 0, (SV*)av);
+	AvFLAGS(av) = AVf_REIFY;
+
+	av_store(padlist, depth, (SV*)newpad);
+	AvFILLp(padlist) = depth;
+    }
+}
+
+#define dMULTICALL \
+    SV **newsp;			/* set by POPBLOCK */			\
+    PERL_CONTEXT *cx;							\
+    CV *cv;								\
+    OP *multicall_cop;							\
+    bool multicall_oldcatch;						\
+    U8 hasargs = 0
+
+/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
+   return op is now stored on the cxstack. */
+#define HAS_RETSTACK (\
+  PERL_REVISION < 5 || \
+  (PERL_REVISION == 5 && PERL_VERSION < 9) || \
+  (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
+)
+
+
+/* PUSHSUB is defined so differently on different versions of perl
+ * that it's easier to define our own version than code for all the
+ * different possibilities.
+ */
+#if HAS_RETSTACK
+#  define PUSHSUB_RETSTACK(cx)
+#else
+#  define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
+#endif
+#undef PUSHSUB
+#define PUSHSUB(cx)                                                     \
+        cx->blk_sub.cv = cv;                                            \
+        cx->blk_sub.olddepth = CvDEPTH(cv);                             \
+        cx->blk_sub.hasargs = hasargs;                                  \
+        cx->blk_sub.lval = PL_op->op_private &                          \
+                              (OPpLVAL_INTRO|OPpENTERSUB_INARGS);	\
+	PUSHSUB_RETSTACK(cx)						\
+        if (!CvDEPTH(cv)) {                                             \
+            (void)SvREFCNT_inc(cv);                                     \
+            (void)SvREFCNT_inc(cv);                                     \
+            SAVEFREESV(cv);                                             \
+        }
+
+#define PUSH_MULTICALL \
+    STMT_START {							\
+	AV* padlist = CvPADLIST(cv);					\
+	ENTER;								\
+ 	multicall_oldcatch = CATCH_GET;					\
+	SAVESPTR(CvROOT(cv)->op_ppaddr);				\
+	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];			\
+	SAVETMPS; SAVEVPTR(PL_op);					\
+	CATCH_SET(TRUE);						\
+	PUSHSTACKi(PERLSI_SORT);					\
+	PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);				\
+	PUSHSUB(cx);							\
+	if (++CvDEPTH(cv) >= 2) {					\
+	    PERL_STACK_OVERFLOW_CHECK();				\
+	    multicall_pad_push(aTHX_ padlist, CvDEPTH(cv));		\
+	}								\
+	SAVECOMPPAD();							\
+	PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(cv)]);		\
+	PL_curpad = AvARRAY(PL_comppad);				\
+	multicall_cop = CvSTART(cv);					\
+    } STMT_END
+
+#define MULTICALL \
+    STMT_START {							\
+	PL_op = multicall_cop;						\
+	CALLRUNOPS(aTHX);						\
+    } STMT_END
+
+#define POP_MULTICALL \
+    STMT_START {							\
+	CvDEPTH(cv)--;							\
+	LEAVESUB(cv);							\
+	POPBLOCK(cx,PL_curpm);						\
+	POPSTACK;							\
+	CATCH_SET(multicall_oldcatch);					\
+	LEAVE;								\
+    } STMT_END
+
+#endif