This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlxs.pod; rpc is considered obsolete
[perl5.git] / cop.h
CommitLineData
a0d0e21e 1/* cop.h
79072805 2 *
1129b882 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
8622e0e2 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
79072805
LW
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 *
8622e0e2 9 * Control ops (cops) are one of the two ops OP_NEXTSTATE and OP_DBSTATE,
775e5718 10 * that (loosely speaking) are statement separators.
3ffa1527
JH
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,
a3985cdc 13 * and thus can be used to determine our current state.
79072805
LW
14 */
15
0d2925a6 16/* A jmpenv packages the state required to perform a proper non-local jump.
1c98cc53
DM
17 * Note that there is a PL_start_env initialized when perl starts, and
18 * PL_top_env points to this initially, so PL_top_env should always be
19 * non-null.
0d2925a6 20 *
1c98cc53
DM
21 * Existence of a non-null PL_top_env->je_prev implies it is valid to call
22 * longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
0d2925a6
DM
23 * null to ensure this).
24 *
25 * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
26 * establish a local jmpenv to handle exception traps. Care must be taken
27 * to restore the previous value of je_mustcatch before exiting the
28 * stack frame iff JMPENV_PUSH was not called in that stack frame.
29 * GSAR 97-03-27
30 */
31
32struct jmpenv {
33 struct jmpenv * je_prev;
caa674f3 34 Sigjmp_buf je_buf; /* uninit if je_prev is NULL */
0d2925a6
DM
35 int je_ret; /* last exception thrown */
36 bool je_mustcatch; /* need to call longjmp()? */
a68090fe 37 U16 je_old_delaymagic; /* saved PL_delaymagic */
9449f0d6 38 SSize_t je_old_stack_hwm;
0d2925a6
DM
39};
40
41typedef struct jmpenv JMPENV;
42
9449f0d6
DM
43#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
44# define JE_OLD_STACK_HWM_zero PL_start_env.je_old_stack_hwm = 0
45# define JE_OLD_STACK_HWM_save(je) \
46 (je).je_old_stack_hwm = PL_curstackinfo->si_stack_hwm
47# define JE_OLD_STACK_HWM_restore(je) \
978b1859
DM
48 if (PL_curstackinfo->si_stack_hwm < (je).je_old_stack_hwm) \
49 PL_curstackinfo->si_stack_hwm = (je).je_old_stack_hwm
9449f0d6
DM
50#else
51# define JE_OLD_STACK_HWM_zero NOOP
52# define JE_OLD_STACK_HWM_save(je) NOOP
53# define JE_OLD_STACK_HWM_restore(je) NOOP
54#endif
55
0d2925a6
DM
56/*
57 * How to build the first jmpenv.
58 *
59 * top_env needs to be non-zero. It points to an area
60 * in which longjmp() stuff is stored, as C callstack
61 * info there at least is thread specific this has to
62 * be per-thread. Otherwise a 'die' in a thread gives
63 * that thread the C stack of last thread to do an eval {}!
64 */
65
66#define JMPENV_BOOTSTRAP \
67 STMT_START { \
caa674f3
DD
68 PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\
69 PL_top_env = &PL_start_env; \
70 PL_start_env.je_prev = NULL; \
0d2925a6
DM
71 PL_start_env.je_ret = -1; \
72 PL_start_env.je_mustcatch = TRUE; \
a68090fe 73 PL_start_env.je_old_delaymagic = 0; \
9449f0d6 74 JE_OLD_STACK_HWM_zero; \
0d2925a6
DM
75 } STMT_END
76
77/*
78 * PERL_FLEXIBLE_EXCEPTIONS
0bbec57d 79 *
0d2925a6
DM
80 * All the flexible exceptions code has been removed.
81 * See the following threads for details:
82 *
0bbec57d
MM
83 * Message-Id: 20040713143217.GB1424@plum.flirble.org
84 * https://www.nntp.perl.org/group/perl.perl5.porters/2004/07/msg93041.html
85 *
0d2925a6 86 * Joshua's original patches (which weren't applied) and discussion:
0bbec57d 87 *
0d2925a6
DM
88 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
89 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
90 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
91 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
92 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
93 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
0bbec57d 94 *
0d2925a6 95 * Chip's reworked patch and discussion:
0bbec57d 96 *
0d2925a6 97 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
0bbec57d 98 *
0d2925a6
DM
99 * The flaw in these patches (which went unnoticed at the time) was
100 * that they moved some code that could potentially die() out of the
101 * region protected by the setjmp()s. This caused exceptions within
102 * END blocks and such to not be handled by the correct setjmp().
c77726bb 103 *
0d2925a6
DM
104 * The original patches that introduces flexible exceptions were:
105 *
47ef154c
DB
106 * https://github.com/Perl/perl5/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
107 * https://github.com/Perl/perl5/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
c77726bb 108 *
0d2925a6
DM
109 */
110
111#define dJMPENV JMPENV cur_env
112
113#define JMPENV_PUSH(v) \
114 STMT_START { \
1c98cc53
DM
115 DEBUG_l({ \
116 int i = 0; JMPENV *p = PL_top_env; \
117 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM
118 Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
119 i, __FILE__, __LINE__);}) \
0d2925a6 120 cur_env.je_prev = PL_top_env; \
9449f0d6 121 JE_OLD_STACK_HWM_save(cur_env); \
0d2925a6 122 cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
9449f0d6 123 JE_OLD_STACK_HWM_restore(cur_env); \
0d2925a6
DM
124 PL_top_env = &cur_env; \
125 cur_env.je_mustcatch = FALSE; \
a68090fe 126 cur_env.je_old_delaymagic = PL_delaymagic; \
0d2925a6
DM
127 (v) = cur_env.je_ret; \
128 } STMT_END
129
130#define JMPENV_POP \
131 STMT_START { \
1c98cc53
DM
132 DEBUG_l({ \
133 int i = -1; JMPENV *p = PL_top_env; \
134 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM
135 Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
136 i, __FILE__, __LINE__);}) \
d3ab86be 137 assert(PL_top_env == &cur_env); \
a68090fe 138 PL_delaymagic = cur_env.je_old_delaymagic; \
0d2925a6
DM
139 PL_top_env = cur_env.je_prev; \
140 } STMT_END
141
142#define JMPENV_JUMP(v) \
143 STMT_START { \
1c98cc53
DM
144 DEBUG_l({ \
145 int i = -1; JMPENV *p = PL_top_env; \
146 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM
147 Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
148 (int)v, i, __FILE__, __LINE__);}) \
0d2925a6
DM
149 if (PL_top_env->je_prev) \
150 PerlProc_longjmp(PL_top_env->je_buf, (v)); \
151 if ((v) == 2) \
37038d91 152 PerlProc_exit(STATUS_EXIT); \
5637ef5b 153 PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
0d2925a6
DM
154 PerlProc_exit(1); \
155 } STMT_END
156
157#define CATCH_GET (PL_top_env->je_mustcatch)
1c98cc53
DM
158#define CATCH_SET(v) \
159 STMT_START { \
160 DEBUG_l( \
161 Perl_deb(aTHX_ \
162 "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
163 PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
164 __FILE__, __LINE__);) \
165 PL_top_env->je_mustcatch = (v); \
166 } STMT_END
0d2925a6 167
20439bc7 168/*
3f620621 169=for apidoc_section $COP
20439bc7
Z
170*/
171
172typedef struct refcounted_he COPHH;
173
174#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8
175
176/*
ffd08bbf 177=for apidoc Amx|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
20439bc7 178
2d7f6611
KW
179Look up the entry in the cop hints hash C<cophh> with the key specified by
180C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
20439bc7 181the key octets are interpreted as UTF-8, otherwise they are interpreted
2d7f6611 182as Latin-1. C<hash> is a precomputed hash of the key string, or zero if
20439bc7
Z
183it has not been precomputed. Returns a mortal scalar copy of the value
184associated with the key, or C<&PL_sv_placeholder> if there is no value
185associated with the key.
186
5af38e47
KW
187=for apidoc Amnh||COPHH_KEY_UTF8
188
20439bc7
Z
189=cut
190*/
191
192#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \
193 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags)
194
195/*
3bb9fd01 196=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|"key"|U32 flags
20439bc7 197
1568d13a 198Like L</cophh_fetch_pvn>, but takes a literal string instead
0c395ea5 199of a string/length pair, and no precomputed hash.
20439bc7
Z
200
201=cut
202*/
203
204#define cophh_fetch_pvs(cophh, key, flags) \
205 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags)
206
207/*
ffd08bbf 208=for apidoc Amx|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
20439bc7
Z
209
210Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of
211a string/length pair.
212
213=cut
214*/
215
216#define cophh_fetch_pv(cophh, key, hash, flags) \
217 Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags)
218
219/*
ffd08bbf 220=for apidoc Amx|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
20439bc7
Z
221
222Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a
223string/length pair.
224
225=cut
226*/
227
228#define cophh_fetch_sv(cophh, key, hash, flags) \
229 Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags)
230
231/*
ffd08bbf 232=for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags
20439bc7
Z
233
234Generates and returns a standard Perl hash representing the full set of
2d7f6611 235key/value pairs in the cop hints hash C<cophh>. C<flags> is currently
20439bc7
Z
236unused and must be zero.
237
238=cut
239*/
240
241#define cophh_2hv(cophh, flags) \
242 Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags)
243
244/*
ffd08bbf 245=for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh
20439bc7 246
2d7f6611 247Make and return a complete copy of the cop hints hash C<cophh>.
20439bc7
Z
248
249=cut
250*/
251
252#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh)
253
254/*
ffd08bbf 255=for apidoc Amx|void|cophh_free|COPHH *cophh
20439bc7 256
2d7f6611 257Discard the cop hints hash C<cophh>, freeing all resources associated
20439bc7
Z
258with it.
259
260=cut
261*/
262
263#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh)
264
265/*
ffd08bbf 266=for apidoc Amx|COPHH *|cophh_new_empty
20439bc7
Z
267
268Generate and return a fresh cop hints hash containing no entries.
269
270=cut
271*/
272
273#define cophh_new_empty() ((COPHH *)NULL)
274
275/*
ffd08bbf 276=for apidoc Amx|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
20439bc7 277
2d7f6611 278Stores a value, associated with a key, in the cop hints hash C<cophh>,
20439bc7
Z
279and returns the modified hash. The returned hash pointer is in general
280not the same as the hash pointer that was passed in. The input hash is
281consumed by the function, and the pointer to it must not be subsequently
282used. Use L</cophh_copy> if you need both hashes.
283
2d7f6611 284The key is specified by C<keypv> and C<keylen>. If C<flags> has the
20439bc7 285C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
2d7f6611 286otherwise they are interpreted as Latin-1. C<hash> is a precomputed
20439bc7
Z
287hash of the key string, or zero if it has not been precomputed.
288
2d7f6611 289C<value> is the scalar value to store for this key. C<value> is copied
20439bc7
Z
290by this function, which thus does not take ownership of any reference
291to it, and later changes to the scalar will not be reflected in the
292value visible in the cop hints hash. Complex types of scalar will not
293be stored with referential integrity, but will be coerced to strings.
294
295=cut
296*/
297
298#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
299 Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags)
300
301/*
28971e16 302=for apidoc Amx|COPHH *|cophh_store_pvs|COPHH *cophh|"key"|SV *value|U32 flags
20439bc7 303
1568d13a 304Like L</cophh_store_pvn>, but takes a literal string instead
0c395ea5 305of a string/length pair, and no precomputed hash.
20439bc7
Z
306
307=cut
308*/
309
310#define cophh_store_pvs(cophh, key, value, flags) \
311 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags)
312
313/*
28971e16 314=for apidoc Amx|COPHH *|cophh_store_pv|COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags
20439bc7
Z
315
316Like L</cophh_store_pvn>, but takes a nul-terminated string instead of
317a string/length pair.
318
319=cut
320*/
321
322#define cophh_store_pv(cophh, key, hash, value, flags) \
323 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags)
324
325/*
28971e16 326=for apidoc Amx|COPHH *|cophh_store_sv|COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags
20439bc7
Z
327
328Like L</cophh_store_pvn>, but takes a Perl scalar instead of a
329string/length pair.
330
331=cut
332*/
333
334#define cophh_store_sv(cophh, key, hash, value, flags) \
335 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags)
336
337/*
ffd08bbf 338=for apidoc Amx|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
20439bc7 339
2d7f6611 340Delete a key and its associated value from the cop hints hash C<cophh>,
20439bc7
Z
341and returns the modified hash. The returned hash pointer is in general
342not the same as the hash pointer that was passed in. The input hash is
343consumed by the function, and the pointer to it must not be subsequently
344used. Use L</cophh_copy> if you need both hashes.
345
2d7f6611 346The key is specified by C<keypv> and C<keylen>. If C<flags> has the
20439bc7 347C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
2d7f6611 348otherwise they are interpreted as Latin-1. C<hash> is a precomputed
20439bc7
Z
349hash of the key string, or zero if it has not been precomputed.
350
351=cut
352*/
353
354#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \
355 Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \
356 (SV *)NULL, flags)
357
358/*
28971e16 359=for apidoc Amx|COPHH *|cophh_delete_pvs|COPHH *cophh|"key"|U32 flags
20439bc7 360
1568d13a 361Like L</cophh_delete_pvn>, but takes a literal string instead
0c395ea5 362of a string/length pair, and no precomputed hash.
20439bc7
Z
363
364=cut
365*/
366
367#define cophh_delete_pvs(cophh, key, flags) \
368 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \
369 (SV *)NULL, flags)
370
371/*
28971e16 372=for apidoc Amx|COPHH *|cophh_delete_pv|COPHH *cophh|char *key|U32 hash|U32 flags
20439bc7
Z
373
374Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
375a string/length pair.
376
377=cut
378*/
379
380#define cophh_delete_pv(cophh, key, hash, flags) \
381 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
382
383/*
28971e16 384=for apidoc Amx|COPHH *|cophh_delete_sv|COPHH *cophh|SV *key|U32 hash|U32 flags
20439bc7
Z
385
386Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
387string/length pair.
388
389=cut
390*/
391
392#define cophh_delete_sv(cophh, key, hash, flags) \
393 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
0d2925a6 394
5ac1e9b2 395#include "mydtrace.h"
0d2925a6 396
88df5f01
FC
397struct cop {
398 BASEOP
399 /* On LP64 putting this here takes advantage of the fact that BASEOP isn't
400 an exact multiple of 8 bytes to save structure padding. */
401 line_t cop_line; /* line # of this command */
402 /* label for this construct is now stored in cop_hints_hash */
57843af0 403#ifdef USE_ITHREADS
88df5f01
FC
404 PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the
405 package the line was compiled in */
6600fe70 406 char * cop_file; /* name of file this command is from */
57843af0 407#else
88df5f01 408 HV * cop_stash; /* package line was compiled in */
6600fe70 409 GV * cop_filegv; /* name of GV file this command is from */
57843af0 410#endif
88df5f01
FC
411 U32 cop_hints; /* hints bits from pragmata */
412 U32 cop_seq; /* parse sequence number */
413 /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */
414 STRLEN * cop_warnings; /* lexical warnings bitmask */
415 /* compile time state of %^H. See the comment in op.c for how this is
416 used to recreate a hash to return from caller. */
20439bc7 417 COPHH * cop_hints_hash;
9f601cf3
TC
418 /* for now just a bitmask stored here.
419 If we get sufficient features this may become a pointer.
420 How these flags are stored is subject to change without
421 notice. Use the macros to test for features.
422 */
423 U32 cop_features;
79072805
LW
424};
425
add0fa58
KW
426/*
427=for apidoc Am|const char *|CopFILE|const COP * c
428Returns the name of the file associated with the C<COP> C<c>
429
430=for apidoc Am|STRLEN|CopLINE|const COP * c
431Returns the line number in the source code associated with the C<COP> C<c>
432
433=for apidoc Am|AV *|CopFILEAV|const COP * c
434Returns the AV associated with the C<COP> C<c>
435
436=for apidoc Am|SV *|CopFILESV|const COP * c
437Returns the SV associated with the C<COP> C<c>
438
439=for apidoc Am|void|CopFILE_set|COP * c|const char * pv
440Makes C<pv> the name of the file associated with the C<COP> C<c>
441
442=for apidoc Am|GV *|CopFILEGV|const COP * c
443Returns the GV associated with the C<COP> C<c>
444
445=for apidoc CopFILEGV_set
446Available only on unthreaded perls. Makes C<pv> the name of the file
447associated with the C<COP> C<c>
448
7f02c139
KW
449=for apidoc Am|HV *|CopSTASH|const COP * c
450Returns the stash associated with C<c>.
451
452=for apidoc Am|bool|CopSTASH_eq|const COP * c|const HV * hv
453Returns a boolean as to whether or not C<hv> is the stash associated with C<c>.
454
455=for apidoc Am|bool|CopSTASH_set|COP * c|HV * hv
456Set the stash associated with C<c> to C<hv>.
457
458=for apidoc Am|char *|CopSTASHPV|const COP * c
459Returns the package name of the stash associated with C<c>, or C<NULL> if no
460associated stash
461
462=for apidoc Am|void|CopSTASHPV_set|COP * c|const char * pv
463Set the package name of the stash associated with C<c>, to the NUL-terminated C
464string C<p>, creating the package if necessary.
465
add0fa58
KW
466=cut
467*/
468
57843af0 469#ifdef USE_ITHREADS
1dc74fdb
FC
470# define CopFILE(c) ((c)->cop_file)
471# define CopFILEGV(c) (CopFILE(c) \
472 ? gv_fetchfile(CopFILE(c)) : NULL)
0bbec57d 473
1dc74fdb
FC
474# ifdef NETWARE
475# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
d166b3ad 476# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepvn((pv),(l)))
1dc74fdb
FC
477# else
478# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
479# define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l)))
480# endif
481
482# define CopFILESV(c) (CopFILE(c) \
483 ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
484# define CopFILEAV(c) (CopFILE(c) \
485 ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
486# define CopFILEAVx(c) (assert_(CopFILE(c)) \
487 GvAV(gv_fetchfile(CopFILE(c))))
083fcd59 488
d4d03940
FC
489# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff]
490# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \
491 ? alloccopstash(hv) \
492 : 0)
1dc74fdb
FC
493# ifdef NETWARE
494# define CopFILE_free(c) SAVECOPFILE_FREE(c)
495# else
496# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
497# endif
6600fe70 498#else /* Above: no threads; Below yes threads */
57843af0 499# define CopFILEGV(c) ((c)->cop_filegv)
f4dd75d9 500# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
1dc74fdb
FC
501# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
502# define CopFILE_setn(c,pv,l) CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
503# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
504# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
505# ifdef DEBUGGING
506# define CopFILEAVx(c) (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
507# else
508# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
509# endif
6600fe70 510# define CopFILE(c) (CopFILEGV(c) /* +2 for '_<' */ \
1dc74fdb 511 ? GvNAME(CopFILEGV(c))+2 : NULL)
57843af0 512# define CopSTASH(c) ((c)->cop_stash)
f4dd75d9 513# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
a0714e2c 514# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
05ec9bb3 515
57843af0 516#endif /* USE_ITHREADS */
20439bc7 517
d4d03940
FC
518#define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
519 /* cop_stash is not refcounted */
520#define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
521#define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
d4d03940 522
20439bc7
Z
523#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
524#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h))
525
526/*
20439bc7
Z
527=for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags
528
2d7f6611
KW
529Look up the hint entry in the cop C<cop> with the key specified by
530C<keypv> and C<keylen>. If C<flags> has the C<COPHH_KEY_UTF8> bit set,
20439bc7 531the key octets are interpreted as UTF-8, otherwise they are interpreted
2d7f6611 532as Latin-1. C<hash> is a precomputed hash of the key string, or zero if
20439bc7
Z
533it has not been precomputed. Returns a mortal scalar copy of the value
534associated with the key, or C<&PL_sv_placeholder> if there is no value
535associated with the key.
536
537=cut
538*/
539
540#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \
541 cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
542
543/*
3bb9fd01 544=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|"key"|U32 flags
20439bc7 545
1568d13a 546Like L</cop_hints_fetch_pvn>, but takes a literal string
0c395ea5 547instead of a string/length pair, and no precomputed hash.
20439bc7
Z
548
549=cut
550*/
551
552#define cop_hints_fetch_pvs(cop, key, flags) \
553 cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags)
554
555/*
556=for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags
557
558Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead
559of a string/length pair.
560
561=cut
562*/
563
564#define cop_hints_fetch_pv(cop, key, hash, flags) \
565 cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags)
566
567/*
568=for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags
569
570Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a
571string/length pair.
572
573=cut
574*/
575
576#define cop_hints_fetch_sv(cop, key, hash, flags) \
577 cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags)
578
579/*
580=for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags
581
582Generates and returns a standard Perl hash representing the full set of
2d7f6611 583hint entries in the cop C<cop>. C<flags> is currently unused and must
20439bc7
Z
584be zero.
585
586=cut
587*/
588
589#define cop_hints_2hv(cop, flags) \
590 cophh_2hv(CopHINTHASH_get(cop), flags)
591
33d29c13
KW
592/*
593=for apidoc Am|const char *|CopLABEL|COP *const cop
594
595Returns the label attached to a cop.
596
597=for apidoc Am|const char *|CopLABEL_len|COP *const cop|STRLEN *len
598
599Returns the label attached to a cop, and stores its length in bytes into
600C<*len>.
601
602=for apidoc Am|const char *|CopLABEL_len_flags|COP *const cop|STRLEN *len|U32 *flags
603
604Returns the label attached to a cop, and stores its length in bytes into
605C<*len>. Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
606
607=cut
608*/
609
aebc0cbe 610#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
5db1eb8d
BF
611#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
612#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
dca6062a 613#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
57843af0 614
ed094faf 615#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
cc49e20b 616#define CopLINE(c) ((c)->cop_line)
57843af0
GS
617#define CopLINE_inc(c) (++CopLINE(c))
618#define CopLINE_dec(c) (--CopLINE(c))
619#define CopLINE_set(c,l) (CopLINE(c) = (l))
cc49e20b 620
248c2a4d 621/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
e37778c2 622#define OutCopFILE(c) CopFILE(c)
248c2a4d 623
d5ec2987 624#define CopHINTS_get(c) ((c)->cop_hints + 0)
623e6609 625#define CopHINTS_set(c, h) STMT_START { \
d5ec2987 626 (c)->cop_hints = (h); \
623e6609
NC
627 } STMT_END
628
79072805
LW
629/*
630 * Here we have some enormously heavy (or at least ponderous) wizardry.
631 */
632
633/* subroutine context */
634struct block_sub {
f9c764c5 635 OP * retop; /* op to execute on exit from sub */
5b6f7443 636 I32 old_cxsubix; /* previous value of si_cxsubix */
adcbf118 637 /* Above here is the same for sub, format and eval. */
9aa350eb 638 PAD *prevcomppad; /* the caller's PL_comppad */
8e663997 639 CV * cv;
f9c764c5 640 /* Above here is the same for sub and format. */
bb172083 641 I32 olddepth;
3073d04f 642 AV *savearray;
f9c764c5
NC
643};
644
645
646/* format context */
647struct block_format {
f39bc417 648 OP * retop; /* op to execute on exit from sub */
5b6f7443 649 I32 old_cxsubix; /* previous value of si_cxsubix */
adcbf118 650 /* Above here is the same for sub, format and eval. */
9aa350eb 651 PAD *prevcomppad; /* the caller's PL_comppad */
8e663997 652 CV * cv;
f9c764c5
NC
653 /* Above here is the same for sub and format. */
654 GV * gv;
655 GV * dfoutgv;
79072805
LW
656};
657
4ebe6e95
DM
658/* return a pointer to the current context */
659
660#define CX_CUR() (&cxstack[cxstack_ix])
661
dfe0f39b
DM
662/* free all savestack items back to the watermark of the specified context */
663
e992140c 664#define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->blk_oldsaveix)
dfe0f39b 665
5da525e9
DM
666#ifdef DEBUGGING
667/* on debugging builds, poison cx afterwards so we know no code
668 * uses it - because after doing cxstack_ix--, any ties, exceptions etc
669 * may overwrite the current stack frame */
670# define CX_POP(cx) \
4ebe6e95 671 assert(CX_CUR() == cx); \
5da525e9
DM
672 cxstack_ix--; \
673 cx = NULL;
674#else
675# define CX_POP(cx) cxstack_ix--;
676#endif
677
490576d1 678#define CX_PUSHSUB_GET_LVALUE_MASK(func) \
777d9014
FC
679 /* If the context is indeterminate, then only the lvalue */ \
680 /* flags that the caller also has are applicable. */ \
4587c532 681 ( \
777d9014
FC
682 (PL_op->op_flags & OPf_WANT) \
683 ? OPpENTERSUB_LVAL_MASK \
684 : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \
4587c532
FC
685 ? 0 : (U8)func(aTHX) \
686 )
687
fad386cb 688/* Restore old @_ */
b405d38b 689#define CX_POP_SAVEARRAY(cx) \
6d4ff0d2 690 STMT_START { \
f2b9631d 691 AV *cx_pop_savearray_av = GvAV(PL_defgv); \
a8bba7fa 692 GvAV(PL_defgv) = cx->blk_sub.savearray; \
656457d0 693 cx->blk_sub.savearray = NULL; \
f2b9631d 694 SvREFCNT_dec(cx_pop_savearray_av); \
6d4ff0d2 695 } STMT_END
6d4ff0d2 696
ecf8e9dd 697/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
8e09340b
GS
698 * leave any (a fast av_clear(ary), basically) */
699#define CLEAR_ARGARRAY(ary) \
700 STMT_START { \
701 AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \
9c6bc640 702 AvARRAY(ary) = AvALLOC(ary); \
8e09340b
GS
703 AvFILLp(ary) = -1; \
704 } STMT_END
7766f137 705
7e27c4a5 706
79072805
LW
707/* eval context */
708struct block_eval {
8e663997 709 OP * retop; /* op to execute on exit from eval */
5b6f7443 710 I32 old_cxsubix; /* previous value of si_cxsubix */
8e663997 711 /* Above here is the same for sub, format and eval. */
0f79a09d 712 SV * old_namesv;
79072805 713 OP * old_eval_root;
748a9306 714 SV * cur_text;
2090ab20 715 CV * cv;
abd70938 716 JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */
79072805
LW
717};
718
17347a51
NC
719/* If we ever need more than 512 op types, change the shift from 7.
720 blku_gimme is actually also only 2 bits, so could be merged with something.
721*/
722
4c57ced5
DM
723/* blk_u16 bit usage for eval contexts: */
724
725#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x3F) /* saved PL in_eval */
726#define CxEVAL_TXT_REFCNTED(cx) (((cx)->blk_u16) & 0x40) /* cur_text rc++ */
727#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) /* type of eval op */
85a64632 728
79072805
LW
729/* loop context */
730struct block_loop {
022eaa24 731 LOOP * my_op; /* My op, that contains redo, next and last ops. */
df530c37 732 union { /* different ways of locating the iteration variable */
b52de964
DM
733 SV **svp; /* for lexicals: address of pad slot */
734 GV *gv; /* for package vars */
df530c37 735 } itervar_u;
f0bb9bf7 736 SV *itersave; /* the original iteration var */
493b0a3c 737 union {
93661e56
DM
738 struct { /* CXt_LOOP_ARY, C<for (@ary)> */
739 AV *ary; /* array being iterated over */
740 IV ix; /* index relative to base of array */
d01136d6 741 } ary;
93661e56
DM
742 struct { /* CXt_LOOP_LIST, C<for (list)> */
743 I32 basesp; /* first element of list on stack */
744 IV ix; /* index relative to basesp */
745 } stack;
746 struct { /* CXt_LOOP_LAZYIV, C<for (1..9)> */
d01136d6
BS
747 IV cur;
748 IV end;
749 } lazyiv;
93661e56 750 struct { /* CXt_LOOP_LAZYSV C<for ('a'..'z')> */
d01136d6
BS
751 SV * cur;
752 SV * end; /* maxiumum value (or minimum in reverse) */
753 } lazysv;
754 } state_u;
7766f137 755#ifdef USE_ITHREADS
b52de964 756 PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */
f83b46a0 757#endif
b52de964 758};
f83b46a0 759
9af0df0b
DM
760#define CxITERVAR(c) \
761 (CxPADLOOP(c) \
762 ? (c)->blk_loop.itervar_u.svp \
763 : ((c)->cx_type & CXp_FOR_GV) \
764 ? &GvSV((c)->blk_loop.itervar_u.gv) \
765 : (SV **)&(c)->blk_loop.itervar_u.gv)
f83b46a0 766
b1cf8b36 767#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
5db1eb8d
BF
768#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
769#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
ae423868 770#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
d9203e03
DM
771
772/* CxLVAL(): the lval flags of the call site: the relevant flag bits from
773 * the op_private field of the calling pp_entersub (or its caller's caller
774 * if the caller's lvalue context isn't known):
775 * OPpLVAL_INTRO: sub used in lvalue context, e.g. f() = 1;
776 * OPpENTERSUB_INARGS (in conjunction with OPpLVAL_INTRO): the
777 * function is being used as a sub arg or as a referent, e.g.
778 * g(...,f(),...) or $r = \f()
779 * OPpDEREF: 2-bit mask indicating e.g. f()->[0].
780 * Note the contrast with CvLVALUE(), which is a property of the sub
781 * rather than the call site.
782 */
1956db7e 783#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
1956db7e 784
7766f137 785
79072805 786
7896dde7
Z
787/* given/when context */
788struct block_givwhen {
0d863452 789 OP *leave_op;
7896dde7 790 SV *defsv_save; /* the original $_ */
0d863452
RH
791};
792
0d863452 793
c5369ccc 794
79072805
LW
795/* context common to subroutines, evals and loops */
796struct block {
446d0787 797 U8 blku_type; /* what kind of context this is */
2e0df0e8 798 U8 blku_gimme; /* is this block running in list context? */
17347a51 799 U16 blku_u16; /* used by block_sub and block_eval (so far) */
e992140c
DM
800 I32 blku_oldsaveix; /* saved PL_savestack_ix */
801 /* all the fields above must be aligned with same-sized fields as sbu */
1bef65a2 802 I32 blku_oldsp; /* current sp floor: where nextstate pops to */
79072805 803 I32 blku_oldmarksp; /* mark stack index */
f284fecd 804 COP * blku_oldcop; /* old curcop pointer */
79072805 805 PMOP * blku_oldpm; /* values of pattern match vars */
bb3300d1 806 SSize_t blku_old_tmpsfloor; /* saved PL_tmps_floor */
f284fecd 807 I32 blku_oldscopesp; /* scope stack index */
79072805
LW
808
809 union {
810 struct block_sub blku_sub;
f9c764c5 811 struct block_format blku_format;
79072805
LW
812 struct block_eval blku_eval;
813 struct block_loop blku_loop;
7896dde7 814 struct block_givwhen blku_givwhen;
79072805
LW
815 } blk_u;
816};
817#define blk_oldsp cx_u.cx_blk.blku_oldsp
818#define blk_oldcop cx_u.cx_blk.blku_oldcop
79072805
LW
819#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
820#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
821#define blk_oldpm cx_u.cx_blk.blku_oldpm
822#define blk_gimme cx_u.cx_blk.blku_gimme
446d0787 823#define blk_u16 cx_u.cx_blk.blku_u16
e992140c 824#define blk_oldsaveix cx_u.cx_blk.blku_oldsaveix
ce8bb8d8 825#define blk_old_tmpsfloor cx_u.cx_blk.blku_old_tmpsfloor
79072805 826#define blk_sub cx_u.cx_blk.blk_u.blku_sub
f9c764c5 827#define blk_format cx_u.cx_blk.blk_u.blku_format
79072805
LW
828#define blk_eval cx_u.cx_blk.blk_u.blku_eval
829#define blk_loop cx_u.cx_blk.blk_u.blku_loop
7896dde7 830#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
79072805 831
5e691bc6 832#define CX_DEBUG(cx, action) \
d9f81b50 833 DEBUG_l( \
bb3300d1 834 Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\
1c98cc53
DM
835 (long)cxstack_ix, \
836 action, \
5e691bc6 837 PL_block_type[CxTYPE(cx)], \
1c98cc53 838 (long)PL_scopestack_ix, \
5e691bc6 839 (long)(cx->blk_oldscopesp), \
bb3300d1 840 (long)PL_savestack_ix, \
5e691bc6 841 (long)(cx->blk_oldsaveix), \
d9f81b50 842 __FILE__, __LINE__));
1c98cc53 843
ed8ff0f3 844
79072805
LW
845
846/* substitution context */
847struct subst {
e992140c 848 U8 sbu_type; /* same as blku_type */
1ed74d04 849 U8 sbu_rflags;
e992140c
DM
850 U16 sbu_rxtainted;
851 I32 sbu_oldsaveix; /* same as blku_oldsaveix */
a7f94955 852 /* all the fields above must be aligned with same-sized fields as blk_u */
3c6ef0a5
FC
853 SSize_t sbu_iters;
854 SSize_t sbu_maxiters;
79072805
LW
855 char * sbu_orig;
856 SV * sbu_dstr;
857 SV * sbu_targ;
858 char * sbu_s;
859 char * sbu_m;
860 char * sbu_strend;
c90c0ff4 861 void * sbu_rxres;
c07a80fd 862 REGEXP * sbu_rx;
79072805 863};
a0412c00
KW
864
865#ifdef PERL_CORE
866
79072805
LW
867#define sb_iters cx_u.cx_subst.sbu_iters
868#define sb_maxiters cx_u.cx_subst.sbu_maxiters
22e551b9 869#define sb_rflags cx_u.cx_subst.sbu_rflags
71be2cbc 870#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
79072805
LW
871#define sb_orig cx_u.cx_subst.sbu_orig
872#define sb_dstr cx_u.cx_subst.sbu_dstr
873#define sb_targ cx_u.cx_subst.sbu_targ
874#define sb_s cx_u.cx_subst.sbu_s
875#define sb_m cx_u.cx_subst.sbu_m
876#define sb_strend cx_u.cx_subst.sbu_strend
c90c0ff4 877#define sb_rxres cx_u.cx_subst.sbu_rxres
c07a80fd 878#define sb_rx cx_u.cx_subst.sbu_rx
79072805 879
490576d1 880# define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(), \
e992140c 881 cx->blk_oldsaveix = oldsave, \
79072805
LW
882 cx->sb_iters = iters, \
883 cx->sb_maxiters = maxiters, \
22e551b9 884 cx->sb_rflags = r_flags, \
71be2cbc 885 cx->sb_rxtainted = rxtainted, \
79072805
LW
886 cx->sb_orig = orig, \
887 cx->sb_dstr = dstr, \
888 cx->sb_targ = targ, \
889 cx->sb_s = s, \
890 cx->sb_m = m, \
891 cx->sb_strend = strend, \
4608196e 892 cx->sb_rxres = NULL, \
c07a80fd 893 cx->sb_rx = rx, \
1ed74d04 894 cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \
e22ae1e2 895 rxres_save(&cx->sb_rxres, rx); \
cf69025f
TC
896 (void)ReREFCNT_inc(rx); \
897 SvREFCNT_inc_void_NN(targ)
79072805 898
b405d38b 899# define CX_POPSUBST(cx) \
77189b8c
DM
900 STMT_START { \
901 REGEXP *re; \
e4592eb4 902 assert(CxTYPE(cx) == CXt_SUBST); \
e22ae1e2 903 rxres_free(&cx->sb_rxres); \
77189b8c
DM
904 re = cx->sb_rx; \
905 cx->sb_rx = NULL; \
906 ReREFCNT_dec(re); \
907 SvREFCNT_dec_NN(cx->sb_targ); \
908 } STMT_END
9c105995
NC
909#endif
910
911#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
79072805
LW
912
913struct context {
79072805
LW
914 union {
915 struct block cx_blk;
916 struct subst cx_subst;
917 } cx_u;
918};
2e0df0e8 919#define cx_type cx_u.cx_subst.sbu_type
6b35e009 920
76753e7f
NC
921/* If you re-order these, there is also an array of uppercase names in perl.h
922 and a static array of context names in pp_ctl.c */
3701055e 923#define CXTYPEMASK 0xf
79646418 924#define CXt_NULL 0 /* currently only used for sort BLOCK */
7896dde7 925#define CXt_WHEN 1
76753e7f 926#define CXt_BLOCK 2
7896dde7
Z
927/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
928 jump table in pp_ctl.c
929 The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
930*/
931#define CXt_GIVEN 3
932
933/* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
93661e56 934 * CxFOREACH compare ranges */
c349b9a0
DM
935#define CXt_LOOP_ARY 4 /* for (@ary) { ...; } */
936#define CXt_LOOP_LAZYSV 5 /* for ('a'..'z') { ...; } */
937#define CXt_LOOP_LAZYIV 6 /* for (1..9) { ...; } */
938#define CXt_LOOP_LIST 7 /* for (1,2,3) { ...; } */
939#define CXt_LOOP_PLAIN 8 /* while (...) { ...; }
940 or plain block { ...; } */
93661e56
DM
941#define CXt_SUB 9
942#define CXt_FORMAT 10
943#define CXt_EVAL 11
944#define CXt_SUBST 12
76753e7f 945/* SUBST doesn't feature in all switch statements. */
79072805 946
ae423868 947/* private flags for CXt_SUB and CXt_FORMAT */
79646418
DM
948#define CXp_MULTICALL 0x10 /* part of a multicall (so don't tear down
949 context on exit). (not CXt_FORMAT) */
1f27d788 950#define CXp_HASARGS 0x20
b0065247
DM
951#define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */
952#define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */
ae423868 953
6b35e009 954/* private flags for CXt_EVAL */
1f27d788
NC
955#define CXp_REAL 0x20 /* truly eval'', not a lookalike */
956#define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */
6b35e009 957
7766f137 958/* private flags for CXt_LOOP */
28e0cf42 959
7896dde7
Z
960/* this is only set in conjunction with CXp_FOR_GV */
961#define CXp_FOR_DEF 0x10 /* foreach using $_ */
28e0cf42 962/* these 3 are mutually exclusive */
d39c26a6 963#define CXp_FOR_LVREF 0x20 /* foreach using \$var */
9af0df0b
DM
964#define CXp_FOR_GV 0x40 /* foreach using package var */
965#define CXp_FOR_PAD 0x80 /* foreach using lexical var */
28e0cf42 966
9af0df0b 967#define CxPADLOOP(c) ((c)->cx_type & CXp_FOR_PAD)
e846cb92 968
1ed74d04
NC
969/* private flags for CXt_SUBST */
970#define CXp_ONCE 0x10 /* What was sbu_once in struct subst */
7766f137 971
6b35e009 972#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
7896dde7 973#define CxTYPE_is_LOOP(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \
113ebcf5 974 && CxTYPE(cx) <= CXt_LOOP_PLAIN)
79646418 975#define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL)
0588a150 976#define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \
7766f137 977 == (CXt_EVAL|CXp_REAL))
0588a150 978#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \
1d76a5c3 979 == (CXt_EVAL|CXp_TRYBLOCK))
113ebcf5
DM
980#define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \
981 && CxTYPE(cx) <= CXt_LOOP_LIST)
6b35e009 982
109bf713 983#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
79072805 984
2f8edad0
NC
985#define G_SCALAR 2
986#define G_ARRAY 3
987#define G_VOID 1
988#define G_WANT 3
79072805 989
864dbfa3 990/* extra flags for Perl_call_* routines */
66ff4fb5 991#define G_DISCARD 0x4 /* Call FREETMPS.
b54b4831
NC
992 Don't change this without consulting the
993 hash actions codes defined in hv.h */
66ff4fb5
TC
994#define G_EVAL 0x8 /* Assume eval {} around subroutine call. */
995#define G_NOARGS 0x10 /* Don't construct a @_ array. */
996#define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */
997#define G_NODEBUG 0x40 /* Disable debugging at toplevel. */
998#define G_METHOD 0x80 /* Calling method. */
999#define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or
edb2152a 1000 fold_constants. */
66ff4fb5 1001#define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef
67549bd2
NC
1002 A special case for UNSHIFT in
1003 Perl_magic_methcall(). */
66ff4fb5 1004#define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling
d1d7a15d 1005 Perl_magic_methcall(). */
66ff4fb5
TC
1006#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
1007#define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */
1008#define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */
e336de0d 1009
faef0170
HS
1010/* flag bits for PL_in_eval */
1011#define EVAL_NULL 0 /* not in an eval */
1012#define EVAL_INEVAL 1 /* some enclosing scope is an eval */
1013#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
864dbfa3 1014#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
6dc8a9e4 1015#define EVAL_INREQUIRE 8 /* The code is being required. */
a1941760 1016#define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */
4c57ced5 1017/* if adding extra bits, make sure they can fit in CxOLD_OP_TYPE() */
faef0170 1018
e336de0d
GS
1019/* Support for switching (stack and block) contexts.
1020 * This ensures magic doesn't invalidate local stack and cx pointers.
ec834f46
KW
1021 * Which one to use (or add) is mostly, but not completely arbitrary: See
1022 * http://nntp.perl.org/group/perl.perl5.porters/257169
e336de0d
GS
1023 */
1024
e788e7d3
GS
1025#define PERLSI_UNKNOWN -1
1026#define PERLSI_UNDEF 0
1027#define PERLSI_MAIN 1
1028#define PERLSI_MAGIC 2
1029#define PERLSI_SORT 3
1030#define PERLSI_SIGNAL 4
1031#define PERLSI_OVERLOAD 5
1032#define PERLSI_DESTROY 6
1033#define PERLSI_WARNHOOK 7
1034#define PERLSI_DIEHOOK 8
1035#define PERLSI_REQUIRE 9
e1a10f35 1036#define PERLSI_MULTICALL 10
b6d9446c 1037#define PERLSI_REGCOMP 11
e336de0d
GS
1038
1039struct stackinfo {
1040 AV * si_stack; /* stack for current runlevel */
1041 PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
9bd87817
NC
1042 struct stackinfo * si_prev;
1043 struct stackinfo * si_next;
e336de0d
GS
1044 I32 si_cxix; /* current context index */
1045 I32 si_cxmax; /* maximum allocated index */
5b6f7443 1046 I32 si_cxsubix; /* topmost sub/eval/format */
e336de0d 1047 I32 si_type; /* type of runlevel */
ce2f7c3b 1048 I32 si_markoff; /* offset where markstack begins for us.
e336de0d
GS
1049 * currently used only with DEBUGGING,
1050 * but not #ifdef-ed for bincompat */
1fced1a2 1051#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM
1052/* high water mark: for checking if the stack was correctly extended /
1053 * tested for extension by each pp function */
1054 SSize_t si_stack_hwm;
1055#endif
1056
e336de0d
GS
1057};
1058
55d39ade
KW
1059/*
1060=for apidoc Ay||PERL_SI
1061Use this typedef to declare variables that are to hold C<struct stackinfo>.
1062
1063=cut
1064*/
e336de0d
GS
1065typedef struct stackinfo PERL_SI;
1066
3280af22
NIS
1067#define cxstack (PL_curstackinfo->si_cxstack)
1068#define cxstack_ix (PL_curstackinfo->si_cxix)
1069#define cxstack_max (PL_curstackinfo->si_cxmax)
e336de0d
GS
1070
1071#ifdef DEBUGGING
ce2f7c3b
GS
1072# define SET_MARK_OFFSET \
1073 PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
e336de0d 1074#else
ce2f7c3b 1075# define SET_MARK_OFFSET NOOP
e336de0d
GS
1076#endif
1077
87058c31 1078#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
45d6bfc0 1079# define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0)
87058c31
DM
1080#else
1081# define PUSHSTACK_INIT_HWM(si) NOOP
1082#endif
1083
d3acc0f7 1084#define PUSHSTACKi(type) \
e336de0d 1085 STMT_START { \
3280af22 1086 PERL_SI *next = PL_curstackinfo->si_next; \
1c98cc53
DM
1087 DEBUG_l({ \
1088 int i = 0; PERL_SI *p = PL_curstackinfo; \
1089 while (p) { i++; p = p->si_prev; } \
1090 Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
1091 i, __FILE__, __LINE__);}) \
e336de0d
GS
1092 if (!next) { \
1093 next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
3280af22
NIS
1094 next->si_prev = PL_curstackinfo; \
1095 PL_curstackinfo->si_next = next; \
e336de0d
GS
1096 } \
1097 next->si_type = type; \
1098 next->si_cxix = -1; \
5b6f7443 1099 next->si_cxsubix = -1; \
87058c31 1100 PUSHSTACK_INIT_HWM(next); \
e336de0d 1101 AvFILLp(next->si_stack) = 0; \
3280af22
NIS
1102 SWITCHSTACK(PL_curstack,next->si_stack); \
1103 PL_curstackinfo = next; \
ce2f7c3b 1104 SET_MARK_OFFSET; \
e336de0d
GS
1105 } STMT_END
1106
e788e7d3 1107#define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
d3acc0f7 1108
3095d977
GS
1109/* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
1110 * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
d3acc0f7 1111#define POPSTACK \
e336de0d 1112 STMT_START { \
39644a26 1113 dSP; \
c4420975 1114 PERL_SI * const prev = PL_curstackinfo->si_prev; \
1c98cc53
DM
1115 DEBUG_l({ \
1116 int i = -1; PERL_SI *p = PL_curstackinfo; \
1117 while (p) { i++; p = p->si_prev; } \
1118 Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
1119 i, __FILE__, __LINE__);}) \
e336de0d 1120 if (!prev) { \
3d04513d 1121 Perl_croak_popstack(); \
e336de0d 1122 } \
3280af22 1123 SWITCHSTACK(PL_curstack,prev->si_stack); \
e336de0d 1124 /* don't free prev here, free them all at the END{} */ \
3280af22 1125 PL_curstackinfo = prev; \
e336de0d
GS
1126 } STMT_END
1127
1128#define POPSTACK_TO(s) \
1129 STMT_START { \
3280af22 1130 while (PL_curstack != s) { \
bac4b2ad 1131 dounwind(-1); \
d3acc0f7 1132 POPSTACK; \
bac4b2ad 1133 } \
e336de0d 1134 } STMT_END
923e4eb5 1135
d57dfc83 1136/*
3f620621 1137=for apidoc_section $utility
d57dfc83
KW
1138=for apidoc Amn|bool|IN_PERL_COMPILETIME
1139Returns 1 if this macro is being called during the compilation phase of the
1140program; otherwise 0;
ed8ff0f3 1141
d57dfc83
KW
1142=for apidoc Amn|bool|IN_PERL_RUNTIME
1143Returns 1 if this macro is being called during the execution phase of the
1144program; otherwise 0;
ed8ff0f3 1145
d57dfc83
KW
1146=cut
1147*/
1148#define IN_PERL_COMPILETIME cBOOL(PL_curcop == &PL_compiling)
1149#define IN_PERL_RUNTIME cBOOL(PL_curcop != &PL_compiling)
ed8ff0f3 1150
9850bf21 1151/*
3f620621 1152=for apidoc_section $multicall
9850bf21 1153
4e5171e9 1154=for apidoc Amns||dMULTICALL
72d33970 1155Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21 1156
78342678 1157=for apidoc Ams||PUSH_MULTICALL|CV* the_cv
9850bf21 1158Opening bracket for a lightweight callback.
0eda4409 1159See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21 1160
4e5171e9 1161=for apidoc Amns||MULTICALL
72d33970 1162Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21 1163
4e5171e9 1164=for apidoc Amns||POP_MULTICALL
9850bf21 1165Closing bracket for a lightweight callback.
0eda4409 1166See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21
RH
1167
1168=cut
1169*/
1170
1171#define dMULTICALL \
79503099 1172 OP *multicall_cop; \
35095fd0 1173 bool multicall_oldcatch
9850bf21 1174
82f35e8b 1175#define PUSH_MULTICALL(the_cv) \
b0065247 1176 PUSH_MULTICALL_FLAGS(the_cv, 0)
81ed78b2 1177
b0065247
DM
1178/* Like PUSH_MULTICALL, but allows you to specify extra flags
1179 * for the CX stack entry (this isn't part of the public API) */
81ed78b2 1180
b0065247 1181#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
9850bf21 1182 STMT_START { \
79503099 1183 PERL_CONTEXT *cx; \
0bcc34c2
AL
1184 CV * const _nOnclAshIngNamE_ = the_cv; \
1185 CV * const cv = _nOnclAshIngNamE_; \
b70d5558 1186 PADLIST * const padlist = CvPADLIST(cv); \
9850bf21 1187 multicall_oldcatch = CATCH_GET; \
9850bf21 1188 CATCH_SET(TRUE); \
e1a10f35 1189 PUSHSTACKi(PERLSI_MULTICALL); \
1c23e2bd 1190 cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \
fd9b7244 1191 PL_stack_sp, PL_savestack_ix); \
79503099 1192 cx_pushsub(cx, cv, NULL, 0); \
49f582ca 1193 SAVEOP(); \
b0065247
DM
1194 if (!(flags & CXp_SUB_RE_FAKE)) \
1195 CvDEPTH(cv)++; \
d2af2719 1196 if (CvDEPTH(cv) >= 2) \
9850bf21 1197 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
9850bf21
RH
1198 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
1199 multicall_cop = CvSTART(cv); \
1200 } STMT_END
1201
1202#define MULTICALL \
1203 STMT_START { \
1204 PL_op = multicall_cop; \
1205 CALLRUNOPS(aTHX); \
1206 } STMT_END
1207
1208#define POP_MULTICALL \
1209 STMT_START { \
79503099 1210 PERL_CONTEXT *cx; \
4ebe6e95 1211 cx = CX_CUR(); \
dfe0f39b 1212 CX_LEAVE_SCOPE(cx); \
a73d8813 1213 cx_popsub_common(cx); \
4df352a8 1214 gimme = cx->blk_gimme; \
7e27c4a5 1215 PERL_UNUSED_VAR(gimme); /* for API */ \
ed8ff0f3 1216 cx_popblock(cx); \
5da525e9 1217 CX_POP(cx); \
1bbbfc50 1218 POPSTACK; \
9850bf21 1219 CATCH_SET(multicall_oldcatch); \
1bbbfc50 1220 SPAGAIN; \
9850bf21 1221 } STMT_END
b3ca2e83 1222
81ed78b2
DM
1223/* Change the CV of an already-pushed MULTICALL CxSUB block.
1224 * (this isn't part of the public API) */
1225
b0065247 1226#define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
81ed78b2
DM
1227 STMT_START { \
1228 CV * const _nOnclAshIngNamE_ = the_cv; \
1229 CV * const cv = _nOnclAshIngNamE_; \
b70d5558 1230 PADLIST * const padlist = CvPADLIST(cv); \
79503099 1231 PERL_CONTEXT *cx = CX_CUR(); \
79646418 1232 assert(CxMULTICALL(cx)); \
a73d8813 1233 cx_popsub_common(cx); \
b0065247 1234 cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \
79503099 1235 cx_pushsub(cx, cv, NULL, 0); \
b0065247
DM
1236 if (!(flags & CXp_SUB_RE_FAKE)) \
1237 CvDEPTH(cv)++; \
d2af2719 1238 if (CvDEPTH(cv) >= 2) \
81ed78b2 1239 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
81ed78b2 1240 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
81ed78b2
DM
1241 multicall_cop = CvSTART(cv); \
1242 } STMT_END
b3ca2e83 1243/*
14d04a33 1244 * ex: set ts=8 sts=4 sw=4 et:
b3ca2e83 1245 */