| | 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 |
https://perl5.git.perl.org / perl5.git / blame_incremental