| 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; \ |
| 89 | CV *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 | #undef PUSHSUB |
| 113 | #define PUSHSUB(cx) \ |
| 114 | cx->blk_sub.cv = cv; \ |
| 115 | cx->blk_sub.olddepth = CvDEPTH(cv); \ |
| 116 | cx->blk_sub.hasargs = hasargs; \ |
| 117 | cx->blk_sub.lval = PL_op->op_private & \ |
| 118 | (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ |
| 119 | PUSHSUB_RETSTACK(cx) \ |
| 120 | if (!CvDEPTH(cv)) { \ |
| 121 | (void)SvREFCNT_inc(cv); \ |
| 122 | (void)SvREFCNT_inc(cv); \ |
| 123 | SAVEFREESV(cv); \ |
| 124 | } |
| 125 | |
| 126 | #define PUSH_MULTICALL \ |
| 127 | STMT_START { \ |
| 128 | AV* padlist = CvPADLIST(cv); \ |
| 129 | ENTER; \ |
| 130 | multicall_oldcatch = CATCH_GET; \ |
| 131 | SAVESPTR(CvROOT(cv)->op_ppaddr); \ |
| 132 | CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ |
| 133 | SAVETMPS; SAVEVPTR(PL_op); \ |
| 134 | CATCH_SET(TRUE); \ |
| 135 | PUSHSTACKi(PERLSI_SORT); \ |
| 136 | PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ |
| 137 | PUSHSUB(cx); \ |
| 138 | if (++CvDEPTH(cv) >= 2) { \ |
| 139 | PERL_STACK_OVERFLOW_CHECK(); \ |
| 140 | multicall_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ |
| 141 | } \ |
| 142 | SAVECOMPPAD(); \ |
| 143 | PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(cv)]); \ |
| 144 | PL_curpad = AvARRAY(PL_comppad); \ |
| 145 | multicall_cop = CvSTART(cv); \ |
| 146 | } STMT_END |
| 147 | |
| 148 | #define MULTICALL \ |
| 149 | STMT_START { \ |
| 150 | PL_op = multicall_cop; \ |
| 151 | CALLRUNOPS(aTHX); \ |
| 152 | } STMT_END |
| 153 | |
| 154 | #define POP_MULTICALL \ |
| 155 | STMT_START { \ |
| 156 | CvDEPTH(cv)--; \ |
| 157 | LEAVESUB(cv); \ |
| 158 | POPBLOCK(cx,PL_curpm); \ |
| 159 | POPSTACK; \ |
| 160 | CATCH_SET(multicall_oldcatch); \ |
| 161 | LEAVE; \ |
| 162 | } STMT_END |
| 163 | |
| 164 | #endif |
projects / p5sagit/p5-mst-13.2.git / blame