1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
/* 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 *multicall_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
#define MULTICALL_PUSHSUB(cx, the_cv) \
cx->blk_sub.cv = the_cv; \
cx->blk_sub.olddepth = CvDEPTH(the_cv); \
cx->blk_sub.hasargs = hasargs; \
cx->blk_sub.lval = PL_op->op_private & \
(OPpLVAL_INTRO|OPpENTERSUB_INARGS); \
PUSHSUB_RETSTACK(cx) \
if (!CvDEPTH(the_cv)) { \
(void)SvREFCNT_inc(the_cv); \
(void)SvREFCNT_inc(the_cv); \
SAVEFREESV(the_cv); \
}
#define PUSH_MULTICALL(the_cv) \
STMT_START { \
CV *_nOnclAshIngNamE_ = the_cv; \
AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
multicall_cv = _nOnclAshIngNamE_; \
ENTER; \
multicall_oldcatch = CATCH_GET; \
SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \
CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
SAVETMPS; SAVEVPTR(PL_op); \
CATCH_SET(TRUE); \
PUSHSTACKi(PERLSI_SORT); \
PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \
MULTICALL_PUSHSUB(cx, multicall_cv); \
if (++CvDEPTH(multicall_cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
} \
SAVECOMPPAD(); \
PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
PL_curpad = AvARRAY(PL_comppad); \
multicall_cop = CvSTART(multicall_cv); \
} STMT_END
#define MULTICALL \
STMT_START { \
PL_op = multicall_cop; \
CALLRUNOPS(aTHX); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
CvDEPTH(multicall_cv)--; \
LEAVESUB(multicall_cv); \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
LEAVE; \
SPAGAIN; \
} STMT_END
#endif
|
