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; \ 89 CV *multicall_cv; \ 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 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 & \ 117 (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ 118 PUSHSUB_RETSTACK(cx) \ 119 if (!CvDEPTH(the_cv)) { \ 120 (void)SvREFCNT_inc(the_cv); \ 121 (void)SvREFCNT_inc(the_cv); \ 122 SAVEFREESV(the_cv); \ 123 } 124 125 #define PUSH_MULTICALL(the_cv) \ 126 STMT_START { \ 127 CV *_nOnclAshIngNamE_ = the_cv; \ 128 AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ 129 multicall_cv = _nOnclAshIngNamE_; \ 130 ENTER; \ 131 multicall_oldcatch = CATCH_GET; \ 132 SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ 133 CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ 134 SAVETMPS; SAVEVPTR(PL_op); \ 135 CATCH_SET(TRUE); \ 136 PUSHSTACKi(PERLSI_SORT); \ 137 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ 138 MULTICALL_PUSHSUB(cx, multicall_cv); \ 139 if (++CvDEPTH(multicall_cv) >= 2) { \ 140 PERL_STACK_OVERFLOW_CHECK(); \ 141 multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \ 142 } \ 143 SAVECOMPPAD(); \ 144 PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \ 145 PL_curpad = AvARRAY(PL_comppad); \ 146 multicall_cop = CvSTART(multicall_cv); \ 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 { \ 157 CvDEPTH(multicall_cv)--; \ 158 LEAVESUB(multicall_cv); \ 159 POPBLOCK(cx,PL_curpm); \ 160 POPSTACK; \ 161 CATCH_SET(multicall_oldcatch); \ 162 LEAVE; \ 163 SPAGAIN; \ 164 } STMT_END 165 166 #endif 167