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