ext/List/Util/multicall.h

   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