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