This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix very minor spelling and pod markup in the last delta
[perl5.git] / cpan / Scalar-List-Utils / multicall.h
CommitLineData
dfa6ead8
RGS
1/* multicall.h (version 1.0)
2 *
3 * Implements a poor-man's MULTICALL interface for old versions
4 * of perl that don't offer a proper one. Intended to be compatible
5 * with 5.6.0 and later.
6 *
7 */
8
9#ifdef dMULTICALL
10#define REAL_MULTICALL
11#else
12#undef REAL_MULTICALL
13
14/* In versions of perl where MULTICALL is not defined (i.e. prior
15 * to 5.9.4), Perl_pad_push is not exported either. It also has
16 * an extra argument in older versions; certainly in the 5.8 series.
17 * So we redefine it here.
18 */
19
20#ifndef AVf_REIFY
21# ifdef SVpav_REIFY
22# define AVf_REIFY SVpav_REIFY
23# else
24# error Neither AVf_REIFY nor SVpav_REIFY is defined
25# endif
26#endif
27
28#ifndef AvFLAGS
29# define AvFLAGS SvFLAGS
30#endif
31
32static void
33multicall_pad_push(pTHX_ AV *padlist, int depth)
34{
35 if (depth <= AvFILLp(padlist))
36 return;
37
38 {
39 SV** const svp = AvARRAY(padlist);
40 AV* const newpad = newAV();
41 SV** const oldpad = AvARRAY(svp[depth-1]);
42 I32 ix = AvFILLp((AV*)svp[1]);
43 const I32 names_fill = AvFILLp((AV*)svp[0]);
44 SV** const names = AvARRAY(svp[0]);
45 AV *av;
46
47 for ( ;ix > 0; ix--) {
48 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
49 const char sigil = SvPVX(names[ix])[0];
50 if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
51 /* outer lexical or anon code */
52 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
53 }
54 else { /* our own lexical */
55 SV *sv;
56 if (sigil == '@')
57 sv = (SV*)newAV();
58 else if (sigil == '%')
59 sv = (SV*)newHV();
60 else
61 sv = NEWSV(0, 0);
62 av_store(newpad, ix, sv);
63 SvPADMY_on(sv);
64 }
65 }
66 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
67 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
68 }
69 else {
70 /* save temporaries on recursion? */
71 SV * const sv = NEWSV(0, 0);
72 av_store(newpad, ix, sv);
73 SvPADTMP_on(sv);
74 }
75 }
76 av = newAV();
77 av_extend(av, 0);
78 av_store(newpad, 0, (SV*)av);
79 AvFLAGS(av) = AVf_REIFY;
80
81 av_store(padlist, depth, (SV*)newpad);
82 AvFILLp(padlist) = depth;
83 }
84}
85
86#define dMULTICALL \
87 SV **newsp; /* set by POPBLOCK */ \
88 PERL_CONTEXT *cx; \
82f35e8b 89 CV *multicall_cv; \
dfa6ead8
RGS
90 OP *multicall_cop; \
91 bool multicall_oldcatch; \
92 U8 hasargs = 0
93
94/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
95 return op is now stored on the cxstack. */
96#define HAS_RETSTACK (\
97 PERL_REVISION < 5 || \
98 (PERL_REVISION == 5 && PERL_VERSION < 9) || \
99 (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
100)
101
102
103/* PUSHSUB is defined so differently on different versions of perl
104 * that it's easier to define our own version than code for all the
105 * different possibilities.
106 */
107#if HAS_RETSTACK
108# define PUSHSUB_RETSTACK(cx)
109#else
110# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
111#endif
82f35e8b
RH
112#define MULTICALL_PUSHSUB(cx, the_cv) \
113 cx->blk_sub.cv = the_cv; \
114 cx->blk_sub.olddepth = CvDEPTH(the_cv); \
115 cx->blk_sub.hasargs = hasargs; \
116 cx->blk_sub.lval = PL_op->op_private & \
dfa6ead8
RGS
117 (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \
118 PUSHSUB_RETSTACK(cx) \
82f35e8b
RH
119 if (!CvDEPTH(the_cv)) { \
120 (void)SvREFCNT_inc(the_cv); \
121 (void)SvREFCNT_inc(the_cv); \
122 SAVEFREESV(the_cv); \
dfa6ead8
RGS
123 }
124
82f35e8b 125#define PUSH_MULTICALL(the_cv) \
dfa6ead8 126 STMT_START { \
82f35e8b
RH
127 CV *_nOnclAshIngNamE_ = the_cv; \
128 AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
129 multicall_cv = _nOnclAshIngNamE_; \
dfa6ead8
RGS
130 ENTER; \
131 multicall_oldcatch = CATCH_GET; \
82f35e8b
RH
132 SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \
133 CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
dfa6ead8
RGS
134 SAVETMPS; SAVEVPTR(PL_op); \
135 CATCH_SET(TRUE); \
136 PUSHSTACKi(PERLSI_SORT); \
137 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \
82f35e8b
RH
138 MULTICALL_PUSHSUB(cx, multicall_cv); \
139 if (++CvDEPTH(multicall_cv) >= 2) { \
dfa6ead8 140 PERL_STACK_OVERFLOW_CHECK(); \
82f35e8b 141 multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
dfa6ead8
RGS
142 } \
143 SAVECOMPPAD(); \
82f35e8b 144 PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
dfa6ead8 145 PL_curpad = AvARRAY(PL_comppad); \
82f35e8b 146 multicall_cop = CvSTART(multicall_cv); \
dfa6ead8
RGS
147 } STMT_END
148
149#define MULTICALL \
150 STMT_START { \
151 PL_op = multicall_cop; \
152 CALLRUNOPS(aTHX); \
153 } STMT_END
154
155#define POP_MULTICALL \
156 STMT_START { \
82f35e8b
RH
157 CvDEPTH(multicall_cv)--; \
158 LEAVESUB(multicall_cv); \
dfa6ead8
RGS
159 POPBLOCK(cx,PL_curpm); \
160 POPSTACK; \
161 CATCH_SET(multicall_oldcatch); \
162 LEAVE; \
88517a29 163 SPAGAIN; \
dfa6ead8
RGS
164 } STMT_END
165
166#endif