Mention in apidocs that av_push takes ownership of a refcount
[perl.git] / cop.h
1 /*    cop.h
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
10  * and OP_SETSTATE that (loosely speaking) are separate statements.
11  * They hold information important for lexical state and error reporting.
12  * At run time, PL_curcop is set to point to the most recently executed cop,
13  * and thus can be used to determine our current state.
14  */
15
16 /* A jmpenv packages the state required to perform a proper non-local jump.
17  * Note that there is a start_env initialized when perl starts, and top_env
18  * points to this initially, so top_env should always be non-null.
19  *
20  * Existence of a non-null top_env->je_prev implies it is valid to call
21  * longjmp() at that runlevel (we make sure start_env.je_prev is always
22  * null to ensure this).
23  *
24  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
25  * establish a local jmpenv to handle exception traps.  Care must be taken
26  * to restore the previous value of je_mustcatch before exiting the
27  * stack frame iff JMPENV_PUSH was not called in that stack frame.
28  * GSAR 97-03-27
29  */
30
31 struct jmpenv {
32     struct jmpenv *     je_prev;
33     Sigjmp_buf          je_buf;         /* only for use if !je_throw */
34     int                 je_ret;         /* last exception thrown */
35     bool                je_mustcatch;   /* need to call longjmp()? */
36 };
37
38 typedef struct jmpenv JMPENV;
39
40 #ifdef OP_IN_REGISTER
41 #define OP_REG_TO_MEM   PL_opsave = op
42 #define OP_MEM_TO_REG   op = PL_opsave
43 #else
44 #define OP_REG_TO_MEM   NOOP
45 #define OP_MEM_TO_REG   NOOP
46 #endif
47
48 /*
49  * How to build the first jmpenv.
50  *
51  * top_env needs to be non-zero. It points to an area
52  * in which longjmp() stuff is stored, as C callstack
53  * info there at least is thread specific this has to
54  * be per-thread. Otherwise a 'die' in a thread gives
55  * that thread the C stack of last thread to do an eval {}!
56  */
57
58 #define JMPENV_BOOTSTRAP \
59     STMT_START {                                \
60         Zero(&PL_start_env, 1, JMPENV);         \
61         PL_start_env.je_ret = -1;               \
62         PL_start_env.je_mustcatch = TRUE;       \
63         PL_top_env = &PL_start_env;             \
64     } STMT_END
65
66 /*
67  *   PERL_FLEXIBLE_EXCEPTIONS
68  * 
69  * All the flexible exceptions code has been removed.
70  * See the following threads for details:
71  *
72  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
73  * 
74  * Joshua's original patches (which weren't applied) and discussion:
75  * 
76  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
77  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
78  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
79  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
80  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
81  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
82  * 
83  * Chip's reworked patch and discussion:
84  * 
85  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
86  * 
87  * The flaw in these patches (which went unnoticed at the time) was
88  * that they moved some code that could potentially die() out of the
89  * region protected by the setjmp()s.  This caused exceptions within
90  * END blocks and such to not be handled by the correct setjmp().
91  * 
92  * The original patches that introduces flexible exceptions were:
93  *
94  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=3386
95  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=5162
96  */
97
98 #define dJMPENV         JMPENV cur_env
99
100 #define JMPENV_PUSH(v) \
101     STMT_START {                                                        \
102         DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n",     \
103                          (void*)&cur_env, (void*)PL_top_env));                  \
104         cur_env.je_prev = PL_top_env;                                   \
105         OP_REG_TO_MEM;                                                  \
106         cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK);              \
107         OP_MEM_TO_REG;                                                  \
108         PL_top_env = &cur_env;                                          \
109         cur_env.je_mustcatch = FALSE;                                   \
110         (v) = cur_env.je_ret;                                           \
111     } STMT_END
112
113 #define JMPENV_POP \
114     STMT_START {                                                        \
115         DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n",    \
116                          (void*)PL_top_env, (void*)cur_env.je_prev));                   \
117         PL_top_env = cur_env.je_prev;                                   \
118     } STMT_END
119
120 #define JMPENV_JUMP(v) \
121     STMT_START {                                                \
122         OP_REG_TO_MEM;                                          \
123         if (PL_top_env->je_prev)                                \
124             PerlProc_longjmp(PL_top_env->je_buf, (v));          \
125         if ((v) == 2)                                           \
126             PerlProc_exit(STATUS_EXIT);                         \
127         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
128         PerlProc_exit(1);                                       \
129     } STMT_END
130
131 #define CATCH_GET               (PL_top_env->je_mustcatch)
132 #define CATCH_SET(v)            (PL_top_env->je_mustcatch = (v))
133
134
135 #include "mydtrace.h"
136
137 struct cop {
138     BASEOP
139     /* On LP64 putting this here takes advantage of the fact that BASEOP isn't
140        an exact multiple of 8 bytes to save structure padding.  */
141     line_t      cop_line;       /* line # of this command */
142     char *      cop_label;      /* label for this construct */
143 #ifdef USE_ITHREADS
144     char *      cop_stashpv;    /* package line was compiled in */
145     char *      cop_file;       /* file name the following line # is from */
146 #else
147     HV *        cop_stash;      /* package line was compiled in */
148     GV *        cop_filegv;     /* file the following line # is from */
149 #endif
150     U32         cop_hints;      /* hints bits from pragmata */
151     U32         cop_seq;        /* parse sequence number */
152     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
153     STRLEN *    cop_warnings;   /* lexical warnings bitmask */
154     /* compile time state of %^H.  See the comment in op.c for how this is
155        used to recreate a hash to return from caller.  */
156     struct refcounted_he * cop_hints_hash;
157 };
158
159 #ifdef USE_ITHREADS
160 #  define CopFILE(c)            ((c)->cop_file)
161 #  define CopFILEGV(c)          (CopFILE(c) \
162                                  ? gv_fetchfile(CopFILE(c)) : NULL)
163                                  
164 #  ifdef NETWARE
165 #    define CopFILE_set(c,pv)   ((c)->cop_file = savepv(pv))
166 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savepv((pv),(l)))
167 #  else
168 #    define CopFILE_set(c,pv)   ((c)->cop_file = savesharedpv(pv))
169 #    define CopFILE_setn(c,pv,l)  ((c)->cop_file = savesharedpvn((pv),(l)))
170 #  endif
171
172 #  define CopFILESV(c)          (CopFILE(c) \
173                                  ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
174 #  define CopFILEAV(c)          (CopFILE(c) \
175                                  ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
176 #  ifdef DEBUGGING
177 #    define CopFILEAVx(c)       (assert(CopFILE(c)), \
178                                    GvAV(gv_fetchfile(CopFILE(c))))
179 #  else
180 #    define CopFILEAVx(c)       (GvAV(gv_fetchfile(CopFILE(c))))
181 #  endif
182 #  define CopSTASHPV(c)         ((c)->cop_stashpv)
183
184 #  ifdef NETWARE
185 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
186 #  else
187 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = savesharedpv(pv))
188 #  endif
189
190 #  define CopSTASH(c)           (CopSTASHPV(c) \
191                                  ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
192 #  define CopSTASH_set(c,hv)    CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
193 #  define CopSTASH_eq(c,hv)     ((hv) && stashpv_hvname_match(c,hv))
194 #  define CopLABEL(c)           ((c)->cop_label)
195 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
196 #  ifdef NETWARE
197 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
198 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
199 #    define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
200 #    define CopLABEL_alloc(pv)  ((pv)?savepv(pv):NULL)
201 #  else
202 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
203 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
204 #    define CopLABEL_free(c)    (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
205 #    define CopLABEL_alloc(pv)  ((pv)?savesharedpv(pv):NULL)
206 #  endif
207 #else
208 #  define CopFILEGV(c)          ((c)->cop_filegv)
209 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
210 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
211 #  define CopFILE_setn(c,pv,l)  CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
212 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
213 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
214 #  ifdef DEBUGGING
215 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
216 #  else
217 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
218 # endif
219 #  define CopFILE(c)            (CopFILEGV(c) && GvSV(CopFILEGV(c)) \
220                                     ? SvPVX(GvSV(CopFILEGV(c))) : NULL)
221 #  define CopSTASH(c)           ((c)->cop_stash)
222 #  define CopLABEL(c)           ((c)->cop_label)
223 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
224 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
225    /* cop_stash is not refcounted */
226 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
227 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
228 #  define CopLABEL_alloc(pv)    ((pv)?savepv(pv):NULL)
229 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
230 #  define CopSTASH_free(c)      
231 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
232 #  define CopLABEL_free(c)      (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
233
234 #endif /* USE_ITHREADS */
235
236 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
237 #define CopLINE(c)              ((c)->cop_line)
238 #define CopLINE_inc(c)          (++CopLINE(c))
239 #define CopLINE_dec(c)          (--CopLINE(c))
240 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
241
242 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
243 #ifdef MACOS_TRADITIONAL
244 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
245 #else
246 #  define OutCopFILE(c) CopFILE(c)
247 #endif
248
249 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
250    HINT_ARYBASE is set to indicate this.
251    Setting it is ineficient due to the need to create 2 mortal SVs, but as
252    using $[ is highly discouraged, no sane Perl code will be using it.  */
253 #define CopARYBASE_get(c)       \
254         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
255          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
256                                          "$[", 2, 0, 0))                \
257          : 0)
258 #define CopARYBASE_set(c, b) STMT_START { \
259         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
260             (c)->cop_hints |= HINT_ARYBASE;                             \
261             if ((c) == &PL_compiling)                                   \
262                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
263             (c)->cop_hints_hash                                         \
264                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
265                                         newSVpvs_flags("$[", SVs_TEMP), \
266                                         sv_2mortal(newSViv(b)));        \
267         }                                                               \
268     } STMT_END
269
270 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
271 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
272 #define CopHINTS_set(c, h)      STMT_START {                            \
273                                     (c)->cop_hints = (h);               \
274                                 } STMT_END
275
276 /*
277  * Here we have some enormously heavy (or at least ponderous) wizardry.
278  */
279
280 /* subroutine context */
281 struct block_sub {
282     CV *        cv;
283     GV *        gv;
284     GV *        dfoutgv;
285     AV *        savearray;
286     AV *        argarray;
287     I32         olddepth;
288     U8          hasargs;
289     U8          lval;           /* XXX merge lval and hasargs? */
290     PAD         *oldcomppad;
291     OP *        retop;  /* op to execute on exit from sub */
292 };
293
294 /* base for the next two macros. Don't use directly.
295  * Note that the refcnt of the cv is incremented twice;  The CX one is
296  * decremented by LEAVESUB, the other by LEAVE. */
297
298 #define PUSHSUB_BASE(cx)                                                \
299         ENTRY_PROBE(GvENAME(CvGV(cv)),                                  \
300                 CopFILE((const COP *)CvSTART(cv)),                      \
301                 CopLINE((const COP *)CvSTART(cv)));                     \
302                                                                         \
303         cx->blk_sub.cv = cv;                                            \
304         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
305         cx->blk_sub.hasargs = hasargs;                                  \
306         cx->blk_sub.retop = NULL;                                       \
307         if (!CvDEPTH(cv)) {                                             \
308             SvREFCNT_inc_simple_void_NN(cv);                            \
309             SvREFCNT_inc_simple_void_NN(cv);                            \
310             SAVEFREESV(cv);                                             \
311         }
312
313
314 #define PUSHSUB(cx)                                                     \
315         PUSHSUB_BASE(cx)                                                \
316         cx->blk_sub.lval = PL_op->op_private &                          \
317                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
318
319 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
320 #define PUSHSUB_DB(cx)                                                  \
321         PUSHSUB_BASE(cx)                                                \
322         cx->blk_sub.lval = 0;
323
324
325 #define PUSHFORMAT(cx)                                                  \
326         cx->blk_sub.cv = cv;                                            \
327         cx->blk_sub.gv = gv;                                            \
328         cx->blk_sub.retop = NULL;                                       \
329         cx->blk_sub.hasargs = 0;                                        \
330         cx->blk_sub.dfoutgv = PL_defoutgv;                              \
331         SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
332
333 #define POP_SAVEARRAY()                                         \
334     STMT_START {                                                        \
335         SvREFCNT_dec(GvAV(PL_defgv));                                   \
336         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
337     } STMT_END
338
339 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
340  * leave any (a fast av_clear(ary), basically) */
341 #define CLEAR_ARGARRAY(ary) \
342     STMT_START {                                                        \
343         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
344         AvARRAY(ary) = AvALLOC(ary);                                    \
345         AvFILLp(ary) = -1;                                              \
346     } STMT_END
347
348 #define POPSUB(cx,sv)                                                   \
349     STMT_START {                                                        \
350         RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)),          \
351                 CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)),      \
352                 CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)));     \
353                                                                         \
354         if (CxHASARGS(cx)) {                                            \
355             POP_SAVEARRAY();                                            \
356             /* abandon @_ if it got reified */                          \
357             if (AvREAL(cx->blk_sub.argarray)) {                         \
358                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
359                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
360                 cx->blk_sub.argarray = newAV();                         \
361                 av_extend(cx->blk_sub.argarray, fill);                  \
362                 AvREIFY_only(cx->blk_sub.argarray);                     \
363                 CX_CURPAD_SV(cx->blk_sub, 0) = MUTABLE_SV(cx->blk_sub.argarray); \
364             }                                                           \
365             else {                                                      \
366                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
367             }                                                           \
368         }                                                               \
369         sv = MUTABLE_SV(cx->blk_sub.cv);                                \
370         if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth))      \
371             sv = NULL;                                          \
372     } STMT_END
373
374 #define LEAVESUB(sv)                                                    \
375     STMT_START {                                                        \
376         if (sv)                                                         \
377             SvREFCNT_dec(sv);                                           \
378     } STMT_END
379
380 #define POPFORMAT(cx)                                                   \
381         setdefout(cx->blk_sub.dfoutgv);                                 \
382         SvREFCNT_dec(cx->blk_sub.dfoutgv);
383
384 /* eval context */
385 struct block_eval {
386     U8          old_in_eval;
387     U16         old_op_type;
388     SV *        old_namesv;
389     OP *        old_eval_root;
390     SV *        cur_text;
391     CV *        cv;
392     OP *        retop;  /* op to execute on exit from eval */
393     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
394 };
395
396 #define CxOLD_IN_EVAL(cx)       (0 + (cx)->blk_eval.old_in_eval)
397 #define CxOLD_OP_TYPE(cx)       (0 + (cx)->blk_eval.old_op_type)
398
399 #define PUSHEVAL(cx,n,fgv)                                              \
400     STMT_START {                                                        \
401         cx->blk_eval.old_in_eval = PL_in_eval;                          \
402         cx->blk_eval.old_op_type = PL_op->op_type;                      \
403         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
404         cx->blk_eval.old_eval_root = PL_eval_root;                      \
405         cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;  \
406         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
407         cx->blk_eval.retop = NULL;                                      \
408         cx->blk_eval.cur_top_env = PL_top_env;                          \
409     } STMT_END
410
411 #define POPEVAL(cx)                                                     \
412     STMT_START {                                                        \
413         PL_in_eval = CxOLD_IN_EVAL(cx);                                 \
414         optype = CxOLD_OP_TYPE(cx);                                     \
415         PL_eval_root = cx->blk_eval.old_eval_root;                      \
416         if (cx->blk_eval.old_namesv)                                    \
417             sv_2mortal(cx->blk_eval.old_namesv);                        \
418     } STMT_END
419
420 /* loop context */
421 struct block_loop {
422     char *      label;
423     I32         resetsp;
424     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
425     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
426         why next_op is conditionally defined below.)  */
427 #ifdef USE_ITHREADS
428     void *      iterdata;
429     PAD         *oldcomppad;
430 #else
431     OP *        next_op;
432     SV **       itervar;
433 #endif
434     /* Eliminated in blead by change 33080, but for binary compatibility
435        reasons we can't remove it from the middle of a struct in a maintenance
436        release, so it gets to stay, and be set to NULL.  */
437     SV *        itersave;
438     /* (from inspection of source code) for a .. range of strings this is the
439        current string.  */
440     SV *        iterlval;
441     /* (from inspection of source code) for a foreach loop this is the array
442        being iterated over. For a .. range of numbers it's the current value.
443        A check is often made on the SvTYPE of iterary to determine whether
444        we are iterating over an array or a range. (numbers or strings)  */
445     AV *        iterary;
446     IV          iterix;
447     /* (from inspection of source code) for a .. range of numbers this is the
448        maximum value.  */
449     IV          itermax;
450 };
451 /* It might be possible to squeeze this structure further. As best I can tell
452    itermax and iterlval are never used at the same time, so it might be possible
453    to make them into a union. However, I'm not confident that there are enough
454    flag bits/NULLable pointers in this structure alone to encode which is
455    active. There is, however, U8 of space free in struct block, which could be
456    used. Right now it may not be worth squeezing this structure further, as it's
457    the largest part of struct block, and currently struct block is 64 bytes on
458    an ILP32 system, which will give good cache alignment.
459 */
460
461 #ifdef USE_ITHREADS
462 #  define CxITERVAR(c)                                                  \
463         ((c)->blk_loop.iterdata                                         \
464          ? (CxPADLOOP(cx)                                               \
465             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
466                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
467             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
468          : (SV**)NULL)
469 #  define CX_ITERDATA_SET(cx,idata)                                     \
470         CX_CURPAD_SAVE(cx->blk_loop);                                   \
471         cx->blk_loop.itersave = NULL;                                   \
472         cx->blk_loop.iterdata = (idata);
473 #else
474 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
475 #  define CX_ITERDATA_SET(cx,ivar)                                      \
476         cx->blk_loop.itersave = NULL;                                   \
477         cx->blk_loop.itervar = (SV**)(ivar);
478 #endif
479 #define CxLABEL(c)      (0 + (c)->blk_loop.label)
480 #define CxHASARGS(c)    (0 + (c)->blk_sub.hasargs)
481 #define CxLVAL(c)       (0 + (c)->blk_sub.lval)
482
483 #ifdef USE_ITHREADS
484 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
485 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
486 #else
487 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
488 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
489 #endif
490
491 #define PUSHLOOP(cx, dat, s)                                            \
492         cx->blk_loop.label = PL_curcop->cop_label;                      \
493         cx->blk_loop.resetsp = s - PL_stack_base;                       \
494         cx->blk_loop.my_op = cLOOP;                                     \
495         PUSHLOOP_OP_NEXT;                                               \
496         cx->blk_loop.iterlval = NULL;                                   \
497         cx->blk_loop.iterary = NULL;                                    \
498         cx->blk_loop.iterix = -1;                                       \
499         CX_ITERDATA_SET(cx,dat);
500
501 #define POPLOOP(cx)                                                     \
502         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
503         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
504             SvREFCNT_dec(cx->blk_loop.iterary);
505
506 /* given/when context */
507 struct block_givwhen {
508         OP *leave_op;
509 };
510
511 #define PUSHGIVEN(cx)                                                   \
512         cx->blk_givwhen.leave_op = cLOGOP->op_other;
513
514 #define PUSHWHEN PUSHGIVEN
515
516 /* context common to subroutines, evals and loops */
517 struct block {
518     U16         blku_type;      /* what kind of context this is */
519     U8          blku_gimme;     /* is this block running in list context? */
520     U8          blku_spare;     /* Padding to match with struct subst */
521     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
522     COP *       blku_oldcop;    /* old curcop pointer */
523     I32         blku_oldmarksp; /* mark stack index */
524     I32         blku_oldscopesp;        /* scope stack index */
525     PMOP *      blku_oldpm;     /* values of pattern match vars */
526
527     union {
528         struct block_sub        blku_sub;
529         struct block_eval       blku_eval;
530         struct block_loop       blku_loop;
531         struct block_givwhen    blku_givwhen;
532     } blk_u;
533 };
534 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
535 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
536 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
537 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
538 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
539 #define blk_gimme       cx_u.cx_blk.blku_gimme
540 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
541 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
542 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
543 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
544
545 /* Enter a block. */
546 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
547         cx->cx_type             = t,                                    \
548         cx->blk_oldsp           = sp - PL_stack_base,                   \
549         cx->blk_oldcop          = PL_curcop,                            \
550         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
551         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
552         cx->blk_oldpm           = PL_curpm,                             \
553         cx->blk_gimme           = (U8)gimme;                            \
554         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
555                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
556
557 /* Exit a block (RETURN and LAST). */
558 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
559         newsp            = PL_stack_base + cx->blk_oldsp,               \
560         PL_curcop        = cx->blk_oldcop,                              \
561         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
562         PL_scopestack_ix = cx->blk_oldscopesp,                          \
563         pm               = cx->blk_oldpm,                               \
564         gimme            = cx->blk_gimme;                               \
565         DEBUG_SCOPE("POPBLOCK");                                        \
566         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
567                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
568
569 /* Continue a block elsewhere (NEXT and REDO). */
570 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
571         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
572         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
573         PL_scopestack_ix = cx->blk_oldscopesp,                          \
574         PL_curpm         = cx->blk_oldpm;                               \
575         DEBUG_SCOPE("TOPBLOCK");
576
577 /* substitution context */
578 struct subst {
579     U16         sbu_type;       /* what kind of context this is */
580     U8          sbu_once;       /* Actually both booleans, but U8 to matches */
581     U8          sbu_rxtainted;  /* struct block */
582     I32         sbu_iters;
583     I32         sbu_maxiters;
584     I32         sbu_rflags;
585     I32         sbu_oldsave;
586     char *      sbu_orig;
587     SV *        sbu_dstr;
588     SV *        sbu_targ;
589     char *      sbu_s;
590     char *      sbu_m;
591     char *      sbu_strend;
592     void *      sbu_rxres;
593     REGEXP *    sbu_rx;
594 };
595 #define sb_iters        cx_u.cx_subst.sbu_iters
596 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
597 #define sb_rflags       cx_u.cx_subst.sbu_rflags
598 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
599 #define sb_once         cx_u.cx_subst.sbu_once
600 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
601 #define sb_orig         cx_u.cx_subst.sbu_orig
602 #define sb_dstr         cx_u.cx_subst.sbu_dstr
603 #define sb_targ         cx_u.cx_subst.sbu_targ
604 #define sb_s            cx_u.cx_subst.sbu_s
605 #define sb_m            cx_u.cx_subst.sbu_m
606 #define sb_strend       cx_u.cx_subst.sbu_strend
607 #define sb_rxres        cx_u.cx_subst.sbu_rxres
608 #define sb_rx           cx_u.cx_subst.sbu_rx
609
610 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
611         cx->sb_iters            = iters,                                \
612         cx->sb_maxiters         = maxiters,                             \
613         cx->sb_rflags           = r_flags,                              \
614         cx->sb_oldsave          = oldsave,                              \
615         cx->sb_once             = once,                                 \
616         cx->sb_rxtainted        = rxtainted,                            \
617         cx->sb_orig             = orig,                                 \
618         cx->sb_dstr             = dstr,                                 \
619         cx->sb_targ             = targ,                                 \
620         cx->sb_s                = s,                                    \
621         cx->sb_m                = m,                                    \
622         cx->sb_strend           = strend,                               \
623         cx->sb_rxres            = NULL,                                 \
624         cx->sb_rx               = rx,                                   \
625         cx->cx_type             = CXt_SUBST;                            \
626         rxres_save(&cx->sb_rxres, rx);                                  \
627         (void)ReREFCNT_inc(rx)
628
629 #define CxONCE(cx)              (0 + cx->sb_once)
630
631 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
632         rxres_free(&cx->sb_rxres);                                      \
633         ReREFCNT_dec(cx->sb_rx)
634
635 struct context {
636     union {
637         struct block    cx_blk;
638         struct subst    cx_subst;
639     } cx_u;
640 };
641 #define cx_type cx_u.cx_subst.sbu_type
642
643 #define CXTYPEMASK      0xff
644 #define CXt_NULL        0
645 #define CXt_SUB         1
646 #define CXt_EVAL        2
647 #define CXt_LOOP        3
648 #define CXt_SUBST       4
649 #define CXt_BLOCK       5
650 #define CXt_FORMAT      6
651 #define CXt_GIVEN       7
652 #define CXt_WHEN        8
653
654 /* private flags for CXt_SUB and CXt_NULL */
655 #define CXp_MULTICALL   0x00000400      /* part of a multicall (so don't
656                                            tear down context on exit). */ 
657
658 /* private flags for CXt_EVAL */
659 #define CXp_REAL        0x00000100      /* truly eval'', not a lookalike */
660 #define CXp_TRYBLOCK    0x00000200      /* eval{}, not eval'' or similar */
661
662 /* private flags for CXt_LOOP */
663 #define CXp_FOREACH     0x00000200      /* a foreach loop */
664 #define CXp_FOR_DEF     0x00000400      /* foreach using $_ */
665 #ifdef USE_ITHREADS
666 #  define CXp_PADVAR    0x00000100      /* itervar lives on pad, iterdata
667                                            has pad offset; if not set,
668                                            iterdata holds GV* */
669 #  define CxPADLOOP(c)  (((c)->cx_type & (CXt_LOOP|CXp_PADVAR))         \
670                          == (CXt_LOOP|CXp_PADVAR))
671 #endif
672
673 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
674 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
675                          == CXp_MULTICALL)
676 #define CxREALEVAL(c)   (((c)->cx_type & (CXTYPEMASK|CXp_REAL))         \
677                          == (CXt_EVAL|CXp_REAL))
678 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK))     \
679                          == (CXt_EVAL|CXp_TRYBLOCK))
680 #define CxFOREACH(c)    (((c)->cx_type & (CXTYPEMASK|CXp_FOREACH))      \
681                          == (CXt_LOOP|CXp_FOREACH))
682 #define CxFOREACHDEF(c) (((c)->cx_type & (CXTYPEMASK|CXp_FOREACH|CXp_FOR_DEF))\
683                          == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
684
685 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
686
687 /* 
688 =head1 "Gimme" Values
689 */
690
691 /*
692 =for apidoc AmU||G_SCALAR
693 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
694 L<perlcall>.
695
696 =for apidoc AmU||G_ARRAY
697 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
698 L<perlcall>.
699
700 =for apidoc AmU||G_VOID
701 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
702
703 =for apidoc AmU||G_DISCARD
704 Indicates that arguments returned from a callback should be discarded.  See
705 L<perlcall>.
706
707 =for apidoc AmU||G_EVAL
708
709 Used to force a Perl C<eval> wrapper around a callback.  See
710 L<perlcall>.
711
712 =for apidoc AmU||G_NOARGS
713
714 Indicates that no arguments are being sent to a callback.  See
715 L<perlcall>.
716
717 =cut
718 */
719
720 #define G_SCALAR        0
721 #define G_ARRAY         1
722 #define G_VOID          128     /* skip this bit when adding flags below */
723 #define G_WANT          (128|1)
724
725 /* extra flags for Perl_call_* routines */
726 #define G_DISCARD       2       /* Call FREETMPS.
727                                    Don't change this without consulting the
728                                    hash actions codes defined in hv.h */
729 #define G_EVAL          4       /* Assume eval {} around subroutine call. */
730 #define G_NOARGS        8       /* Don't construct a @_ array. */
731 #define G_KEEPERR      16       /* Append errors to $@, don't overwrite it */
732 #define G_NODEBUG      32       /* Disable debugging at toplevel.  */
733 #define G_METHOD       64       /* Calling method. */
734 #define G_FAKINGEVAL  256       /* Faking an eval context for call_sv or
735                                    fold_constants. */
736
737 /* flag bits for PL_in_eval */
738 #define EVAL_NULL       0       /* not in an eval */
739 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
740 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
741 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
742 #define EVAL_INREQUIRE  8       /* The code is being required. */
743
744 /* Support for switching (stack and block) contexts.
745  * This ensures magic doesn't invalidate local stack and cx pointers.
746  */
747
748 #define PERLSI_UNKNOWN          -1
749 #define PERLSI_UNDEF            0
750 #define PERLSI_MAIN             1
751 #define PERLSI_MAGIC            2
752 #define PERLSI_SORT             3
753 #define PERLSI_SIGNAL           4
754 #define PERLSI_OVERLOAD         5
755 #define PERLSI_DESTROY          6
756 #define PERLSI_WARNHOOK         7
757 #define PERLSI_DIEHOOK          8
758 #define PERLSI_REQUIRE          9
759
760 struct stackinfo {
761     AV *                si_stack;       /* stack for current runlevel */
762     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
763     struct stackinfo *  si_prev;
764     struct stackinfo *  si_next;
765     I32                 si_cxix;        /* current context index */
766     I32                 si_cxmax;       /* maximum allocated index */
767     I32                 si_type;        /* type of runlevel */
768     I32                 si_markoff;     /* offset where markstack begins for us.
769                                          * currently used only with DEBUGGING,
770                                          * but not #ifdef-ed for bincompat */
771 };
772
773 typedef struct stackinfo PERL_SI;
774
775 #define cxstack         (PL_curstackinfo->si_cxstack)
776 #define cxstack_ix      (PL_curstackinfo->si_cxix)
777 #define cxstack_max     (PL_curstackinfo->si_cxmax)
778
779 #ifdef DEBUGGING
780 #  define       SET_MARK_OFFSET \
781     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
782 #else
783 #  define       SET_MARK_OFFSET NOOP
784 #endif
785
786 #define PUSHSTACKi(type) \
787     STMT_START {                                                        \
788         PERL_SI *next = PL_curstackinfo->si_next;                       \
789         if (!next) {                                                    \
790             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
791             next->si_prev = PL_curstackinfo;                            \
792             PL_curstackinfo->si_next = next;                            \
793         }                                                               \
794         next->si_type = type;                                           \
795         next->si_cxix = -1;                                             \
796         AvFILLp(next->si_stack) = 0;                                    \
797         SWITCHSTACK(PL_curstack,next->si_stack);                        \
798         PL_curstackinfo = next;                                         \
799         SET_MARK_OFFSET;                                                \
800     } STMT_END
801
802 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
803
804 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
805  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
806 #define POPSTACK \
807     STMT_START {                                                        \
808         dSP;                                                            \
809         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
810         if (!prev) {                                                    \
811             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
812             my_exit(1);                                                 \
813         }                                                               \
814         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
815         /* don't free prev here, free them all at the END{} */          \
816         PL_curstackinfo = prev;                                         \
817     } STMT_END
818
819 #define POPSTACK_TO(s) \
820     STMT_START {                                                        \
821         while (PL_curstack != s) {                                      \
822             dounwind(-1);                                               \
823             POPSTACK;                                                   \
824         }                                                               \
825     } STMT_END
826
827 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
828 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
829
830 /*
831 =head1 Multicall Functions
832
833 =for apidoc Ams||dMULTICALL
834 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
835
836 =for apidoc Ams||PUSH_MULTICALL
837 Opening bracket for a lightweight callback.
838 See L<perlcall/Lightweight Callbacks>.
839
840 =for apidoc Ams||MULTICALL
841 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
842
843 =for apidoc Ams||POP_MULTICALL
844 Closing bracket for a lightweight callback.
845 See L<perlcall/Lightweight Callbacks>.
846
847 =cut
848 */
849
850 #define dMULTICALL \
851     SV **newsp;                 /* set by POPBLOCK */                   \
852     PERL_CONTEXT *cx;                                                   \
853     CV *multicall_cv;                                                   \
854     OP *multicall_cop;                                                  \
855     bool multicall_oldcatch;                                            \
856     U8 hasargs = 0              /* used by PUSHSUB */
857
858 #define PUSH_MULTICALL(the_cv) \
859     STMT_START {                                                        \
860         CV * const _nOnclAshIngNamE_ = the_cv;                          \
861         CV * const cv = _nOnclAshIngNamE_;                              \
862         AV * const padlist = CvPADLIST(cv);                             \
863         ENTER;                                                          \
864         multicall_oldcatch = CATCH_GET;                                 \
865         SAVETMPS; SAVEVPTR(PL_op);                                      \
866         CATCH_SET(TRUE);                                                \
867         PUSHSTACKi(PERLSI_SORT);                                        \
868         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
869         PUSHSUB(cx);                                                    \
870         if (++CvDEPTH(cv) >= 2) {                                       \
871             PERL_STACK_OVERFLOW_CHECK();                                \
872             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
873         }                                                               \
874         SAVECOMPPAD();                                                  \
875         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
876         multicall_cv = cv;                                              \
877         multicall_cop = CvSTART(cv);                                    \
878     } STMT_END
879
880 #define MULTICALL \
881     STMT_START {                                                        \
882         PL_op = multicall_cop;                                          \
883         CALLRUNOPS(aTHX);                                               \
884     } STMT_END
885
886 #define POP_MULTICALL \
887     STMT_START {                                                        \
888         LEAVESUB(multicall_cv);                                         \
889         CvDEPTH(multicall_cv)--;                                        \
890         POPBLOCK(cx,PL_curpm);                                          \
891         POPSTACK;                                                       \
892         CATCH_SET(multicall_oldcatch);                                  \
893         LEAVE;                                                          \
894         SPAGAIN;                                                        \
895     } STMT_END
896
897 /*
898  * Local variables:
899  * c-indentation-style: bsd
900  * c-basic-offset: 4
901  * indent-tabs-mode: t
902  * End:
903  *
904  * ex: set ts=8 sts=4 sw=4 noet:
905  */