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