This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
t/op/sprintf.t: include test comment in "ok" output, where available
[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()? */
37};
38
39typedef struct jmpenv JMPENV;
40
0d2925a6
DM		 41/*
42 * How to build the first jmpenv.
43 *
44 * top_env needs to be non-zero. It points to an area
45 * in which longjmp() stuff is stored, as C callstack
46 * info there at least is thread specific this has to
47 * be per-thread. Otherwise a 'die' in a thread gives
48 * that thread the C stack of last thread to do an eval {}!
49 */
50
51#define JMPENV_BOOTSTRAP \
52 STMT_START { \
caa674f3
DD		 53 PERL_POISON_EXPR(PoisonNew(&PL_start_env, 1, JMPENV));\
54 PL_top_env = &PL_start_env; \
55 PL_start_env.je_prev = NULL; \
0d2925a6
DM		 56 PL_start_env.je_ret = -1; \
57 PL_start_env.je_mustcatch = TRUE; \
0d2925a6
DM		 58 } STMT_END
59
60/*
61 * PERL_FLEXIBLE_EXCEPTIONS
62 *
63 * All the flexible exceptions code has been removed.
64 * See the following threads for details:
65 *
66 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
67 *
68 * Joshua's original patches (which weren't applied) and discussion:
69 *
70 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
71 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
72 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
73 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
74 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
75 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
76 *
77 * Chip's reworked patch and discussion:
78 *
79 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
80 *
81 * The flaw in these patches (which went unnoticed at the time) was
82 * that they moved some code that could potentially die() out of the
83 * region protected by the setjmp()s. This caused exceptions within
84 * END blocks and such to not be handled by the correct setjmp().
85 *
86 * The original patches that introduces flexible exceptions were:
87 *
ff7e9008
MS		 88 * http://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929
89 * http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a
90 *
0d2925a6
DM		 91 */
92
93#define dJMPENV JMPENV cur_env
94
95#define JMPENV_PUSH(v) \
96 STMT_START { \
1c98cc53
DM		 97 DEBUG_l({ \
98 int i = 0; JMPENV *p = PL_top_env; \
99 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM		 100 Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
101 i, __FILE__, __LINE__);}) \
0d2925a6 102 cur_env.je_prev = PL_top_env; \
0d2925a6 103 cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \
0d2925a6
DM		 104 PL_top_env = &cur_env; \
105 cur_env.je_mustcatch = FALSE; \
106 (v) = cur_env.je_ret; \
107 } STMT_END
108
109#define JMPENV_POP \
110 STMT_START { \
1c98cc53
DM		 111 DEBUG_l({ \
112 int i = -1; JMPENV *p = PL_top_env; \
113 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM		 114 Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
115 i, __FILE__, __LINE__);}) \
d3ab86be 116 assert(PL_top_env == &cur_env); \
0d2925a6
DM		 117 PL_top_env = cur_env.je_prev; \
118 } STMT_END
119
120#define JMPENV_JUMP(v) \
121 STMT_START { \
1c98cc53
DM		 122 DEBUG_l({ \
123 int i = -1; JMPENV *p = PL_top_env; \
124 while (p) { i++; p = p->je_prev; } \
91e35ba1
DM		 125 Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
126 (int)v, i, __FILE__, __LINE__);}) \
0d2925a6
DM		 127 if (PL_top_env->je_prev) \
128 PerlProc_longjmp(PL_top_env->je_buf, (v)); \
129 if ((v) == 2) \
37038d91 130 PerlProc_exit(STATUS_EXIT); \
5637ef5b 131 PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
0d2925a6
DM		 132 PerlProc_exit(1); \
133 } STMT_END
134
135#define CATCH_GET (PL_top_env->je_mustcatch)
1c98cc53
DM		 136#define CATCH_SET(v) \
137 STMT_START { \
138 DEBUG_l( \
139 Perl_deb(aTHX_ \
140 "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
141 PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
142 __FILE__, __LINE__);) \
143 PL_top_env->je_mustcatch = (v); \
144 } STMT_END
0d2925a6 145
20439bc7
Z		 146/*
147=head1 COP Hint Hashes
148*/
149
150typedef struct refcounted_he COPHH;
151
152#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8
153
154/*
ffd08bbf 155=for apidoc Amx|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
20439bc7
Z		 156
157Look up the entry in the cop hints hash I<cophh> with the key specified by
158I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set,
159the key octets are interpreted as UTF-8, otherwise they are interpreted
160as Latin-1. I<hash> is a precomputed hash of the key string, or zero if
161it has not been precomputed. Returns a mortal scalar copy of the value
162associated with the key, or C<&PL_sv_placeholder> if there is no value
163associated with the key.
164
165=cut
166*/
167
168#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \
169 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags)
170
171/*
ffd08bbf 172=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|const char *key|U32 flags
20439bc7
Z		 173
174Like L</cophh_fetch_pvn>, but takes a literal string instead of a
175string/length pair, and no precomputed hash.
176
177=cut
178*/
179
180#define cophh_fetch_pvs(cophh, key, flags) \
181 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags)
182
183/*
ffd08bbf 184=for apidoc Amx|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
20439bc7
Z		 185
186Like L</cophh_fetch_pvn>, but takes a nul-terminated string instead of
187a string/length pair.
188
189=cut
190*/
191
192#define cophh_fetch_pv(cophh, key, hash, flags) \
193 Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags)
194
195/*
ffd08bbf 196=for apidoc Amx|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
20439bc7
Z		 197
198Like L</cophh_fetch_pvn>, but takes a Perl scalar instead of a
199string/length pair.
200
201=cut
202*/
203
204#define cophh_fetch_sv(cophh, key, hash, flags) \
205 Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags)
206
207/*
ffd08bbf 208=for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags
20439bc7
Z		 209
210Generates and returns a standard Perl hash representing the full set of
211key/value pairs in the cop hints hash I<cophh>. I<flags> is currently
212unused and must be zero.
213
214=cut
215*/
216
217#define cophh_2hv(cophh, flags) \
218 Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags)
219
220/*
ffd08bbf 221=for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh
20439bc7
Z		 222
223Make and return a complete copy of the cop hints hash I<cophh>.
224
225=cut
226*/
227
228#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh)
229
230/*
ffd08bbf 231=for apidoc Amx|void|cophh_free|COPHH *cophh
20439bc7
Z		 232
233Discard the cop hints hash I<cophh>, freeing all resources associated
234with it.
235
236=cut
237*/
238
239#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh)
240
241/*
ffd08bbf 242=for apidoc Amx|COPHH *|cophh_new_empty
20439bc7
Z		 243
244Generate and return a fresh cop hints hash containing no entries.
245
246=cut
247*/
248
249#define cophh_new_empty() ((COPHH *)NULL)
250
251/*
ffd08bbf 252=for apidoc Amx|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
20439bc7
Z		 253
254Stores a value, associated with a key, in the cop hints hash I<cophh>,
255and returns the modified hash. The returned hash pointer is in general
256not the same as the hash pointer that was passed in. The input hash is
257consumed by the function, and the pointer to it must not be subsequently
258used. Use L</cophh_copy> if you need both hashes.
259
260The key is specified by I<keypv> and I<keylen>. If I<flags> has the
261C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
262otherwise they are interpreted as Latin-1. I<hash> is a precomputed
263hash of the key string, or zero if it has not been precomputed.
264
265I<value> is the scalar value to store for this key. I<value> is copied
266by this function, which thus does not take ownership of any reference
267to it, and later changes to the scalar will not be reflected in the
268value visible in the cop hints hash. Complex types of scalar will not
269be stored with referential integrity, but will be coerced to strings.
270
271=cut
272*/
273
274#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \
275 Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags)
276
277/*
ffd08bbf 278=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|const char *key|SV *value|U32 flags
20439bc7
Z		 279
280Like L</cophh_store_pvn>, but takes a literal string instead of a
281string/length pair, and no precomputed hash.
282
283=cut
284*/
285
286#define cophh_store_pvs(cophh, key, value, flags) \
287 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags)
288
289/*
ffd08bbf 290=for apidoc Amx|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags
20439bc7
Z		 291
292Like L</cophh_store_pvn>, but takes a nul-terminated string instead of
293a string/length pair.
294
295=cut
296*/
297
298#define cophh_store_pv(cophh, key, hash, value, flags) \
299 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags)
300
301/*
ffd08bbf 302=for apidoc Amx|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags
20439bc7
Z		 303
304Like L</cophh_store_pvn>, but takes a Perl scalar instead of a
305string/length pair.
306
307=cut
308*/
309
310#define cophh_store_sv(cophh, key, hash, value, flags) \
311 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags)
312
313/*
ffd08bbf 314=for apidoc Amx|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags
20439bc7
Z		 315
316Delete a key and its associated value from the cop hints hash I<cophh>,
317and returns the modified hash. The returned hash pointer is in general
318not the same as the hash pointer that was passed in. The input hash is
319consumed by the function, and the pointer to it must not be subsequently
320used. Use L</cophh_copy> if you need both hashes.
321
322The key is specified by I<keypv> and I<keylen>. If I<flags> has the
323C<COPHH_KEY_UTF8> bit set, the key octets are interpreted as UTF-8,
324otherwise they are interpreted as Latin-1. I<hash> is a precomputed
325hash of the key string, or zero if it has not been precomputed.
326
327=cut
328*/
329
330#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \
331 Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \
332 (SV *)NULL, flags)
333
334/*
ffd08bbf 335=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags
20439bc7
Z		 336
337Like L</cophh_delete_pvn>, but takes a literal string instead of a
338string/length pair, and no precomputed hash.
339
340=cut
341*/
342
343#define cophh_delete_pvs(cophh, key, flags) \
344 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \
345 (SV *)NULL, flags)
346
347/*
ffd08bbf 348=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags
20439bc7
Z		 349
350Like L</cophh_delete_pvn>, but takes a nul-terminated string instead of
351a string/length pair.
352
353=cut
354*/
355
356#define cophh_delete_pv(cophh, key, hash, flags) \
357 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
358
359/*
ffd08bbf 360=for apidoc Amx|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags
20439bc7
Z		 361
362Like L</cophh_delete_pvn>, but takes a Perl scalar instead of a
363string/length pair.
364
365=cut
366*/
367
368#define cophh_delete_sv(cophh, key, hash, flags) \
369 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags)
0d2925a6 370
5ac1e9b2 371#include "mydtrace.h"
0d2925a6 372
88df5f01
FC		 373struct cop {
374 BASEOP
375 /* On LP64 putting this here takes advantage of the fact that BASEOP isn't
376 an exact multiple of 8 bytes to save structure padding. */
377 line_t cop_line; /* line # of this command */
378 /* label for this construct is now stored in cop_hints_hash */
57843af0 379#ifdef USE_ITHREADS
88df5f01
FC		 380 PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the
381 package the line was compiled in */
1dc74fdb 382 char * cop_file; /* file name the following line # is from */
57843af0 383#else
88df5f01 384 HV * cop_stash; /* package line was compiled in */
79072805 385 GV * cop_filegv; /* file the following line # is from */
57843af0 386#endif
88df5f01
FC		 387 U32 cop_hints; /* hints bits from pragmata */
388 U32 cop_seq; /* parse sequence number */
389 /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */
390 STRLEN * cop_warnings; /* lexical warnings bitmask */
391 /* compile time state of %^H. See the comment in op.c for how this is
392 used to recreate a hash to return from caller. */
20439bc7 393 COPHH * cop_hints_hash;
79072805
LW		 394};
395
57843af0 396#ifdef USE_ITHREADS
1dc74fdb
FC		 397# define CopFILE(c) ((c)->cop_file)
398# define CopFILEGV(c) (CopFILE(c) \
399 ? gv_fetchfile(CopFILE(c)) : NULL)
400
401# ifdef NETWARE
402# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
d166b3ad 403# define CopFILE_setn(c,pv,l) ((c)->cop_file = savepvn((pv),(l)))
1dc74fdb
FC		 404# else
405# define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv))
406# define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l)))
407# endif
408
409# define CopFILESV(c) (CopFILE(c) \
410 ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
411# define CopFILEAV(c) (CopFILE(c) \
412 ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
413# define CopFILEAVx(c) (assert_(CopFILE(c)) \
414 GvAV(gv_fetchfile(CopFILE(c))))
083fcd59 415
d4d03940
FC		 416# define CopSTASH(c) PL_stashpad[(c)->cop_stashoff]
417# define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \
418 ? alloccopstash(hv) \
419 : 0)
1dc74fdb
FC		 420# ifdef NETWARE
421# define CopFILE_free(c) SAVECOPFILE_FREE(c)
422# else
423# define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
424# endif
57843af0
GS		 425#else
426# define CopFILEGV(c) ((c)->cop_filegv)
f4dd75d9 427# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
1dc74fdb
FC		 428# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
429# define CopFILE_setn(c,pv,l) CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0))
430# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
431# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
432# ifdef DEBUGGING
433# define CopFILEAVx(c) (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
434# else
435# define CopFILEAVx(c) (GvAV(CopFILEGV(c)))
436# endif
437# define CopFILE(c) (CopFILEGV(c) \
438 ? GvNAME(CopFILEGV(c))+2 : NULL)
57843af0 439# define CopSTASH(c) ((c)->cop_stash)
f4dd75d9 440# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
a0714e2c 441# define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
05ec9bb3 442
57843af0 443#endif /* USE_ITHREADS */
20439bc7 444
d4d03940
FC		 445#define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
446 /* cop_stash is not refcounted */
447#define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
448#define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
d4d03940 449
20439bc7
Z		 450#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash))
451#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h))
452
453/*
454=head1 COP Hint Reading
455*/
456
457/*
458=for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags
459
460Look up the hint entry in the cop I<cop> with the key specified by
461I<keypv> and I<keylen>. If I<flags> has the C<COPHH_KEY_UTF8> bit set,
462the key octets are interpreted as UTF-8, otherwise they are interpreted
463as Latin-1. I<hash> is a precomputed hash of the key string, or zero if
464it has not been precomputed. Returns a mortal scalar copy of the value
465associated with the key, or C<&PL_sv_placeholder> if there is no value
466associated with the key.
467
468=cut
469*/
470
471#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \
472 cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
473
474/*
475=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|const char *key|U32 flags
476
477Like L</cop_hints_fetch_pvn>, but takes a literal string instead of a
478string/length pair, and no precomputed hash.
479
480=cut
481*/
482
483#define cop_hints_fetch_pvs(cop, key, flags) \
484 cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags)
485
486/*
487=for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags
488
489Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead
490of a string/length pair.
491
492=cut
493*/
494
495#define cop_hints_fetch_pv(cop, key, hash, flags) \
496 cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags)
497
498/*
499=for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags
500
501Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a
502string/length pair.
503
504=cut
505*/
506
507#define cop_hints_fetch_sv(cop, key, hash, flags) \
508 cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags)
509
510/*
511=for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags
512
513Generates and returns a standard Perl hash representing the full set of
514hint entries in the cop I<cop>. I<flags> is currently unused and must
515be zero.
516
517=cut
518*/
519
520#define cop_hints_2hv(cop, flags) \
521 cophh_2hv(CopHINTHASH_get(cop), flags)
522
aebc0cbe 523#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
5db1eb8d
BF		 524#define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL)
525#define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags)
dca6062a 526#define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL)
57843af0 527
ed094faf 528#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv))
cc49e20b 529#define CopLINE(c) ((c)->cop_line)
57843af0
GS		 530#define CopLINE_inc(c) (++CopLINE(c))
531#define CopLINE_dec(c) (--CopLINE(c))
532#define CopLINE_set(c,l) (CopLINE(c) = (l))
cc49e20b 533
248c2a4d 534/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
e37778c2 535#define OutCopFILE(c) CopFILE(c)
248c2a4d 536
d5ec2987 537#define CopHINTS_get(c) ((c)->cop_hints + 0)
623e6609 538#define CopHINTS_set(c, h) STMT_START { \
d5ec2987 539 (c)->cop_hints = (h); \
623e6609
NC		 540 } STMT_END
541
79072805
LW		 542/*
543 * Here we have some enormously heavy (or at least ponderous) wizardry.
544 */
545
546/* subroutine context */
547struct block_sub {
f9c764c5 548 OP * retop; /* op to execute on exit from sub */
8e663997
NC		 549 /* Above here is the same for sub, format and eval. */
550 CV * cv;
f9c764c5 551 /* Above here is the same for sub and format. */
79072805
LW		 552 AV * savearray;
553 AV * argarray;
bb172083 554 I32 olddepth;
f3548bdc 555 PAD *oldcomppad;
f9c764c5
NC		 556};
557
558
559/* format context */
560struct block_format {
f39bc417 561 OP * retop; /* op to execute on exit from sub */
8e663997
NC		 562 /* Above here is the same for sub, format and eval. */
563 CV * cv;
f9c764c5
NC		 564 /* Above here is the same for sub and format. */
565 GV * gv;
566 GV * dfoutgv;
79072805
LW		 567};
568
b36bdeca
DM		 569/* base for the next two macros. Don't use directly.
570 * Note that the refcnt of the cv is incremented twice; The CX one is
571 * decremented by LEAVESUB, the other by LEAVE. */
572
ee98a1d6 573#define PUSHSUB_BASE(cx) \
88dbe4af
FC		 574 ENTRY_PROBE(CvNAMED(cv) \
575 ? HEK_KEY(CvNAME_HEK(cv)) \
576 : GvENAME(CvGV(cv)), \
c6903450 577 CopFILE((const COP *)CvSTART(cv)), \
3e2413e5
DL		 578 CopLINE((const COP *)CvSTART(cv)), \
579 CopSTASHPV((const COP *)CvSTART(cv))); \
5ac1e9b2 580 \
79072805 581 cx->blk_sub.cv = cv; \
b8f55b69 582 cx->blk_sub.olddepth = CvDEPTH(cv); \
ae423868 583 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; \
5f66b61c 584 cx->blk_sub.retop = NULL; \
b36bdeca 585 if (!CvDEPTH(cv)) { \
74c765eb
AL		 586 SvREFCNT_inc_simple_void_NN(cv); \
587 SvREFCNT_inc_simple_void_NN(cv); \
b36bdeca
DM		 588 SAVEFREESV(cv); \
589 }
590
4587c532 591#define PUSHSUB_GET_LVALUE_MASK(func) \
777d9014
FC		 592 /* If the context is indeterminate, then only the lvalue */ \
593 /* flags that the caller also has are applicable. */ \
4587c532 594 ( \
777d9014
FC		 595 (PL_op->op_flags & OPf_WANT) \
596 ? OPpENTERSUB_LVAL_MASK \
597 : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \
4587c532
FC		 598 ? 0 : (U8)func(aTHX) \
599 )
600
601#define PUSHSUB(cx) \
602 { \
603 U8 phlags = PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \
ee98a1d6 604 PUSHSUB_BASE(cx) \
446d0787 605 cx->blk_u16 = PL_op->op_private & \
0e9700df 606 (phlags|OPpDEREF); \
777d9014 607 }
79072805 608
ee98a1d6
DM		 609/* variant for use by OP_DBSTATE, where op_private holds hint bits */
610#define PUSHSUB_DB(cx) \
611 PUSHSUB_BASE(cx) \
446d0787 612 cx->blk_u16 = 0;
ee98a1d6
DM		 613
614
10067d9a 615#define PUSHFORMAT(cx, retop) \
f9c764c5
NC		 616 cx->blk_format.cv = cv; \
617 cx->blk_format.gv = gv; \
618 cx->blk_format.retop = (retop); \
f9c764c5 619 cx->blk_format.dfoutgv = PL_defoutgv; \
1956db7e 620 cx->blk_u16 = 0; \
ee23553f 621 if (!CvDEPTH(cv)) SvREFCNT_inc_simple_void_NN(cv); \
f32c7e86 622 CvDEPTH(cv)++; \
f9c764c5 623 SvREFCNT_inc_void(cx->blk_format.dfoutgv)
79072805 624
3db8f154 625#define POP_SAVEARRAY() \
6d4ff0d2 626 STMT_START { \
3280af22 627 SvREFCNT_dec(GvAV(PL_defgv)); \
a8bba7fa 628 GvAV(PL_defgv) = cx->blk_sub.savearray; \
6d4ff0d2 629 } STMT_END
6d4ff0d2 630
ecf8e9dd 631/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
8e09340b
GS		 632 * leave any (a fast av_clear(ary), basically) */
633#define CLEAR_ARGARRAY(ary) \
634 STMT_START { \
635 AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \
9c6bc640 636 AvARRAY(ary) = AvALLOC(ary); \
8e09340b
GS		 637 AvFILLp(ary) = -1; \
638 } STMT_END
7766f137 639
b0d9ce38
GS		 640#define POPSUB(cx,sv) \
641 STMT_START { \
25375124 642 const I32 olddepth = cx->blk_sub.olddepth; \
1956db7e
DM		 643 if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
644 cx->blk_u16 |= CxPOPSUB_DONE; \
88dbe4af
FC		 645 RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \
646 ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \
647 : GvENAME(CvGV(cx->blk_sub.cv)), \
8f629a87 648 CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
3e2413e5
DL		 649 CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \
650 CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \
5ac1e9b2 651 \
bafb2adc 652 if (CxHASARGS(cx)) { \
7766f137 653 POP_SAVEARRAY(); \
d8b46c1b 654 /* abandon @_ if it got reified */ \
a8bba7fa 655 if (AvREAL(cx->blk_sub.argarray)) { \
e2d306cb 656 const SSize_t fill = AvFILLp(cx->blk_sub.argarray); \
2f995715 657 SvREFCNT_dec_NN(cx->blk_sub.argarray); \
a8bba7fa
GS		 658 cx->blk_sub.argarray = newAV(); \
659 av_extend(cx->blk_sub.argarray, fill); \
11ca45c0 660 AvREIFY_only(cx->blk_sub.argarray); \
b1bc3f34 661 CX_CURPAD_SV(cx->blk_sub, 0) = MUTABLE_SV(cx->blk_sub.argarray); \
d8b46c1b 662 } \
7766f137 663 else { \
8e09340b 664 CLEAR_ARGARRAY(cx->blk_sub.argarray); \
7766f137 665 } \
79072805 666 } \
1956db7e 667 } \
b1bc3f34 668 sv = MUTABLE_SV(cx->blk_sub.cv); \
25375124
FC		 669 LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]); \
670 if (sv && (CvDEPTH((const CV*)sv) = olddepth)) \
a0714e2c 671 sv = NULL; \
b0d9ce38
GS		 672 } STMT_END
673
674#define LEAVESUB(sv) \
675 STMT_START { \
d2687c98 676 SvREFCNT_dec(sv); \
b0d9ce38 677 } STMT_END
79072805
LW		 678
679#define POPFORMAT(cx) \
25375124 680 STMT_START { \
1956db7e 681 if (!(cx->blk_u16 & CxPOPSUB_DONE)) { \
25375124
FC		 682 CV * const cv = cx->blk_format.cv; \
683 GV * const dfuot = cx->blk_format.dfoutgv; \
1956db7e 684 cx->blk_u16 |= CxPOPSUB_DONE; \
25375124
FC		 685 setdefout(dfuot); \
686 LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]); \
687 if (!--CvDEPTH(cv)) \
2f995715 688 SvREFCNT_dec_NN(cx->blk_format.cv); \
25375124 689 SvREFCNT_dec_NN(dfuot); \
1956db7e 690 } \
25375124 691 } STMT_END
79072805
LW		 692
693/* eval context */
694struct block_eval {
8e663997
NC		 695 OP * retop; /* op to execute on exit from eval */
696 /* Above here is the same for sub, format and eval. */
0f79a09d 697 SV * old_namesv;
79072805 698 OP * old_eval_root;
748a9306 699 SV * cur_text;
2090ab20 700 CV * cv;
abd70938 701 JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */
79072805
LW		 702};
703
17347a51
NC		 704/* If we ever need more than 512 op types, change the shift from 7.
705 blku_gimme is actually also only 2 bits, so could be merged with something.
706*/
707
708#define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x7F)
709#define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7)
85a64632 710
6b75f042 711#define PUSHEVAL(cx,n) \
0f79a09d 712 STMT_START { \
17347a51
NC		 713 assert(!(PL_in_eval & ~0x7F)); \
714 assert(!(PL_op->op_type & ~0x1FF)); \
715 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); \
a0714e2c 716 cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL); \
a8bba7fa 717 cx->blk_eval.old_eval_root = PL_eval_root; \
bdc0bf6f 718 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL; \
601f1833 719 cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */ \
5f66b61c 720 cx->blk_eval.retop = NULL; \
abd70938 721 cx->blk_eval.cur_top_env = PL_top_env; \
0f79a09d 722 } STMT_END
79072805
LW		 723
724#define POPEVAL(cx) \
0f79a09d 725 STMT_START { \
85a64632
NC		 726 PL_in_eval = CxOLD_IN_EVAL(cx); \
727 optype = CxOLD_OP_TYPE(cx); \
7766f137 728 PL_eval_root = cx->blk_eval.old_eval_root; \
d37427bc 729 if (cx->blk_eval.cur_text && SvSCREAM(cx->blk_eval.cur_text)) \
2f995715 730 SvREFCNT_dec_NN(cx->blk_eval.cur_text); \
0f79a09d
GS		 731 if (cx->blk_eval.old_namesv) \
732 sv_2mortal(cx->blk_eval.old_namesv); \
733 } STMT_END
79072805
LW		 734
735/* loop context */
736struct block_loop {
79072805 737 I32 resetsp;
022eaa24 738 LOOP * my_op; /* My op, that contains redo, next and last ops. */
df530c37
DM		 739 union { /* different ways of locating the iteration variable */
740 SV **svp;
741 GV *gv;
742 PAD *oldcomppad; /* only used in ITHREADS */
743 } itervar_u;
493b0a3c 744 union {
d01136d6
BS		 745 struct { /* valid if type is LOOP_FOR or LOOP_PLAIN (but {NULL,0})*/
746 AV * ary; /* use the stack if this is NULL */
747 IV ix;
748 } ary;
749 struct { /* valid if type is LOOP_LAZYIV */
750 IV cur;
751 IV end;
752 } lazyiv;
753 struct { /* valid if type if LOOP_LAZYSV */
754 SV * cur;
755 SV * end; /* maxiumum value (or minimum in reverse) */
756 } lazysv;
757 } state_u;
79072805
LW		 758};
759
7766f137 760#ifdef USE_ITHREADS
f83b46a0
DM		 761# define CxITERVAR_PADSV(c) \
762 &CX_CURPAD_SV( (c)->blk_loop.itervar_u, (c)->blk_loop.my_op->op_targ)
763#else
764# define CxITERVAR_PADSV(c) ((c)->blk_loop.itervar_u.svp)
765#endif
766
767#define CxITERVAR(c) \
df530c37 768 ((c)->blk_loop.itervar_u.oldcomppad \
e846cb92 769 ? (CxPADLOOP(c) \
f83b46a0 770 ? CxITERVAR_PADSV(c) \
d39c26a6
FC		 771 : isGV((c)->blk_loop.itervar_u.gv) \
772 ? &GvSV((c)->blk_loop.itervar_u.gv) \
773 : (SV **)&(c)->blk_loop.itervar_u.gv) \
7766f137 774 : (SV**)NULL)
f83b46a0 775
b1cf8b36 776#define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop))
5db1eb8d
BF		 777#define CxLABEL_len(c,len) (0 + CopLABEL_len((c)->blk_oldcop, len))
778#define CxLABEL_len_flags(c,len,flags) (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
ae423868 779#define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
1956db7e
DM		 780#define CxLVAL(c) (0 + ((c)->blk_u16 & 0xff))
781/* POPSUB has already been performed on this context frame */
782#define CxPOPSUB_DONE 0x100
783
7766f137 784
3b719c58
NC		 785#define PUSHLOOP_PLAIN(cx, s) \
786 cx->blk_loop.resetsp = s - PL_stack_base; \
787 cx->blk_loop.my_op = cLOOP; \
d01136d6
BS		 788 cx->blk_loop.state_u.ary.ary = NULL; \
789 cx->blk_loop.state_u.ary.ix = 0; \
df530c37 790 cx->blk_loop.itervar_u.svp = NULL;
3b719c58 791
df530c37 792#define PUSHLOOP_FOR(cx, ivar, s) \
38a230cb 793 cx->blk_loop.resetsp = s - PL_stack_base; \
022eaa24 794 cx->blk_loop.my_op = cLOOP; \
d01136d6
BS		 795 cx->blk_loop.state_u.ary.ary = NULL; \
796 cx->blk_loop.state_u.ary.ix = 0; \
df530c37 797 cx->blk_loop.itervar_u.svp = (SV**)(ivar);
79072805
LW		 798
799#define POPLOOP(cx) \
d01136d6 800 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \
2f995715
FC		 801 SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.cur); \
802 SvREFCNT_dec_NN(cx->blk_loop.state_u.lazysv.end); \
d01136d6 803 } \
d01136d6
BS		 804 if (CxTYPE(cx) == CXt_LOOP_FOR) \
805 SvREFCNT_dec(cx->blk_loop.state_u.ary.ary);
79072805 806
0d863452
RH		 807/* given/when context */
808struct block_givwhen {
809 OP *leave_op;
810};
811
812#define PUSHGIVEN(cx) \
813 cx->blk_givwhen.leave_op = cLOGOP->op_other;
814
815#define PUSHWHEN PUSHGIVEN
816
79072805
LW		 817/* context common to subroutines, evals and loops */
818struct block {
446d0787 819 U8 blku_type; /* what kind of context this is */
2e0df0e8 820 U8 blku_gimme; /* is this block running in list context? */
17347a51 821 U16 blku_u16; /* used by block_sub and block_eval (so far) */
79072805
LW		 822 I32 blku_oldsp; /* stack pointer to copy stuff down to */
823 COP * blku_oldcop; /* old curcop pointer */
79072805
LW		 824 I32 blku_oldmarksp; /* mark stack index */
825 I32 blku_oldscopesp; /* scope stack index */
826 PMOP * blku_oldpm; /* values of pattern match vars */
79072805
LW		 827
828 union {
829 struct block_sub blku_sub;
f9c764c5 830 struct block_format blku_format;
79072805
LW		 831 struct block_eval blku_eval;
832 struct block_loop blku_loop;
0d863452 833 struct block_givwhen blku_givwhen;
79072805
LW		 834 } blk_u;
835};
836#define blk_oldsp cx_u.cx_blk.blku_oldsp
837#define blk_oldcop cx_u.cx_blk.blku_oldcop
79072805
LW		 838#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
839#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
840#define blk_oldpm cx_u.cx_blk.blku_oldpm
841#define blk_gimme cx_u.cx_blk.blku_gimme
446d0787 842#define blk_u16 cx_u.cx_blk.blku_u16
79072805 843#define blk_sub cx_u.cx_blk.blk_u.blku_sub
f9c764c5 844#define blk_format cx_u.cx_blk.blk_u.blku_format
79072805
LW		 845#define blk_eval cx_u.cx_blk.blk_u.blku_eval
846#define blk_loop cx_u.cx_blk.blk_u.blku_loop
0d863452 847#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
79072805 848
1c98cc53 849#define DEBUG_CX(action) \
d9f81b50 850 DEBUG_l( \
1c98cc53
DM		 851 Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) at %s:%d\n", \
852 (long)cxstack_ix, \
853 action, \
854 PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
855 (long)PL_scopestack_ix, \
856 (long)(cxstack[cxstack_ix].blk_oldscopesp), \
d9f81b50 857 __FILE__, __LINE__));
1c98cc53 858
79072805 859/* Enter a block. */
8990e307 860#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
79072805 861 cx->cx_type = t, \
3280af22
NIS		 862 cx->blk_oldsp = sp - PL_stack_base, \
863 cx->blk_oldcop = PL_curcop, \
1aff0e91 864 cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
3280af22 865 cx->blk_oldscopesp = PL_scopestack_ix, \
3280af22 866 cx->blk_oldpm = PL_curpm, \
eb160463 867 cx->blk_gimme = (U8)gimme; \
1c98cc53 868 DEBUG_CX("PUSH");
79072805
LW		 869
870/* Exit a block (RETURN and LAST). */
1c98cc53
DM		 871#define POPBLOCK(cx,pm) \
872 DEBUG_CX("POP"); \
873 cx = &cxstack[cxstack_ix--], \
1aff0e91 874 newsp = PL_stack_base + cx->blk_oldsp, \
3280af22
NIS		 875 PL_curcop = cx->blk_oldcop, \
876 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
877 PL_scopestack_ix = cx->blk_oldscopesp, \
3280af22 878 pm = cx->blk_oldpm, \
1c98cc53 879 gimme = cx->blk_gimme;
79072805
LW		 880
881/* Continue a block elsewhere (NEXT and REDO). */
1c98cc53
DM		 882#define TOPBLOCK(cx) \
883 DEBUG_CX("TOP"); \
884 cx = &cxstack[cxstack_ix], \
1aff0e91 885 PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
3280af22
NIS		 886 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
887 PL_scopestack_ix = cx->blk_oldscopesp, \
1c98cc53 888 PL_curpm = cx->blk_oldpm;
79072805
LW		 889
890/* substitution context */
891struct subst {
446d0787 892 U8 sbu_type; /* what kind of context this is */
1ed74d04 893 U8 sbu_rflags;
446d0787 894 U16 sbu_rxtainted; /* matches struct block */
4633a7c4 895 I32 sbu_oldsave;
3c6ef0a5
FC		 896 SSize_t sbu_iters;
897 SSize_t sbu_maxiters;
79072805
LW		 898 char * sbu_orig;
899 SV * sbu_dstr;
900 SV * sbu_targ;
901 char * sbu_s;
902 char * sbu_m;
903 char * sbu_strend;
c90c0ff4 904 void * sbu_rxres;
c07a80fd 905 REGEXP * sbu_rx;
79072805
LW		 906};
907#define sb_iters cx_u.cx_subst.sbu_iters
908#define sb_maxiters cx_u.cx_subst.sbu_maxiters
22e551b9 909#define sb_rflags cx_u.cx_subst.sbu_rflags
4633a7c4 910#define sb_oldsave cx_u.cx_subst.sbu_oldsave
71be2cbc 911#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
79072805
LW		 912#define sb_orig cx_u.cx_subst.sbu_orig
913#define sb_dstr cx_u.cx_subst.sbu_dstr
914#define sb_targ cx_u.cx_subst.sbu_targ
915#define sb_s cx_u.cx_subst.sbu_s
916#define sb_m cx_u.cx_subst.sbu_m
917#define sb_strend cx_u.cx_subst.sbu_strend
c90c0ff4 918#define sb_rxres cx_u.cx_subst.sbu_rxres
c07a80fd 919#define sb_rx cx_u.cx_subst.sbu_rx
79072805 920
9c105995
NC		 921#ifdef PERL_CORE
922# define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
79072805
LW		 923 cx->sb_iters = iters, \
924 cx->sb_maxiters = maxiters, \
22e551b9 925 cx->sb_rflags = r_flags, \
4633a7c4 926 cx->sb_oldsave = oldsave, \
71be2cbc 927 cx->sb_rxtainted = rxtainted, \
79072805
LW		 928 cx->sb_orig = orig, \
929 cx->sb_dstr = dstr, \
930 cx->sb_targ = targ, \
931 cx->sb_s = s, \
932 cx->sb_m = m, \
933 cx->sb_strend = strend, \
4608196e 934 cx->sb_rxres = NULL, \
c07a80fd 935 cx->sb_rx = rx, \
1ed74d04 936 cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \
e22ae1e2 937 rxres_save(&cx->sb_rxres, rx); \
b69b0499 938 (void)ReREFCNT_inc(rx)
79072805 939
9c105995 940# define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
e22ae1e2
DM		 941 rxres_free(&cx->sb_rxres); \
942 ReREFCNT_dec(cx->sb_rx)
9c105995
NC		 943#endif
944
945#define CxONCE(cx) ((cx)->cx_type & CXp_ONCE)
79072805
LW		 946
947struct context {
79072805
LW		 948 union {
949 struct block cx_blk;
950 struct subst cx_subst;
951 } cx_u;
952};
2e0df0e8 953#define cx_type cx_u.cx_subst.sbu_type
6b35e009 954
76753e7f
NC		 955/* If you re-order these, there is also an array of uppercase names in perl.h
956 and a static array of context names in pp_ctl.c */
3701055e 957#define CXTYPEMASK 0xf
79072805 958#define CXt_NULL 0
76753e7f
NC		 959#define CXt_WHEN 1
960#define CXt_BLOCK 2
961/* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
962 jump table in pp_ctl.c
963 The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
964*/
965#define CXt_GIVEN 3
c6fdafd0 966/* This is first so that CXt_LOOP_FOR|CXt_LOOP_LAZYIV is CXt_LOOP_LAZYIV */
76753e7f
NC		 967#define CXt_LOOP_FOR 4
968#define CXt_LOOP_PLAIN 5
969#define CXt_LOOP_LAZYSV 6
970#define CXt_LOOP_LAZYIV 7
971#define CXt_SUB 8
972#define CXt_FORMAT 9
973#define CXt_EVAL 10
974#define CXt_SUBST 11
975/* SUBST doesn't feature in all switch statements. */
79072805 976
3701055e
NC		 977/* private flags for CXt_SUB and CXt_NULL
978 However, this is checked in many places which do not check the type, so
979 this bit needs to be kept clear for most everything else. For reasons I
980 haven't investigated, it can coexist with CXp_FOR_DEF */
1f27d788
NC		 981#define CXp_MULTICALL 0x10 /* part of a multicall (so don't
982 tear down context on exit). */
9850bf21 983
ae423868 984/* private flags for CXt_SUB and CXt_FORMAT */
1f27d788 985#define CXp_HASARGS 0x20
b0065247
DM		 986#define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */
987#define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */
ae423868 988
6b35e009 989/* private flags for CXt_EVAL */
1f27d788
NC		 990#define CXp_REAL 0x20 /* truly eval'', not a lookalike */
991#define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */
6b35e009 992
7766f137 993/* private flags for CXt_LOOP */
1f27d788 994#define CXp_FOR_DEF 0x10 /* foreach using $_ */
d39c26a6 995#define CXp_FOR_LVREF 0x20 /* foreach using \$var */
56b98d0f 996#define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ)
e846cb92 997
1ed74d04
NC		 998/* private flags for CXt_SUBST */
999#define CXp_ONCE 0x10 /* What was sbu_once in struct subst */
7766f137 1000
6b35e009 1001#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
76753e7f 1002#define CxTYPE_is_LOOP(c) (((c)->cx_type & 0xC) == 0x4)
9850bf21
RH		 1003#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \
1004 == CXp_MULTICALL)
0588a150 1005#define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \
7766f137 1006 == (CXt_EVAL|CXp_REAL))
0588a150 1007#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \
1d76a5c3 1008 == (CXt_EVAL|CXp_TRYBLOCK))
3b719c58
NC		 1009#define CxFOREACH(c) (CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN)
1010#define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \
1011 && ((c)->cx_type & CXp_FOR_DEF))
6b35e009 1012
109bf713 1013#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
79072805 1014
ccfc67b7
JH		 1015/*
1016=head1 "Gimme" Values
1017*/
954c1994
GS		 1018
1019/*
1020=for apidoc AmU||G_SCALAR
1021Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and
1022L<perlcall>.
1023
1024=for apidoc AmU||G_ARRAY
91e74348 1025Used to indicate list context. See C<GIMME_V>, C<GIMME> and
954c1994
GS		 1026L<perlcall>.
1027
1028=for apidoc AmU||G_VOID
1029Used to indicate void context. See C<GIMME_V> and L<perlcall>.
1030
1031=for apidoc AmU||G_DISCARD
1032Indicates that arguments returned from a callback should be discarded. See
1033L<perlcall>.
1034
1035=for apidoc AmU||G_EVAL
1036
1037Used to force a Perl C<eval> wrapper around a callback. See
1038L<perlcall>.
1039
1040=for apidoc AmU||G_NOARGS
1041
1042Indicates that no arguments are being sent to a callback. See
1043L<perlcall>.
1044
1045=cut
1046*/
1047
2f8edad0
NC		 1048#define G_SCALAR 2
1049#define G_ARRAY 3
1050#define G_VOID 1
1051#define G_WANT 3
79072805 1052
864dbfa3 1053/* extra flags for Perl_call_* routines */
2f8edad0 1054#define G_DISCARD 4 /* Call FREETMPS.
b54b4831
NC		 1055 Don't change this without consulting the
1056 hash actions codes defined in hv.h */
2f8edad0
NC		 1057#define G_EVAL 8 /* Assume eval {} around subroutine call. */
1058#define G_NOARGS 16 /* Don't construct a @_ array. */
7ce09284 1059#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
2f8edad0
NC		 1060#define G_NODEBUG 64 /* Disable debugging at toplevel. */
1061#define G_METHOD 128 /* Calling method. */
c40f1585 1062#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
edb2152a 1063 fold_constants. */
67549bd2
NC		 1064#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
1065 A special case for UNSHIFT in
1066 Perl_magic_methcall(). */
d1d7a15d
NC		 1067#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
1068 Perl_magic_methcall(). */
a1941760 1069#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
c106c2be 1070#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
e336de0d 1071
faef0170
HS		 1072/* flag bits for PL_in_eval */
1073#define EVAL_NULL 0 /* not in an eval */
1074#define EVAL_INEVAL 1 /* some enclosing scope is an eval */
1075#define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */
864dbfa3 1076#define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */
6dc8a9e4 1077#define EVAL_INREQUIRE 8 /* The code is being required. */
a1941760 1078#define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */
faef0170 1079
e336de0d
GS		 1080/* Support for switching (stack and block) contexts.
1081 * This ensures magic doesn't invalidate local stack and cx pointers.
1082 */
1083
e788e7d3
GS		 1084#define PERLSI_UNKNOWN -1
1085#define PERLSI_UNDEF 0
1086#define PERLSI_MAIN 1
1087#define PERLSI_MAGIC 2
1088#define PERLSI_SORT 3
1089#define PERLSI_SIGNAL 4
1090#define PERLSI_OVERLOAD 5
1091#define PERLSI_DESTROY 6
1092#define PERLSI_WARNHOOK 7
1093#define PERLSI_DIEHOOK 8
1094#define PERLSI_REQUIRE 9
e1a10f35 1095#define PERLSI_MULTICALL 10
e336de0d
GS		 1096
1097struct stackinfo {
1098 AV * si_stack; /* stack for current runlevel */
1099 PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
9bd87817
NC		 1100 struct stackinfo * si_prev;
1101 struct stackinfo * si_next;
e336de0d
GS		 1102 I32 si_cxix; /* current context index */
1103 I32 si_cxmax; /* maximum allocated index */
1104 I32 si_type; /* type of runlevel */
ce2f7c3b 1105 I32 si_markoff; /* offset where markstack begins for us.
e336de0d
GS		 1106 * currently used only with DEBUGGING,
1107 * but not #ifdef-ed for bincompat */
1108};
1109
1110typedef struct stackinfo PERL_SI;
1111
3280af22
NIS		 1112#define cxstack (PL_curstackinfo->si_cxstack)
1113#define cxstack_ix (PL_curstackinfo->si_cxix)
1114#define cxstack_max (PL_curstackinfo->si_cxmax)
e336de0d
GS		 1115
1116#ifdef DEBUGGING
ce2f7c3b
GS		 1117# define SET_MARK_OFFSET \
1118 PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
e336de0d 1119#else
ce2f7c3b 1120# define SET_MARK_OFFSET NOOP
e336de0d
GS		 1121#endif
1122
d3acc0f7 1123#define PUSHSTACKi(type) \
e336de0d 1124 STMT_START { \
3280af22 1125 PERL_SI *next = PL_curstackinfo->si_next; \
1c98cc53
DM		 1126 DEBUG_l({ \
1127 int i = 0; PERL_SI *p = PL_curstackinfo; \
1128 while (p) { i++; p = p->si_prev; } \
1129 Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
1130 i, __FILE__, __LINE__);}) \
e336de0d
GS		 1131 if (!next) { \
1132 next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
3280af22
NIS		 1133 next->si_prev = PL_curstackinfo; \
1134 PL_curstackinfo->si_next = next; \
e336de0d
GS		 1135 } \
1136 next->si_type = type; \
1137 next->si_cxix = -1; \
1138 AvFILLp(next->si_stack) = 0; \
3280af22
NIS		 1139 SWITCHSTACK(PL_curstack,next->si_stack); \
1140 PL_curstackinfo = next; \
ce2f7c3b 1141 SET_MARK_OFFSET; \
e336de0d
GS		 1142 } STMT_END
1143
e788e7d3 1144#define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
d3acc0f7 1145
3095d977
GS		 1146/* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
1147 * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
d3acc0f7 1148#define POPSTACK \
e336de0d 1149 STMT_START { \
39644a26 1150 dSP; \
c4420975 1151 PERL_SI * const prev = PL_curstackinfo->si_prev; \
1c98cc53
DM		 1152 DEBUG_l({ \
1153 int i = -1; PERL_SI *p = PL_curstackinfo; \
1154 while (p) { i++; p = p->si_prev; } \
1155 Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
1156 i, __FILE__, __LINE__);}) \
e336de0d 1157 if (!prev) { \
3d04513d 1158 Perl_croak_popstack(); \
e336de0d 1159 } \
3280af22 1160 SWITCHSTACK(PL_curstack,prev->si_stack); \
e336de0d 1161 /* don't free prev here, free them all at the END{} */ \
3280af22 1162 PL_curstackinfo = prev; \
e336de0d
GS		 1163 } STMT_END
1164
1165#define POPSTACK_TO(s) \
1166 STMT_START { \
3280af22 1167 while (PL_curstack != s) { \
bac4b2ad 1168 dounwind(-1); \
d3acc0f7 1169 POPSTACK; \
bac4b2ad 1170 } \
e336de0d 1171 } STMT_END
923e4eb5
JH		 1172
1173#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
1174#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
1175
9850bf21
RH		 1176/*
1177=head1 Multicall Functions
1178
1179=for apidoc Ams||dMULTICALL
72d33970 1180Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21
RH		 1181
1182=for apidoc Ams||PUSH_MULTICALL
1183Opening bracket for a lightweight callback.
0eda4409 1184See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21
RH		 1185
1186=for apidoc Ams||MULTICALL
72d33970 1187Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21
RH		 1188
1189=for apidoc Ams||POP_MULTICALL
1190Closing bracket for a lightweight callback.
0eda4409 1191See L<perlcall/LIGHTWEIGHT CALLBACKS>.
9850bf21
RH		 1192
1193=cut
1194*/
1195
1196#define dMULTICALL \
1197 SV **newsp; /* set by POPBLOCK */ \
1198 PERL_CONTEXT *cx; \
82f35e8b 1199 CV *multicall_cv; \
9850bf21
RH		 1200 OP *multicall_cop; \
1201 bool multicall_oldcatch; \
1202 U8 hasargs = 0 /* used by PUSHSUB */
1203
82f35e8b 1204#define PUSH_MULTICALL(the_cv) \
b0065247 1205 PUSH_MULTICALL_FLAGS(the_cv, 0)
81ed78b2 1206
b0065247
DM		 1207/* Like PUSH_MULTICALL, but allows you to specify extra flags
1208 * for the CX stack entry (this isn't part of the public API) */
81ed78b2 1209
b0065247 1210#define PUSH_MULTICALL_FLAGS(the_cv, flags) \
9850bf21 1211 STMT_START { \
0bcc34c2
AL		 1212 CV * const _nOnclAshIngNamE_ = the_cv; \
1213 CV * const cv = _nOnclAshIngNamE_; \
b70d5558 1214 PADLIST * const padlist = CvPADLIST(cv); \
9850bf21
RH		 1215 ENTER; \
1216 multicall_oldcatch = CATCH_GET; \
1217 SAVETMPS; SAVEVPTR(PL_op); \
1218 CATCH_SET(TRUE); \
e1a10f35 1219 PUSHSTACKi(PERLSI_MULTICALL); \
b0065247 1220 PUSHBLOCK(cx, (CXt_SUB|CXp_MULTICALL|flags), PL_stack_sp); \
9850bf21 1221 PUSHSUB(cx); \
b0065247
DM		 1222 if (!(flags & CXp_SUB_RE_FAKE)) \
1223 CvDEPTH(cv)++; \
81ed78b2 1224 if (CvDEPTH(cv) >= 2) { \
9850bf21
RH		 1225 PERL_STACK_OVERFLOW_CHECK(); \
1226 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
1227 } \
1228 SAVECOMPPAD(); \
1229 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
82f35e8b 1230 multicall_cv = cv; \
9850bf21
RH		 1231 multicall_cop = CvSTART(cv); \
1232 } STMT_END
1233
1234#define MULTICALL \
1235 STMT_START { \
1236 PL_op = multicall_cop; \
1237 CALLRUNOPS(aTHX); \
1238 } STMT_END
1239
1240#define POP_MULTICALL \
1241 STMT_START { \
3d26b81e
DM		 1242 cx = &cxstack[cxstack_ix]; \
1243 if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
81ed78b2
DM		 1244 LEAVESUB(multicall_cv); \
1245 } \
9850bf21 1246 POPBLOCK(cx,PL_curpm); \
1bbbfc50 1247 POPSTACK; \
9850bf21
RH		 1248 CATCH_SET(multicall_oldcatch); \
1249 LEAVE; \
1bbbfc50 1250 SPAGAIN; \
9850bf21 1251 } STMT_END
b3ca2e83 1252
81ed78b2
DM		 1253/* Change the CV of an already-pushed MULTICALL CxSUB block.
1254 * (this isn't part of the public API) */
1255
b0065247 1256#define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
81ed78b2
DM		 1257 STMT_START { \
1258 CV * const _nOnclAshIngNamE_ = the_cv; \
1259 CV * const cv = _nOnclAshIngNamE_; \
b70d5558 1260 PADLIST * const padlist = CvPADLIST(cv); \
81ed78b2
DM		 1261 cx = &cxstack[cxstack_ix]; \
1262 assert(cx->cx_type & CXp_MULTICALL); \
1263 if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
1264 LEAVESUB(multicall_cv); \
1265 } \
b0065247 1266 cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \
81ed78b2 1267 PUSHSUB(cx); \
b0065247
DM		 1268 if (!(flags & CXp_SUB_RE_FAKE)) \
1269 CvDEPTH(cv)++; \
81ed78b2
DM		 1270 if (CvDEPTH(cv) >= 2) { \
1271 PERL_STACK_OVERFLOW_CHECK(); \
1272 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
1273 } \
1274 SAVECOMPPAD(); \
1275 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
1276 multicall_cv = cv; \
1277 multicall_cop = CvSTART(cv); \
1278 } STMT_END
b3ca2e83 1279/*
14d04a33 1280 * ex: set ts=8 sts=4 sw=4 et:
b3ca2e83 1281 */
Unnamed repository; edit this file 'description' to name the repository.