Commit | Line | Data |
dfa6ead8 |
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 |
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 |
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 |
117 | (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ |
118 | PUSHSUB_RETSTACK(cx) \ |
82f35e8b |
119 | if (!CvDEPTH(the_cv)) { \ |
120 | (void)SvREFCNT_inc(the_cv); \ |
121 | (void)SvREFCNT_inc(the_cv); \ |
122 | SAVEFREESV(the_cv); \ |
dfa6ead8 |
123 | } |
124 | |
82f35e8b |
125 | #define PUSH_MULTICALL(the_cv) \ |
dfa6ead8 |
126 | STMT_START { \ |
82f35e8b |
127 | CV *_nOnclAshIngNamE_ = the_cv; \ |
128 | AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ |
129 | multicall_cv = _nOnclAshIngNamE_; \ |
dfa6ead8 |
130 | ENTER; \ |
131 | multicall_oldcatch = CATCH_GET; \ |
82f35e8b |
132 | SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ |
133 | CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ |
dfa6ead8 |
134 | SAVETMPS; SAVEVPTR(PL_op); \ |
135 | CATCH_SET(TRUE); \ |
136 | PUSHSTACKi(PERLSI_SORT); \ |
137 | PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ |
82f35e8b |
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 |
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 |
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 |
157 | CvDEPTH(multicall_cv)--; \ |
158 | LEAVESUB(multicall_cv); \ |
dfa6ead8 |
159 | POPBLOCK(cx,PL_curpm); \ |
160 | POPSTACK; \ |
161 | CATCH_SET(multicall_oldcatch); \ |
162 | LEAVE; \ |
163 | } STMT_END |
164 | |
165 | #endif |