cop.h

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