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; /* longjmp()s must be caught locally */ 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 * Message-Id: 20040713143217.GB1424@plum.flirble.org 84 * https://www.nntp.perl.org/group/perl.perl5.porters/2004/07/msg93041.html 85 * 86 * Joshua's original patches (which weren't applied) and discussion: 87 * 88 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html 89 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html 90 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html 91 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html 92 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html 93 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html 94 * 95 * Chip's reworked patch and discussion: 96 * 97 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html 98 * 99 * The flaw in these patches (which went unnoticed at the time) was 100 * that they moved some code that could potentially die() out of the 101 * region protected by the setjmp()s. This caused exceptions within 102 * END blocks and such to not be handled by the correct setjmp(). 103 * 104 * The original patches that introduces flexible exceptions were: 105 * 106 * https://github.com/Perl/perl5/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929 107 * https://github.com/Perl/perl5/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a 108 * 109 */ 110 111 #define dJMPENV JMPENV cur_env 112 113 #define JMPENV_PUSH(v) \ 114 STMT_START { \ 115 DEBUG_l({ \ 116 int i = 0; \ 117 JMPENV *p = PL_top_env; \ 118 while (p) { i++; p = p->je_prev; } \ 119 Perl_deb(aTHX_ "JMPENV_PUSH pre level=%d in %s at %s:%d\n", \ 120 i, SAFE_FUNCTION__, __FILE__, __LINE__); \ 121 }); \ 122 cur_env.je_prev = PL_top_env; \ 123 JE_OLD_STACK_HWM_save(cur_env); \ 124 /* setjmp() is callable in limited contexts which does not */ \ 125 /* include assignment, so switch() instead */ \ 126 switch (PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK)) { \ 127 case 0: cur_env.je_ret = 0; break; \ 128 case 1: cur_env.je_ret = 1; break; \ 129 case 2: cur_env.je_ret = 2; break; \ 130 case 3: cur_env.je_ret = 3; break; \ 131 default: Perl_croak(aTHX_ "panic: unexpected setjmp() result\n"); \ 132 } \ 133 JE_OLD_STACK_HWM_restore(cur_env); \ 134 PL_top_env = &cur_env; \ 135 cur_env.je_mustcatch = FALSE; \ 136 cur_env.je_old_delaymagic = PL_delaymagic; \ 137 DEBUG_l({ \ 138 int i = 0; \ 139 JMPENV *p = PL_top_env; \ 140 while (p) { i++; p = p->je_prev; } \ 141 Perl_deb(aTHX_ "JMPENV_PUSH level=%d ret=%d in %s at %s:%d\n", \ 142 i, cur_env.je_ret, SAFE_FUNCTION__, __FILE__, __LINE__); \ 143 }); \ 144 (v) = cur_env.je_ret; \ 145 } STMT_END 146 147 #define JMPENV_POP \ 148 STMT_START { \ 149 DEBUG_l({ \ 150 int i = -1; JMPENV *p = PL_top_env; \ 151 while (p) { i++; p = p->je_prev; } \ 152 Perl_deb(aTHX_ "JMPENV_POP level=%d in %s at %s:%d\n", \ 153 i, SAFE_FUNCTION__, __FILE__, __LINE__);}) \ 154 assert(PL_top_env == &cur_env); \ 155 PL_delaymagic = cur_env.je_old_delaymagic; \ 156 PL_top_env = cur_env.je_prev; \ 157 } STMT_END 158 159 #define JMPENV_JUMP(v) \ 160 STMT_START { \ 161 DEBUG_l({ \ 162 int i = -1; JMPENV *p = PL_top_env; \ 163 while (p) { i++; p = p->je_prev; } \ 164 Perl_deb(aTHX_ "JMPENV_JUMP(%d) level=%d in %s at %s:%d\n", \ 165 (int)(v), i, SAFE_FUNCTION__, __FILE__, __LINE__);}) \ 166 if (PL_top_env->je_prev) { \ 167 assert((v) >= 0 && (v) <= 3); \ 168 PerlProc_longjmp(PL_top_env->je_buf, (v)); \ 169 } \ 170 if ((v) == 2) \ 171 PerlProc_exit(STATUS_EXIT); \ 172 PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)(v)); \ 173 PerlProc_exit(1); \ 174 } STMT_END 175 176 #define CATCH_GET (PL_top_env->je_mustcatch) 177 #define CATCH_SET(v) \ 178 STMT_START { \ 179 DEBUG_l( \ 180 Perl_deb(aTHX_ \ 181 "JUMPLEVEL set catch %d => %d (for %p) in %s at %s:%d\n", \ 182 PL_top_env->je_mustcatch, (v), (void*)PL_top_env, \ 183 SAFE_FUNCTION__, __FILE__, __LINE__);) \ 184 PL_top_env->je_mustcatch = (v); \ 185 } STMT_END 186 187 /* 188 =for apidoc_section $COP 189 */ 190 191 typedef struct refcounted_he COPHH; 192 193 #define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8 194 #define COPHH_EXISTS REFCOUNTED_HE_EXISTS 195 196 /* 197 =for apidoc Amx|SV *|cophh_fetch_pv |const COPHH *cophh|const char *key |U32 hash|U32 flags 198 =for apidoc_item|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *key|STRLEN keylen|U32 hash|U32 flags 199 =for apidoc_item|SV *|cophh_fetch_pvs|const COPHH *cophh| "key" |U32 flags 200 =for apidoc_item|SV *|cophh_fetch_sv |const COPHH *cophh| SV *key |U32 hash|U32 flags 201 202 These look up the entry in the cop hints hash C<cophh> with the key specified by 203 C<key> (and C<keylen> in the C<pvn> form), returning that value as a mortal 204 scalar copy, or C<&PL_sv_placeholder> if there is no value associated with the 205 key. 206 207 The forms differ in how the key is specified. 208 In the plain C<pv> form, the key is a C language NUL-terminated string. 209 In the C<pvs> form, the key is a C language string literal. 210 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 211 the string, which hence, may contain embedded-NUL characters. 212 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 213 using C<L</SvPV_const>>. 214 215 C<hash> is a precomputed hash of the key string, or zero if it has not been 216 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 217 automatically at compile time. 218 219 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 220 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 221 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 222 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 223 the octets. 224 225 =for apidoc Amnh||COPHH_KEY_UTF8 226 227 =cut 228 229 */ 230 231 #define cophh_fetch_pvn(cophh, key, keylen, hash, flags) \ 232 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, key, keylen, hash, \ 233 (flags & COPHH_KEY_UTF8)) 234 235 #define cophh_fetch_pvs(cophh, key, flags) \ 236 Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \ 237 (flags & COPHH_KEY_UTF8)) 238 239 #define cophh_fetch_pv(cophh, key, hash, flags) \ 240 Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, \ 241 (flags & COPHH_KEY_UTF8)) 242 243 #define cophh_fetch_sv(cophh, key, hash, flags) \ 244 Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, \ 245 (flags & COPHH_KEY_UTF8)) 246 247 /* 248 =for apidoc Amx|bool|cophh_exists_pvn|const COPHH *cophh|const char *key|STRLEN keylen|U32 hash|U32 flags 249 250 These look up the hint entry in the cop C<cop> with the key specified by 251 C<key> (and C<keylen> in the C<pvn> form), returning true if a value exists, 252 and false otherwise. 253 254 The forms differ in how the key is specified. 255 In the plain C<pv> form, the key is a C language NUL-terminated string. 256 In the C<pvs> form, the key is a C language string literal. 257 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 258 the string, which hence, may contain embedded-NUL characters. 259 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 260 using C<L</SvPV_const>>. 261 262 C<hash> is a precomputed hash of the key string, or zero if it has not been 263 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 264 automatically at compile time. 265 266 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 267 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 268 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 269 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 270 the octets. 271 272 =cut 273 */ 274 275 #define cophh_exists_pvn(cophh, key, keylen, hash, flags) \ 276 cBOOL(Perl_refcounted_he_fetch_pvn(aTHX_ cophh, key, keylen, hash, flags | COPHH_EXISTS)) 277 278 #define cophh_exists_pvs(cophh, key, flags) \ 279 cBOOL(Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags | COPHH_EXISTS)) 280 281 #define cophh_exists_pv(cophh, key, hash, flags) \ 282 cBOOL(Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags | COPHH_EXISTS)) 283 284 #define cophh_exists_sv(cophh, key, hash, flags) \ 285 cBOOL(Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags | COPHH_EXISTS)) 286 287 /* 288 =for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags 289 290 Generates and returns a standard Perl hash representing the full set of 291 key/value pairs in the cop hints hash C<cophh>. C<flags> is currently 292 unused and must be zero. 293 294 =cut 295 */ 296 297 #define cophh_2hv(cophh, flags) \ 298 Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags) 299 300 /* 301 =for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh 302 303 Make and return a complete copy of the cop hints hash C<cophh>. 304 305 =cut 306 */ 307 308 #define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh) 309 310 /* 311 =for apidoc Amx|void|cophh_free|COPHH *cophh 312 313 Discard the cop hints hash C<cophh>, freeing all resources associated 314 with it. 315 316 =cut 317 */ 318 319 #define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh) 320 321 /* 322 =for apidoc Amx|COPHH *|cophh_new_empty 323 324 Generate and return a fresh cop hints hash containing no entries. 325 326 =cut 327 */ 328 329 #define cophh_new_empty() ((COPHH *)NULL) 330 331 /* 332 =for apidoc Amx|COPHH *|cophh_store_pv |COPHH *cophh|const char *key |U32 hash|SV *value|U32 flags 333 =for apidoc_item|COPHH *|cophh_store_pvn|COPHH *cophh|const char *key|STRLEN keylen|U32 hash|SV *value|U32 flags 334 =for apidoc_item|COPHH *|cophh_store_pvs|COPHH *cophh| "key" |SV *value|U32 flags 335 =for apidoc_item|COPHH *|cophh_store_sv |COPHH *cophh| SV *key |U32 hash|SV *value|U32 flags 336 337 These store a value, associated with a key, in the cop hints hash C<cophh>, 338 and return 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 C<value> is the scalar value to store for this key. C<value> is copied 344 by these functions, which thus do not take ownership of any reference 345 to it, and hence later changes to the scalar will not be reflected in the value 346 visible in the cop hints hash. Complex types of scalar will not be stored with 347 referential integrity, but will be coerced to strings. 348 349 The forms differ in how the key is specified. In all forms, the key is pointed 350 to by C<key>. 351 In the plain C<pv> form, the key is a C language NUL-terminated string. 352 In the C<pvs> form, the key is a C language string literal. 353 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 354 the string, which hence, may contain embedded-NUL characters. 355 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 356 using C<L</SvPV_const>>. 357 358 C<hash> is a precomputed hash of the key string, or zero if it has not been 359 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 360 automatically at compile time. 361 362 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 363 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 364 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 365 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 366 the octets. 367 368 =cut 369 */ 370 371 #define cophh_store_pvn(cophh, key, keylen, hash, value, flags) \ 372 Perl_refcounted_he_new_pvn(aTHX_ cophh, key, keylen, hash, value, flags) 373 374 #define cophh_store_pvs(cophh, key, value, flags) \ 375 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags) 376 377 #define cophh_store_pv(cophh, key, hash, value, flags) \ 378 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags) 379 380 #define cophh_store_sv(cophh, key, hash, value, flags) \ 381 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags) 382 383 /* 384 =for apidoc Amx|COPHH *|cophh_delete_pv |COPHH *cophh|const char *key |U32 hash|U32 flags 385 =for apidoc_item|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *key|STRLEN keylen|U32 hash|U32 flags 386 =for apidoc_item|COPHH *|cophh_delete_pvs|COPHH *cophh| "key" |U32 flags 387 =for apidoc_item|COPHH *|cophh_delete_sv |COPHH *cophh| SV *key |U32 hash|U32 flags 388 389 These delete a key and its associated value from the cop hints hash C<cophh>, 390 and return the modified hash. The returned hash pointer is in general 391 not the same as the hash pointer that was passed in. The input hash is 392 consumed by the function, and the pointer to it must not be subsequently 393 used. Use L</cophh_copy> if you need both hashes. 394 395 The forms differ in how the key is specified. In all forms, the key is pointed 396 to by C<key>. 397 In the plain C<pv> form, the key is a C language NUL-terminated string. 398 In the C<pvs> form, the key is a C language string literal. 399 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 400 the string, which hence, may contain embedded-NUL characters. 401 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 402 using C<L</SvPV_const>>. 403 404 C<hash> is a precomputed hash of the key string, or zero if it has not been 405 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 406 automatically at compile time. 407 408 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 409 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 410 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 411 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 412 the octets. 413 414 =cut 415 */ 416 417 #define cophh_delete_pvn(cophh, key, keylen, hash, flags) \ 418 Perl_refcounted_he_new_pvn(aTHX_ cophh, key, keylen, hash, \ 419 (SV *)NULL, flags) 420 421 #define cophh_delete_pvs(cophh, key, flags) \ 422 Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \ 423 (SV *)NULL, flags) 424 425 #define cophh_delete_pv(cophh, key, hash, flags) \ 426 Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags) 427 428 #define cophh_delete_sv(cophh, key, hash, flags) \ 429 Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags) 430 431 #include "mydtrace.h" 432 433 struct cop { 434 BASEOP 435 /* On LP64 putting this here takes advantage of the fact that BASEOP isn't 436 an exact multiple of 8 bytes to save structure padding. */ 437 line_t cop_line; /* line # of this command */ 438 /* label for this construct is now stored in cop_hints_hash */ 439 #ifdef USE_ITHREADS 440 PADOFFSET cop_stashoff; /* offset into PL_stashpad, for the 441 package the line was compiled in */ 442 char * cop_file; /* rcpv containing name of file this command is from */ 443 #else 444 HV * cop_stash; /* package line was compiled in */ 445 GV * cop_filegv; /* name of GV file this command is from */ 446 #endif 447 U32 cop_hints; /* hints bits from pragmata */ 448 U32 cop_seq; /* parse sequence number */ 449 char * cop_warnings; /* Lexical warnings bitmask vector. 450 Refcounted shared copy of ${^WARNING_BITS}. 451 This pointer either points at one of the 452 magic values for warnings, or it points 453 at a buffer constructed with rcpv_new(). 454 Use the RCPV_LEN() macro to get its length. 455 */ 456 /* compile time state of %^H. See the comment in op.c for how this is 457 used to recreate a hash to return from caller. */ 458 COPHH * cop_hints_hash; 459 /* for now just a bitmask stored here. 460 If we get sufficient features this may become a pointer. 461 How these flags are stored is subject to change without 462 notice. Use the macros to test for features. 463 */ 464 U32 cop_features; 465 }; 466 467 /* 468 =for apidoc Am|const char *|CopFILE|const COP * c 469 Returns the name of the file associated with the C<COP> C<c> 470 471 =for apidoc Am|const char *|CopFILE_LEN|const COP * c 472 Returns the length of the file associated with the C<COP> C<c> 473 474 =for apidoc Am|line_t|CopLINE|const COP * c 475 Returns the line number in the source code associated with the C<COP> C<c> 476 477 =for apidoc Am|AV *|CopFILEAV|const COP * c 478 Returns the AV associated with the C<COP> C<c>, creating it if necessary. 479 480 =for apidoc Am|AV *|CopFILEAVn|const COP * c 481 Returns the AV associated with the C<COP> C<c>, returning NULL if it 482 doesn't already exist. 483 484 =for apidoc Am|SV *|CopFILESV|const COP * c 485 Returns the SV associated with the C<COP> C<c> 486 487 =for apidoc Am|void|CopFILE_set|COP * c|const char * pv 488 Makes C<pv> the name of the file associated with the C<COP> C<c> 489 490 =for apidoc Am|void|CopFILE_setn|COP * c|const char * pv|STRLEN len 491 Makes C<pv> the name of the file associated with the C<COP> C<c> 492 493 =for apidoc Am|void|CopFILE_copy|COP * dst|COP * src 494 Efficiently copies the cop file name from one COP to another. Wraps 495 the required logic to do a refcounted copy under threads or not. 496 497 =for apidoc Am|void|CopFILE_free|COP * c 498 Frees the file data in a cop. Under the hood this is a refcounting 499 operation. 500 501 =for apidoc Am|GV *|CopFILEGV|const COP * c 502 Returns the GV associated with the C<COP> C<c> 503 504 =for apidoc CopFILEGV_set 505 Available only on unthreaded perls. Makes C<pv> the name of the file 506 associated with the C<COP> C<c> 507 508 =for apidoc Am|HV *|CopSTASH|const COP * c 509 Returns the stash associated with C<c>. 510 511 =for apidoc Am|bool|CopSTASH_eq|const COP * c|const HV * hv 512 Returns a boolean as to whether or not C<hv> is the stash associated with C<c>. 513 514 =for apidoc Am|bool|CopSTASH_set|COP * c|HV * hv 515 Set the stash associated with C<c> to C<hv>. 516 517 =for apidoc Am|char *|CopSTASHPV|const COP * c 518 Returns the package name of the stash associated with C<c>, or C<NULL> if no 519 associated stash 520 521 =for apidoc Am|void|CopSTASHPV_set|COP * c|const char * pv 522 Set the package name of the stash associated with C<c>, to the NUL-terminated C 523 string C<p>, creating the package if necessary. 524 525 =cut 526 */ 527 528 /* 529 =for apidoc Am|RCPV *|RCPVx|char *pv 530 Returns the RCPV structure (struct rcpv) for a refcounted 531 string pv created with C<rcpv_new()>. 532 No checks are performed to ensure that C<pv> was actually allocated 533 with C<rcpv_new()>, it is the callers responsibility to ensure that 534 this is the case. 535 536 =for apidoc Am|RCPV *|RCPV_REFCOUNT|char *pv 537 Returns the refcount for a pv created with C<rcpv_new()>. 538 No checks are performed to ensure that C<pv> was actually allocated 539 with C<rcpv_new()>, it is the callers responsibility to ensure that 540 this is the case. 541 542 =for apidoc Am|RCPV *|RCPV_REFCNT_inc|char *pv 543 Increments the refcount for a C<char *> pointer which was created 544 with a call to C<rcpv_new()>. Same as calling rcpv_copy(). 545 No checks are performed to ensure that C<pv> was actually allocated 546 with C<rcpv_new()>, it is the callers responsibility to ensure that 547 this is the case. 548 549 =for apidoc Am|RCPV *|RCPV_REFCNT_dec|char *pv 550 Decrements the refcount for a C<char *> pointer which was created 551 with a call to C<rcpv_new()>. Same as calling rcpv_free(). 552 No checks are performed to ensure that C<pv> was actually allocated 553 with C<rcpv_new()>, it is the callers responsibility to ensure that 554 this is the case. 555 556 =for apidoc Am|RCPV *|RCPV_LEN|char *pv 557 Returns the length of a pv created with C<rcpv_new()>. 558 Note that this reflects the length of the string from the callers 559 point of view, it does not include the mandatory null which is 560 always injected at the end of the string by rcpv_new(). 561 No checks are performed to ensure that C<pv> was actually allocated 562 with C<rcpv_new()>, it is the callers responsibility to ensure that 563 this is the case. 564 565 =cut 566 */ 567 568 struct rcpv { 569 STRLEN refcount; /* UV would mean a 64 refcnt on 570 32 bit builds with -Duse64bitint */ 571 STRLEN len; /* length of string including mandatory 572 null byte at end */ 573 char pv[1]; 574 }; 575 typedef struct rcpv RCPV; 576 577 #define RCPVf_USE_STRLEN (1 << 0) 578 #define RCPVf_NO_COPY (1 << 1) 579 #define RCPVf_ALLOW_EMPTY (1 << 2) 580 581 #define RCPVx(pv_arg) ((RCPV *)((pv_arg) - STRUCT_OFFSET(struct rcpv, pv))) 582 #define RCPV_REFCOUNT(pv) (RCPVx(pv)->refcount) 583 #define RCPV_LEN(pv) (RCPVx(pv)->len-1) /* len always includes space for a null */ 584 #define RCPV_REFCNT_inc(pv) rcpv_copy(pv) 585 #define RCPV_REFCNT_dec(pv) rcpv_free(pv) 586 587 #ifdef USE_ITHREADS 588 589 # define CopFILE(c) ((c)->cop_file) 590 # define CopFILE_LEN(c) (CopFILE(c) ? RCPV_LEN(CopFILE(c)) : 0) 591 # define CopFILEGV(c) (CopFILE(c) \ 592 ? gv_fetchfile(CopFILE(c)) : NULL) 593 594 # define CopFILE_set_x(c,pv) ((c)->cop_file = rcpv_new((pv),0,RCPVf_USE_STRLEN)) 595 # define CopFILE_setn_x(c,pv,l) ((c)->cop_file = rcpv_new((pv),(l),0)) 596 # define CopFILE_free_x(c) ((c)->cop_file = rcpv_free((c)->cop_file)) 597 # define CopFILE_copy_x(dst,src) ((dst)->cop_file = rcpv_copy((src)->cop_file)) 598 599 /* change condition to 1 && to enable this debugging */ 600 # define CopFILE_debug(c,t,rk) \ 601 if (0 && (c)->cop_file) \ 602 PerlIO_printf(Perl_debug_log, \ 603 "%-14s THX:%p OP:%p PV:%p rc: " \ 604 "%6zu fn: '%.*s' at %s line %d\n", \ 605 (t), aTHX, (c), (c)->cop_file, \ 606 RCPV_REFCOUNT((c)->cop_file)-rk, \ 607 (int)RCPV_LEN((c)->cop_file), \ 608 (c)->cop_file,__FILE__,__LINE__) \ 609 610 611 # define CopFILE_set(c,pv) \ 612 STMT_START { \ 613 CopFILE_set_x(c,pv); \ 614 CopFILE_debug(c,"CopFILE_set", 0); \ 615 } STMT_END 616 617 # define CopFILE_setn(c,pv,l) \ 618 STMT_START { \ 619 CopFILE_setn_x(c,pv,l); \ 620 CopFILE_debug(c,"CopFILE_setn", 0); \ 621 } STMT_END 622 623 # define CopFILE_copy(dst,src) \ 624 STMT_START { \ 625 CopFILE_copy_x((dst),(src)); \ 626 CopFILE_debug((dst),"CopFILE_copy", 0); \ 627 } STMT_END 628 629 # define CopFILE_free(c) \ 630 STMT_START { \ 631 CopFILE_debug((c),"CopFILE_free", 1); \ 632 CopFILE_free_x(c); \ 633 } STMT_END 634 635 636 # define CopFILESV(c) (CopFILE(c) \ 637 ? GvSV(gv_fetchfile(CopFILE(c))) : NULL) 638 # define CopFILEAV(c) (CopFILE(c) \ 639 ? GvAV(gv_fetchfile(CopFILE(c))) : NULL) 640 # define CopFILEAVx(c) (assert_(CopFILE(c)) \ 641 GvAV(gv_fetchfile(CopFILE(c)))) 642 # define CopFILEAVn(c) (cop_file_avn(c)) 643 # define CopSTASH(c) PL_stashpad[(c)->cop_stashoff] 644 # define CopSTASH_set(c,hv) ((c)->cop_stashoff = (hv) \ 645 ? alloccopstash(hv) \ 646 : 0) 647 648 #else /* Above: yes threads; Below no threads */ 649 650 # define CopFILEGV(c) ((c)->cop_filegv) 651 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) 652 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) 653 # define CopFILE_copy(dst,src) CopFILEGV_set((dst),CopFILEGV(src)) 654 # define CopFILE_setn(c,pv,l) CopFILEGV_set((c), gv_fetchfile_flags((pv),(l),0)) 655 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL) 656 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL) 657 # ifdef DEBUGGING 658 # define CopFILEAVx(c) (assert(CopFILEGV(c)), GvAV(CopFILEGV(c))) 659 # else 660 # define CopFILEAVx(c) (GvAV(CopFILEGV(c))) 661 # endif 662 # define CopFILEAVn(c) (CopFILEGV(c) ? GvAVn(CopFILEGV(c)) : NULL) 663 # define CopFILE(c) (CopFILEGV(c) /* +2 for '_<' */ \ 664 ? GvNAME(CopFILEGV(c))+2 : NULL) 665 # define CopFILE_LEN(c) (CopFILEGV(c) /* -2 for '_<' */ \ 666 ? GvNAMELEN(CopFILEGV(c))-2 : 0) 667 # define CopSTASH(c) ((c)->cop_stash) 668 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) 669 # define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL)) 670 671 #endif /* USE_ITHREADS */ 672 673 #define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL) 674 /* cop_stash is not refcounted */ 675 #define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) 676 #define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) 677 678 #define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash)) 679 #define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h)) 680 681 #define CopFEATURES_setfrom(dst, src) ((dst)->cop_features = (src)->cop_features) 682 683 /* 684 =for apidoc Am|SV *|cop_hints_fetch_pv |const COP *cop|const char *key |U32 hash|U32 flags 685 =for apidoc_item|SV *|cop_hints_fetch_pvn|const COP *cop|const char *key|STRLEN keylen|U32 hash|U32 flags 686 =for apidoc_item|SV *|cop_hints_fetch_pvs|const COP *cop| "key" |U32 flags 687 =for apidoc_item|SV *|cop_hints_fetch_sv |const COP *cop| SV *key |U32 hash|U32 flags 688 689 These look up the hint entry in the cop C<cop> with the key specified by 690 C<key> (and C<keylen> in the C<pvn> form), returning that value as a mortal 691 scalar copy, or C<&PL_sv_placeholder> if there is no value associated with the 692 key. 693 694 The forms differ in how the key is specified. 695 In the plain C<pv> form, the key is a C language NUL-terminated string. 696 In the C<pvs> form, the key is a C language string literal. 697 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 698 the string, which hence, may contain embedded-NUL characters. 699 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 700 using C<L</SvPV_const>>. 701 702 C<hash> is a precomputed hash of the key string, or zero if it has not been 703 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 704 automatically at compile time. 705 706 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 707 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 708 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 709 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 710 the octets. 711 712 =cut 713 */ 714 715 #define cop_hints_fetch_pvn(cop, key, keylen, hash, flags) \ 716 cophh_fetch_pvn(CopHINTHASH_get(cop), key, keylen, hash, flags) 717 718 #define cop_hints_fetch_pvs(cop, key, flags) \ 719 cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags) 720 721 #define cop_hints_fetch_pv(cop, key, hash, flags) \ 722 cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags) 723 724 #define cop_hints_fetch_sv(cop, key, hash, flags) \ 725 cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags) 726 727 /* 728 =for apidoc Am|bool|cop_hints_exists_pv |const COP *cop|const char *key|U32 hash |U32 flags 729 =for apidoc_item|bool|cop_hints_exists_pvn|const COP *cop|const char *key|STRLEN keylen|U32 hash|U32 flags 730 =for apidoc_item|bool|cop_hints_exists_pvs|const COP *cop| "key" |U32 flags 731 =for apidoc_item|bool|cop_hints_exists_sv |const COP *cop| SV *key |U32 hash|U32 flags 732 733 These look up the hint entry in the cop C<cop> with the key specified by 734 C<key> (and C<keylen> in the C<pvn> form), returning true if a value exists, 735 and false otherwise. 736 737 The forms differ in how the key is specified. In all forms, the key is pointed 738 to by C<key>. 739 In the plain C<pv> form, the key is a C language NUL-terminated string. 740 In the C<pvs> form, the key is a C language string literal. 741 In the C<pvn> form, an additional parameter, C<keylen>, specifies the length of 742 the string, which hence, may contain embedded-NUL characters. 743 In the C<sv> form, C<*key> is an SV, and the key is the PV extracted from that. 744 using C<L</SvPV_const>>. 745 746 C<hash> is a precomputed hash of the key string, or zero if it has not been 747 precomputed. This parameter is omitted from the C<pvs> form, as it is computed 748 automatically at compile time. 749 750 The only flag currently used from the C<flags> parameter is C<COPHH_KEY_UTF8>. 751 It is illegal to set this in the C<sv> form. In the C<pv*> forms, it specifies 752 whether the key octets are interpreted as UTF-8 (if set) or as Latin-1 (if 753 cleared). The C<sv> form uses the underlying SV to determine the UTF-8ness of 754 the octets. 755 756 =cut 757 */ 758 759 #define cop_hints_exists_pvn(cop, key, keylen, hash, flags) \ 760 cophh_exists_pvn(CopHINTHASH_get(cop), key, keylen, hash, flags) 761 762 #define cop_hints_exists_pvs(cop, key, flags) \ 763 cophh_exists_pvs(CopHINTHASH_get(cop), key, flags) 764 765 #define cop_hints_exists_pv(cop, key, hash, flags) \ 766 cophh_exists_pv(CopHINTHASH_get(cop), key, hash, flags) 767 768 #define cop_hints_exists_sv(cop, key, hash, flags) \ 769 cophh_exists_sv(CopHINTHASH_get(cop), key, hash, flags) 770 771 /* 772 =for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags 773 774 Generates and returns a standard Perl hash representing the full set of 775 hint entries in the cop C<cop>. C<flags> is currently unused and must 776 be zero. 777 778 =cut 779 */ 780 781 #define cop_hints_2hv(cop, flags) \ 782 cophh_2hv(CopHINTHASH_get(cop), flags) 783 784 /* 785 =for apidoc Am|const char *|CopLABEL |COP *const cop 786 =for apidoc_item|const char *|CopLABEL_len |COP *const cop|STRLEN *len 787 =for apidoc_item|const char *|CopLABEL_len_flags|COP *const cop|STRLEN *len|U32 *flags 788 789 These return the label attached to a cop. 790 791 C<CopLABEL_len> and C<CopLABEL_len_flags> additionally store the number of 792 bytes comprising the returned label into C<*len>. 793 794 C<CopLABEL_len_flags> additionally returns the UTF-8ness of the returned label, 795 by setting C<*flags> to 0 or C<SVf_UTF8>. 796 797 =cut 798 */ 799 800 #define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL) 801 #define CopLABEL_len(c,len) Perl_cop_fetch_label(aTHX_ (c), len, NULL) 802 #define CopLABEL_len_flags(c,len,flags) Perl_cop_fetch_label(aTHX_ (c), len, flags) 803 #define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL) 804 805 #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) 806 #define CopLINE(c) ((c)->cop_line) 807 #define CopLINE_inc(c) (++CopLINE(c)) 808 #define CopLINE_dec(c) (--CopLINE(c)) 809 #define CopLINE_set(c,l) (CopLINE(c) = (l)) 810 811 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */ 812 #define OutCopFILE(c) CopFILE(c) 813 814 #define CopHINTS_get(c) ((c)->cop_hints + 0) 815 #define CopHINTS_set(c, h) STMT_START { \ 816 (c)->cop_hints = (h); \ 817 } STMT_END 818 819 /* 820 * Here we have some enormously heavy (or at least ponderous) wizardry. 821 */ 822 823 /* subroutine context */ 824 struct block_sub { 825 OP * retop; /* op to execute on exit from sub */ 826 I32 old_cxsubix; /* previous value of si_cxsubix */ 827 /* Above here is the same for sub, format and eval. */ 828 PAD *prevcomppad; /* the caller's PL_comppad */ 829 CV * cv; 830 /* Above here is the same for sub and format. */ 831 I32 olddepth; 832 AV *savearray; 833 }; 834 835 836 /* format context */ 837 struct block_format { 838 OP * retop; /* op to execute on exit from sub */ 839 I32 old_cxsubix; /* previous value of si_cxsubix */ 840 /* Above here is the same for sub, format and eval. */ 841 PAD *prevcomppad; /* the caller's PL_comppad */ 842 CV * cv; 843 /* Above here is the same for sub and format. */ 844 GV * gv; 845 GV * dfoutgv; 846 }; 847 848 /* return a pointer to the current context */ 849 850 #define CX_CUR() (&cxstack[cxstack_ix]) 851 852 /* free all savestack items back to the watermark of the specified context */ 853 854 #define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->blk_oldsaveix) 855 856 #ifdef DEBUGGING 857 /* on debugging builds, poison cx afterwards so we know no code 858 * uses it - because after doing cxstack_ix--, any ties, exceptions etc 859 * may overwrite the current stack frame */ 860 # define CX_POP(cx) \ 861 assert(CX_CUR() == cx); \ 862 cxstack_ix--; \ 863 cx = NULL; 864 #else 865 # define CX_POP(cx) cxstack_ix--; 866 #endif 867 868 #define CX_PUSHSUB_GET_LVALUE_MASK(func) \ 869 /* If the context is indeterminate, then only the lvalue */ \ 870 /* flags that the caller also has are applicable. */ \ 871 ( \ 872 (PL_op->op_flags & OPf_WANT) \ 873 ? OPpENTERSUB_LVAL_MASK \ 874 : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \ 875 ? 0 : (U8)func(aTHX) \ 876 ) 877 878 /* Restore old @_ */ 879 #define CX_POP_SAVEARRAY(cx) \ 880 STMT_START { \ 881 AV *cx_pop_savearray_av = GvAV(PL_defgv); \ 882 GvAV(PL_defgv) = cx->blk_sub.savearray; \ 883 cx->blk_sub.savearray = NULL; \ 884 SvREFCNT_dec(cx_pop_savearray_av); \ 885 } STMT_END 886 887 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't 888 * leave any (a fast av_clear(ary), basically) */ 889 #define CLEAR_ARGARRAY(ary) \ 890 STMT_START { \ 891 AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ 892 AvARRAY(ary) = AvALLOC(ary); \ 893 AvFILLp(ary) = -1; \ 894 } STMT_END 895 896 897 /* eval context */ 898 struct block_eval { 899 OP * retop; /* op to execute on exit from eval */ 900 I32 old_cxsubix; /* previous value of si_cxsubix */ 901 /* Above here is the same for sub, format and eval. */ 902 SV * old_namesv; 903 OP * old_eval_root; 904 SV * cur_text; 905 CV * cv; 906 JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */ 907 }; 908 909 /* If we ever need more than 512 op types, change the shift from 7. 910 blku_gimme is actually also only 2 bits, so could be merged with something. 911 */ 912 913 /* blk_u16 bit usage for eval contexts: */ 914 915 #define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x3F) /* saved PL_in_eval */ 916 #define CxEVAL_TXT_REFCNTED(cx) (((cx)->blk_u16) & 0x40) /* cur_text rc++ */ 917 #define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) /* type of eval op */ 918 919 /* loop context */ 920 struct block_loop { 921 LOOP * my_op; /* My op, that contains redo, next and last ops. */ 922 union { /* different ways of locating the iteration variable */ 923 SV **svp; /* for lexicals: address of pad slot */ 924 GV *gv; /* for package vars */ 925 } itervar_u; 926 SV *itersave; /* the original iteration var */ 927 union { 928 struct { /* CXt_LOOP_ARY, C<for (@ary)> */ 929 AV *ary; /* array being iterated over */ 930 IV ix; /* index relative to base of array */ 931 } ary; 932 struct { /* CXt_LOOP_LIST, C<for (list)> */ 933 I32 basesp; /* first element of list on stack */ 934 IV ix; /* index relative to basesp */ 935 } stack; 936 struct { /* CXt_LOOP_LAZYIV, C<for (1..9)> */ 937 IV cur; 938 IV end; 939 } lazyiv; 940 struct { /* CXt_LOOP_LAZYSV C<for ('a'..'z')> */ 941 SV * cur; 942 SV * end; /* maximum value (or minimum in reverse) */ 943 } lazysv; 944 } state_u; 945 #ifdef USE_ITHREADS 946 PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */ 947 #endif 948 }; 949 950 #define CxITERVAR(c) \ 951 (CxPADLOOP(c) \ 952 ? (c)->blk_loop.itervar_u.svp \ 953 : ((c)->cx_type & CXp_FOR_GV) \ 954 ? &GvSV((c)->blk_loop.itervar_u.gv) \ 955 : (SV **)&(c)->blk_loop.itervar_u.gv) 956 957 #define CxLABEL(c) (CopLABEL((c)->blk_oldcop)) 958 #define CxLABEL_len(c,len) (CopLABEL_len((c)->blk_oldcop, len)) 959 #define CxLABEL_len_flags(c,len,flags) ((const char *)CopLABEL_len_flags((c)->blk_oldcop, len, flags)) 960 #define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS) 961 962 /* CxLVAL(): the lval flags of the call site: the relevant flag bits from 963 * the op_private field of the calling pp_entersub (or its caller's caller 964 * if the caller's lvalue context isn't known): 965 * OPpLVAL_INTRO: sub used in lvalue context, e.g. f() = 1; 966 * OPpENTERSUB_INARGS (in conjunction with OPpLVAL_INTRO): the 967 * function is being used as a sub arg or as a referent, e.g. 968 * g(...,f(),...) or $r = \f() 969 * OPpDEREF: 2-bit mask indicating e.g. f()->[0]. 970 * Note the contrast with CvLVALUE(), which is a property of the sub 971 * rather than the call site. 972 */ 973 #define CxLVAL(c) (0 + ((U8)((c)->blk_u16))) 974 975 976 977 /* given/when context */ 978 struct block_givwhen { 979 OP *leave_op; 980 SV *defsv_save; /* the original $_ */ 981 }; 982 983 984 985 /* context common to subroutines, evals and loops */ 986 struct block { 987 U8 blku_type; /* what kind of context this is */ 988 U8 blku_gimme; /* is this block running in list context? */ 989 U16 blku_u16; /* used by block_sub and block_eval (so far) */ 990 I32 blku_oldsaveix; /* saved PL_savestack_ix */ 991 /* all the fields above must be aligned with same-sized fields as sbu */ 992 I32 blku_oldsp; /* current sp floor: where nextstate pops to */ 993 I32 blku_oldmarksp; /* mark stack index */ 994 COP * blku_oldcop; /* old curcop pointer */ 995 PMOP * blku_oldpm; /* values of pattern match vars */ 996 SSize_t blku_old_tmpsfloor; /* saved PL_tmps_floor */ 997 I32 blku_oldscopesp; /* scope stack index */ 998 999 union { 1000 struct block_sub blku_sub; 1001 struct block_format blku_format; 1002 struct block_eval blku_eval; 1003 struct block_loop blku_loop; 1004 struct block_givwhen blku_givwhen; 1005 } blk_u; 1006 }; 1007 #define blk_oldsp cx_u.cx_blk.blku_oldsp 1008 #define blk_oldcop cx_u.cx_blk.blku_oldcop 1009 #define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp 1010 #define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp 1011 #define blk_oldpm cx_u.cx_blk.blku_oldpm 1012 #define blk_gimme cx_u.cx_blk.blku_gimme 1013 #define blk_u16 cx_u.cx_blk.blku_u16 1014 #define blk_oldsaveix cx_u.cx_blk.blku_oldsaveix 1015 #define blk_old_tmpsfloor cx_u.cx_blk.blku_old_tmpsfloor 1016 #define blk_sub cx_u.cx_blk.blk_u.blku_sub 1017 #define blk_format cx_u.cx_blk.blk_u.blku_format 1018 #define blk_eval cx_u.cx_blk.blk_u.blku_eval 1019 #define blk_loop cx_u.cx_blk.blk_u.blku_loop 1020 #define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen 1021 1022 #define CX_DEBUG(cx, action) \ 1023 DEBUG_l( \ 1024 Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) in %s at %s:%d\n",\ 1025 (long)cxstack_ix, \ 1026 action, \ 1027 PL_block_type[CxTYPE(cx)], \ 1028 (long)PL_scopestack_ix, \ 1029 (long)(cx->blk_oldscopesp), \ 1030 (long)PL_savestack_ix, \ 1031 (long)(cx->blk_oldsaveix), \ 1032 SAFE_FUNCTION__, __FILE__, __LINE__)); 1033 1034 1035 1036 /* substitution context */ 1037 struct subst { 1038 U8 sbu_type; /* same as blku_type */ 1039 U8 sbu_rflags; 1040 U16 sbu_rxtainted; 1041 I32 sbu_oldsaveix; /* same as blku_oldsaveix */ 1042 /* all the fields above must be aligned with same-sized fields as blk_u */ 1043 SSize_t sbu_iters; 1044 SSize_t sbu_maxiters; 1045 char * sbu_orig; 1046 SV * sbu_dstr; 1047 SV * sbu_targ; 1048 char * sbu_s; 1049 char * sbu_m; 1050 char * sbu_strend; 1051 void * sbu_rxres; 1052 REGEXP * sbu_rx; 1053 }; 1054 1055 #ifdef PERL_CORE 1056 1057 #define sb_iters cx_u.cx_subst.sbu_iters 1058 #define sb_maxiters cx_u.cx_subst.sbu_maxiters 1059 #define sb_rflags cx_u.cx_subst.sbu_rflags 1060 #define sb_rxtainted cx_u.cx_subst.sbu_rxtainted 1061 #define sb_orig cx_u.cx_subst.sbu_orig 1062 #define sb_dstr cx_u.cx_subst.sbu_dstr 1063 #define sb_targ cx_u.cx_subst.sbu_targ 1064 #define sb_s cx_u.cx_subst.sbu_s 1065 #define sb_m cx_u.cx_subst.sbu_m 1066 #define sb_strend cx_u.cx_subst.sbu_strend 1067 #define sb_rxres cx_u.cx_subst.sbu_rxres 1068 #define sb_rx cx_u.cx_subst.sbu_rx 1069 1070 # define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(), \ 1071 cx->blk_oldsaveix = oldsave, \ 1072 cx->sb_iters = iters, \ 1073 cx->sb_maxiters = maxiters, \ 1074 cx->sb_rflags = r_flags, \ 1075 cx->sb_rxtainted = rxtainted, \ 1076 cx->sb_orig = orig, \ 1077 cx->sb_dstr = dstr, \ 1078 cx->sb_targ = targ, \ 1079 cx->sb_s = s, \ 1080 cx->sb_m = m, \ 1081 cx->sb_strend = strend, \ 1082 cx->sb_rxres = NULL, \ 1083 cx->sb_rx = rx, \ 1084 cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \ 1085 rxres_save(&cx->sb_rxres, rx); \ 1086 (void)ReREFCNT_inc(rx); \ 1087 SvREFCNT_inc_void_NN(targ) 1088 1089 # define CX_POPSUBST(cx) \ 1090 STMT_START { \ 1091 REGEXP *re; \ 1092 assert(CxTYPE(cx) == CXt_SUBST); \ 1093 rxres_free(&cx->sb_rxres); \ 1094 re = cx->sb_rx; \ 1095 cx->sb_rx = NULL; \ 1096 ReREFCNT_dec(re); \ 1097 SvREFCNT_dec_NN(cx->sb_targ); \ 1098 } STMT_END 1099 #endif 1100 1101 #define CxONCE(cx) ((cx)->cx_type & CXp_ONCE) 1102 1103 struct context { 1104 union { 1105 struct block cx_blk; 1106 struct subst cx_subst; 1107 } cx_u; 1108 }; 1109 #define cx_type cx_u.cx_subst.sbu_type 1110 1111 /* If you re-order these, there is also an array of uppercase names in perl.h 1112 and a static array of context names in pp_ctl.c */ 1113 #define CXTYPEMASK 0xf 1114 #define CXt_NULL 0 /* currently only used for sort BLOCK */ 1115 #define CXt_WHEN 1 1116 #define CXt_BLOCK 2 1117 /* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a 1118 jump table in pp_ctl.c 1119 The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c 1120 */ 1121 #define CXt_GIVEN 3 1122 1123 /* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP, 1124 * CxFOREACH compare ranges */ 1125 #define CXt_LOOP_ARY 4 /* for (@ary) { ...; } */ 1126 #define CXt_LOOP_LAZYSV 5 /* for ('a'..'z') { ...; } */ 1127 #define CXt_LOOP_LAZYIV 6 /* for (1..9) { ...; } */ 1128 #define CXt_LOOP_LIST 7 /* for (1,2,3) { ...; } */ 1129 #define CXt_LOOP_PLAIN 8 /* while (...) { ...; } 1130 or plain block { ...; } */ 1131 #define CXt_SUB 9 1132 #define CXt_FORMAT 10 1133 #define CXt_EVAL 11 /* eval'', eval{}, try{} */ 1134 #define CXt_SUBST 12 1135 #define CXt_DEFER 13 1136 /* SUBST doesn't feature in all switch statements. */ 1137 1138 /* private flags for CXt_SUB and CXt_FORMAT */ 1139 #define CXp_MULTICALL 0x10 /* part of a multicall (so don't tear down 1140 context on exit). (not CXt_FORMAT) */ 1141 #define CXp_HASARGS 0x20 1142 #define CXp_SUB_RE 0x40 /* code called within regex, i.e. (?{}) */ 1143 #define CXp_SUB_RE_FAKE 0x80 /* fake sub CX for (?{}) in current scope */ 1144 1145 /* private flags for CXt_EVAL */ 1146 #define CXp_REAL 0x20 /* truly eval'', not a lookalike */ 1147 #define CXp_EVALBLOCK 0x40 /* eval{}, not eval'' or similar */ 1148 #define CXp_TRY 0x80 /* try {} block */ 1149 1150 /* private flags for CXt_LOOP */ 1151 1152 /* this is only set in conjunction with CXp_FOR_GV */ 1153 #define CXp_FOR_DEF 0x10 /* foreach using $_ */ 1154 /* these 3 are mutually exclusive */ 1155 #define CXp_FOR_LVREF 0x20 /* foreach using \$var */ 1156 #define CXp_FOR_GV 0x40 /* foreach using package var */ 1157 #define CXp_FOR_PAD 0x80 /* foreach using lexical var */ 1158 1159 #define CxPADLOOP(c) ((c)->cx_type & CXp_FOR_PAD) 1160 1161 /* private flags for CXt_SUBST */ 1162 #define CXp_ONCE 0x10 /* What was sbu_once in struct subst */ 1163 1164 #define CxTYPE(c) ((c)->cx_type & CXTYPEMASK) 1165 #define CxTYPE_is_LOOP(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \ 1166 && CxTYPE(cx) <= CXt_LOOP_PLAIN) 1167 #define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL) 1168 #define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \ 1169 == (CXt_EVAL|CXp_REAL)) 1170 #define CxEVALBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_EVALBLOCK)) \ 1171 == (CXt_EVAL|CXp_EVALBLOCK)) 1172 #define CxTRY(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRY)) \ 1173 == (CXt_EVAL|CXp_TRY)) 1174 #define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \ 1175 && CxTYPE(cx) <= CXt_LOOP_LIST) 1176 1177 /* private flags for CXt_DEFER */ 1178 #define CXp_FINALLY 0x20 /* `finally` block; semantically identical 1179 * but matters for diagnostic messages */ 1180 1181 /* deprecated old name before real try/catch was added */ 1182 #define CXp_TRYBLOCK CXp_EVALBLOCK 1183 #define CxTRYBLOCK(c) CxEVALBLOCK(c) 1184 1185 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc())) 1186 1187 #define G_SCALAR 2 1188 #define G_LIST 3 1189 #define G_VOID 1 1190 #define G_WANT 3 1191 1192 #ifndef PERL_CORE 1193 /* name prior to 5.31.1 */ 1194 # define G_ARRAY G_LIST 1195 #endif 1196 1197 /* extra flags for Perl_call_* routines */ 1198 #define G_DISCARD 0x4 /* Call FREETMPS. 1199 Don't change this without consulting the 1200 hash actions codes defined in hv.h */ 1201 #define G_EVAL 0x8 /* Assume eval {} around subroutine call. */ 1202 #define G_NOARGS 0x10 /* Don't construct a @_ array. */ 1203 #define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */ 1204 #define G_NODEBUG 0x40 /* Disable debugging at toplevel. */ 1205 #define G_METHOD 0x80 /* Calling method. */ 1206 #define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or 1207 fold_constants. */ 1208 #define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef 1209 A special case for UNSHIFT in 1210 Perl_magic_methcall(). */ 1211 #define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling 1212 Perl_magic_methcall(). */ 1213 #define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */ 1214 #define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */ 1215 #define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */ 1216 1217 /* flag bits for PL_in_eval */ 1218 #define EVAL_NULL 0 /* not in an eval */ 1219 #define EVAL_INEVAL 1 /* some enclosing scope is an eval */ 1220 #define EVAL_WARNONLY 2 /* used by yywarn() when calling yyerror() */ 1221 #define EVAL_KEEPERR 4 /* set by Perl_call_sv if G_KEEPERR */ 1222 #define EVAL_INREQUIRE 8 /* The code is being required. */ 1223 #define EVAL_RE_REPARSING 0x10 /* eval_sv() called with G_RE_REPARSING */ 1224 /* if adding extra bits, make sure they can fit in CxOLD_OP_TYPE() */ 1225 1226 /* Support for switching (stack and block) contexts. 1227 * This ensures magic doesn't invalidate local stack and cx pointers. 1228 * Which one to use (or add) is mostly, but not completely arbitrary: See 1229 * http://nntp.perl.org/group/perl.perl5.porters/257169 1230 */ 1231 1232 #define PERLSI_UNKNOWN -1 1233 #define PERLSI_UNDEF 0 1234 #define PERLSI_MAIN 1 1235 #define PERLSI_MAGIC 2 1236 #define PERLSI_SORT 3 1237 #define PERLSI_SIGNAL 4 1238 #define PERLSI_OVERLOAD 5 1239 #define PERLSI_DESTROY 6 1240 #define PERLSI_WARNHOOK 7 1241 #define PERLSI_DIEHOOK 8 1242 #define PERLSI_REQUIRE 9 1243 #define PERLSI_MULTICALL 10 1244 #define PERLSI_REGCOMP 11 1245 1246 struct stackinfo { 1247 AV * si_stack; /* stack for current runlevel */ 1248 PERL_CONTEXT * si_cxstack; /* context stack for runlevel */ 1249 struct stackinfo * si_prev; 1250 struct stackinfo * si_next; 1251 I32 si_cxix; /* current context index */ 1252 I32 si_cxmax; /* maximum allocated index */ 1253 I32 si_cxsubix; /* topmost sub/eval/format */ 1254 I32 si_type; /* type of runlevel */ 1255 I32 si_markoff; /* offset where markstack begins for us. 1256 * currently used only with DEBUGGING, 1257 * but not #ifdef-ed for bincompat */ 1258 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 1259 /* high water mark: for checking if the stack was correctly extended / 1260 * tested for extension by each pp function */ 1261 SSize_t si_stack_hwm; 1262 #endif 1263 1264 }; 1265 1266 /* 1267 =for apidoc Ay||PERL_SI 1268 Use this typedef to declare variables that are to hold C<struct stackinfo>. 1269 1270 =cut 1271 */ 1272 typedef struct stackinfo PERL_SI; 1273 1274 #define cxstack (PL_curstackinfo->si_cxstack) 1275 #define cxstack_ix (PL_curstackinfo->si_cxix) 1276 #define cxstack_max (PL_curstackinfo->si_cxmax) 1277 1278 #ifdef DEBUGGING 1279 # define SET_MARK_OFFSET \ 1280 PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack 1281 #else 1282 # define SET_MARK_OFFSET NOOP 1283 #endif 1284 1285 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 1286 # define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0) 1287 #else 1288 # define PUSHSTACK_INIT_HWM(si) NOOP 1289 #endif 1290 1291 #define PUSHSTACKi(type) \ 1292 STMT_START { \ 1293 PERL_SI *next = PL_curstackinfo->si_next; \ 1294 DEBUG_l({ \ 1295 int i = 0; PERL_SI *p = PL_curstackinfo; \ 1296 while (p) { i++; p = p->si_prev; } \ 1297 Perl_deb(aTHX_ "push STACKINFO %d in %s at %s:%d\n", \ 1298 i, SAFE_FUNCTION__, __FILE__, __LINE__);}) \ 1299 if (!next) { \ 1300 next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \ 1301 next->si_prev = PL_curstackinfo; \ 1302 PL_curstackinfo->si_next = next; \ 1303 } \ 1304 next->si_type = type; \ 1305 next->si_cxix = -1; \ 1306 next->si_cxsubix = -1; \ 1307 PUSHSTACK_INIT_HWM(next); \ 1308 AvFILLp(next->si_stack) = 0; \ 1309 SWITCHSTACK(PL_curstack,next->si_stack); \ 1310 PL_curstackinfo = next; \ 1311 SET_MARK_OFFSET; \ 1312 } STMT_END 1313 1314 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN) 1315 1316 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by 1317 * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */ 1318 #define POPSTACK \ 1319 STMT_START { \ 1320 dSP; \ 1321 PERL_SI * const prev = PL_curstackinfo->si_prev; \ 1322 DEBUG_l({ \ 1323 int i = -1; PERL_SI *p = PL_curstackinfo; \ 1324 while (p) { i++; p = p->si_prev; } \ 1325 Perl_deb(aTHX_ "pop STACKINFO %d in %s at %s:%d\n", \ 1326 i, SAFE_FUNCTION__, __FILE__, __LINE__);}) \ 1327 if (!prev) { \ 1328 Perl_croak_popstack(); \ 1329 } \ 1330 SWITCHSTACK(PL_curstack,prev->si_stack); \ 1331 /* don't free prev here, free them all at the END{} */ \ 1332 PL_curstackinfo = prev; \ 1333 } STMT_END 1334 1335 #define POPSTACK_TO(s) \ 1336 STMT_START { \ 1337 while (PL_curstack != s) { \ 1338 dounwind(-1); \ 1339 POPSTACK; \ 1340 } \ 1341 } STMT_END 1342 1343 /* 1344 =for apidoc_section $utility 1345 =for apidoc Amn|bool|IN_PERL_COMPILETIME 1346 Returns 1 if this macro is being called during the compilation phase of the 1347 program; otherwise 0; 1348 1349 =for apidoc Amn|bool|IN_PERL_RUNTIME 1350 Returns 1 if this macro is being called during the execution phase of the 1351 program; otherwise 0; 1352 1353 =cut 1354 */ 1355 #define IN_PERL_COMPILETIME cBOOL(PL_curcop == &PL_compiling) 1356 #define IN_PERL_RUNTIME cBOOL(PL_curcop != &PL_compiling) 1357 1358 /* 1359 =for apidoc_section $multicall 1360 1361 =for apidoc Amn;||dMULTICALL 1362 Declare local variables for a multicall. See L<perlcall/LIGHTWEIGHT CALLBACKS>. 1363 1364 =for apidoc Am;||PUSH_MULTICALL|CV* the_cv 1365 Opening bracket for a lightweight callback. 1366 See L<perlcall/LIGHTWEIGHT CALLBACKS>. 1367 1368 =for apidoc Amn;||MULTICALL 1369 Make a lightweight callback. See L<perlcall/LIGHTWEIGHT CALLBACKS>. 1370 1371 =for apidoc Amn;||POP_MULTICALL 1372 Closing bracket for a lightweight callback. 1373 See L<perlcall/LIGHTWEIGHT CALLBACKS>. 1374 1375 =cut 1376 */ 1377 1378 #define dMULTICALL \ 1379 OP *multicall_cop; \ 1380 bool multicall_oldcatch 1381 1382 #define PUSH_MULTICALL(the_cv) \ 1383 PUSH_MULTICALL_FLAGS(the_cv, 0) 1384 1385 /* Like PUSH_MULTICALL, but allows you to specify extra flags 1386 * for the CX stack entry (this isn't part of the public API) */ 1387 1388 #define PUSH_MULTICALL_FLAGS(the_cv, flags) \ 1389 STMT_START { \ 1390 PERL_CONTEXT *cx; \ 1391 CV * const _nOnclAshIngNamE_ = the_cv; \ 1392 CV * const cv = _nOnclAshIngNamE_; \ 1393 PADLIST * const padlist = CvPADLIST(cv); \ 1394 multicall_oldcatch = CATCH_GET; \ 1395 CATCH_SET(TRUE); \ 1396 PUSHSTACKi(PERLSI_MULTICALL); \ 1397 cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme, \ 1398 PL_stack_sp, PL_savestack_ix); \ 1399 cx_pushsub(cx, cv, NULL, 0); \ 1400 SAVEOP(); \ 1401 if (!(flags & CXp_SUB_RE_FAKE)) \ 1402 CvDEPTH(cv)++; \ 1403 if (CvDEPTH(cv) >= 2) \ 1404 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ 1405 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ 1406 multicall_cop = CvSTART(cv); \ 1407 } STMT_END 1408 1409 #define MULTICALL \ 1410 STMT_START { \ 1411 PL_op = multicall_cop; \ 1412 CALLRUNOPS(aTHX); \ 1413 } STMT_END 1414 1415 #define POP_MULTICALL \ 1416 STMT_START { \ 1417 PERL_CONTEXT *cx; \ 1418 cx = CX_CUR(); \ 1419 CX_LEAVE_SCOPE(cx); \ 1420 cx_popsub_common(cx); \ 1421 gimme = cx->blk_gimme; \ 1422 PERL_UNUSED_VAR(gimme); /* for API */ \ 1423 cx_popblock(cx); \ 1424 CX_POP(cx); \ 1425 POPSTACK; \ 1426 CATCH_SET(multicall_oldcatch); \ 1427 SPAGAIN; \ 1428 } STMT_END 1429 1430 /* Change the CV of an already-pushed MULTICALL CxSUB block. 1431 * (this isn't part of the public API) */ 1432 1433 #define CHANGE_MULTICALL_FLAGS(the_cv, flags) \ 1434 STMT_START { \ 1435 CV * const _nOnclAshIngNamE_ = the_cv; \ 1436 CV * const cv = _nOnclAshIngNamE_; \ 1437 PADLIST * const padlist = CvPADLIST(cv); \ 1438 PERL_CONTEXT *cx = CX_CUR(); \ 1439 assert(CxMULTICALL(cx)); \ 1440 cx_popsub_common(cx); \ 1441 cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ 1442 cx_pushsub(cx, cv, NULL, 0); \ 1443 if (!(flags & CXp_SUB_RE_FAKE)) \ 1444 CvDEPTH(cv)++; \ 1445 if (CvDEPTH(cv) >= 2) \ 1446 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ 1447 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ 1448 multicall_cop = CvSTART(cv); \ 1449 } STMT_END 1450 /* 1451 * ex: set ts=8 sts=4 sw=4 et: 1452 */ 1453