This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate CPAN release of version.pm 0.9905
[perl5.git] / cpan / Scalar-List-Utils / 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 *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