Commit | Line | Data |
---|---|---|
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 | ||
32 | static void | |
33 | multicall_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 |