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 =for apidoc_section 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;       /* name of file this command is from */
 407 #else
 408     HV *        cop_stash;      /* package line was compiled in */
 409     GV *        cop_filegv;     /* name of GV file this command 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 /* Above: no threads; Below yes threads */
 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) /* +2 for '_<' */         \
 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 =for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags
 485
 486 Look up the hint entry in the cop C<cop> with the key specified by
 487 C<keypv> and C<keylen>.  If C<flags> has the C<COPHH_KEY_UTF8> bit set,
 488 the key octets are interpreted as UTF-8, otherwise they are interpreted
 489 as Latin-1.  C<hash> is a precomputed hash of the key string, or zero if
 490 it has not been precomputed.  Returns a mortal scalar copy of the value
 491 associated with the key, or C<&PL_sv_placeholder> if there is no value
 492 associated with the key.
 493
 494 =cut
 495 */
 496
 497 #define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \
 498     cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags)
 499
 500 /*
 501 =for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|"key"|U32 flags
 502
 503 Like L</cop_hints_fetch_pvn>, but takes a literal string
 504 instead of a string/length pair, and no precomputed hash.
 505
 506 =cut
 507 */
 508
 509 #define cop_hints_fetch_pvs(cop, key, flags) \
 510     cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags)
 511
 512 /*
 513 =for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags
 514
 515 Like L</cop_hints_fetch_pvn>, but takes a nul-terminated string instead
 516 of a string/length pair.
 517
 518 =cut
 519 */
 520
 521 #define cop_hints_fetch_pv(cop, key, hash, flags) \
 522     cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags)
 523
 524 /*
 525 =for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags
 526
 527 Like L</cop_hints_fetch_pvn>, but takes a Perl scalar instead of a
 528 string/length pair.
 529
 530 =cut
 531 */
 532
 533 #define cop_hints_fetch_sv(cop, key, hash, flags) \
 534     cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags)
 535
 536 /*
 537 =for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags
 538
 539 Generates and returns a standard Perl hash representing the full set of
 540 hint entries in the cop C<cop>.  C<flags> is currently unused and must
 541 be zero.
 542
 543 =cut
 544 */
 545
 546 #define cop_hints_2hv(cop, flags) \
 547     cophh_2hv(CopHINTHASH_get(cop), flags)
 548
 549 /*
 550 =for apidoc Am|const char *|CopLABEL|COP *const cop
 551
 552 Returns the label attached to a cop.
 553
 554 =for apidoc Am|const char *|CopLABEL_len|COP *const cop|STRLEN *len
 555
 556 Returns the label attached to a cop, and stores its length in bytes into
 557 C<*len>.
 558
 559 =for apidoc Am|const char *|CopLABEL_len_flags|COP *const cop|STRLEN *len|U32 *flags
 560
 561 Returns the label attached to a cop, and stores its length in bytes into
 562 C<*len>.  Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
 563
 564 =cut
 565 */
 566
 567 #define CopLABEL(c)  Perl_cop_fetch_label(aTHX_ (c), NULL, NULL)
 568 #define CopLABEL_len(c,len)  Perl_cop_fetch_label(aTHX_ (c), len, NULL)
 569 #define CopLABEL_len_flags(c,len,flags)  Perl_cop_fetch_label(aTHX_ (c), len, flags)
 570 #define CopLABEL_alloc(pv)      ((pv)?savepv(pv):NULL)
 571
 572 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
 573 #define CopLINE(c)              ((c)->cop_line)
 574 #define CopLINE_inc(c)          (++CopLINE(c))
 575 #define CopLINE_dec(c)          (--CopLINE(c))
 576 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
 577
 578 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
 579 #define OutCopFILE(c) CopFILE(c)
 580
 581 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
 582 #define CopHINTS_set(c, h)      STMT_START {                            \
 583                                     (c)->cop_hints = (h);               \
 584                                 } STMT_END
 585
 586 /*
 587  * Here we have some enormously heavy (or at least ponderous) wizardry.
 588  */
 589
 590 /* subroutine context */
 591 struct block_sub {
 592     OP *        retop;  /* op to execute on exit from sub */
 593     I32         old_cxsubix;  /* previous value of si_cxsubix */
 594     /* Above here is the same for sub, format and eval.  */
 595     PAD         *prevcomppad; /* the caller's PL_comppad */
 596     CV *        cv;
 597     /* Above here is the same for sub and format.  */
 598     I32         olddepth;
 599     AV          *savearray;
 600 };
 601
 602
 603 /* format context */
 604 struct block_format {
 605     OP *        retop;  /* op to execute on exit from sub */
 606     I32         old_cxsubix;  /* previous value of si_cxsubix */
 607     /* Above here is the same for sub, format and eval.  */
 608     PAD         *prevcomppad; /* the caller's PL_comppad */
 609     CV *        cv;
 610     /* Above here is the same for sub and format.  */
 611     GV *        gv;
 612     GV *        dfoutgv;
 613 };
 614
 615 /* return a pointer to the current context */
 616
 617 #define CX_CUR() (&cxstack[cxstack_ix])
 618
 619 /* free all savestack items back to the watermark of the specified context */
 620
 621 #define CX_LEAVE_SCOPE(cx) LEAVE_SCOPE(cx->blk_oldsaveix)
 622
 623 #ifdef DEBUGGING
 624 /* on debugging builds, poison cx afterwards so we know no code
 625  * uses it - because after doing cxstack_ix--, any ties, exceptions etc
 626  * may overwrite the current stack frame */
 627 #  define CX_POP(cx)                                                   \
 628         assert(CX_CUR() == cx);                                        \
 629         cxstack_ix--;                                                  \
 630         cx = NULL;
 631 #else
 632 #  define CX_POP(cx) cxstack_ix--;
 633 #endif
 634
 635 #define CX_PUSHSUB_GET_LVALUE_MASK(func) \
 636         /* If the context is indeterminate, then only the lvalue */     \
 637         /* flags that the caller also has are applicable.        */     \
 638         (                                                               \
 639            (PL_op->op_flags & OPf_WANT)                                 \
 640                ? OPpENTERSUB_LVAL_MASK                                  \
 641                : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK)           \
 642                    ? 0 : (U8)func(aTHX)                                 \
 643         )
 644
 645 /* Restore old @_ */
 646 #define CX_POP_SAVEARRAY(cx)                                            \
 647     STMT_START {                                                        \
 648         AV *cx_pop_savearray_av = GvAV(PL_defgv);                       \
 649         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
 650         cx->blk_sub.savearray = NULL;                                   \
 651         SvREFCNT_dec(cx_pop_savearray_av);                              \
 652     } STMT_END
 653
 654 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
 655  * leave any (a fast av_clear(ary), basically) */
 656 #define CLEAR_ARGARRAY(ary) \
 657     STMT_START {                                                        \
 658         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
 659         AvARRAY(ary) = AvALLOC(ary);                                    \
 660         AvFILLp(ary) = -1;                                              \
 661     } STMT_END
 662
 663
 664 /* eval context */
 665 struct block_eval {
 666     OP *        retop;  /* op to execute on exit from eval */
 667     I32         old_cxsubix;  /* previous value of si_cxsubix */
 668     /* Above here is the same for sub, format and eval.  */
 669     SV *        old_namesv;
 670     OP *        old_eval_root;
 671     SV *        cur_text;
 672     CV *        cv;
 673     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
 674 };
 675
 676 /* If we ever need more than 512 op types, change the shift from 7.
 677    blku_gimme is actually also only 2 bits, so could be merged with something.
 678 */
 679
 680 /* blk_u16 bit usage for eval contexts: */
 681
 682 #define CxOLD_IN_EVAL(cx)       (((cx)->blk_u16) & 0x3F) /* saved PL in_eval */
 683 #define CxEVAL_TXT_REFCNTED(cx) (((cx)->blk_u16) & 0x40) /* cur_text rc++ */
 684 #define CxOLD_OP_TYPE(cx)       (((cx)->blk_u16) >> 7)   /* type of eval op */
 685
 686 /* loop context */
 687 struct block_loop {
 688     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
 689     union {     /* different ways of locating the iteration variable */
 690         SV      **svp; /* for lexicals: address of pad slot */
 691         GV      *gv;   /* for package vars */
 692     } itervar_u;
 693     SV          *itersave; /* the original iteration var */
 694     union {
 695         struct { /* CXt_LOOP_ARY, C<for (@ary)>  */
 696             AV *ary; /* array being iterated over */
 697             IV  ix;   /* index relative to base of array */
 698         } ary;
 699         struct { /* CXt_LOOP_LIST, C<for (list)> */
 700             I32 basesp; /* first element of list on stack */
 701             IV  ix;      /* index relative to basesp */
 702         } stack;
 703         struct { /* CXt_LOOP_LAZYIV, C<for (1..9)> */
 704             IV cur;
 705             IV end;
 706         } lazyiv;
 707         struct { /* CXt_LOOP_LAZYSV C<for ('a'..'z')> */
 708             SV * cur;
 709             SV * end; /* maxiumum value (or minimum in reverse) */
 710         } lazysv;
 711     } state_u;
 712 #ifdef USE_ITHREADS
 713     PAD *oldcomppad; /* needed to map itervar_u.svp during thread clone */
 714 #endif
 715 };
 716
 717 #define CxITERVAR(c)                                    \
 718         (CxPADLOOP(c)                                   \
 719             ? (c)->blk_loop.itervar_u.svp               \
 720             : ((c)->cx_type & CXp_FOR_GV)               \
 721                 ? &GvSV((c)->blk_loop.itervar_u.gv)     \
 722                 : (SV **)&(c)->blk_loop.itervar_u.gv)
 723
 724 #define CxLABEL(c)      (0 + CopLABEL((c)->blk_oldcop))
 725 #define CxLABEL_len(c,len)      (0 + CopLABEL_len((c)->blk_oldcop, len))
 726 #define CxLABEL_len_flags(c,len,flags)  (0 + CopLABEL_len_flags((c)->blk_oldcop, len, flags))
 727 #define CxHASARGS(c)    (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS)
 728
 729 /* CxLVAL(): the lval flags of the call site: the relevant flag bits from
 730  * the op_private field of the calling pp_entersub (or its caller's caller
 731  * if the caller's lvalue context isn't known):
 732  *  OPpLVAL_INTRO:  sub used in lvalue context, e.g. f() = 1;
 733  *  OPpENTERSUB_INARGS (in conjunction with OPpLVAL_INTRO): the
 734  *      function is being used as a sub arg or as a referent, e.g.
 735  *      g(...,f(),...)  or $r = \f()
 736  *  OPpDEREF: 2-bit mask indicating e.g. f()->[0].
 737  *  Note the contrast with CvLVALUE(), which is a property of the sub
 738  *  rather than the call site.
 739  */
 740 #define CxLVAL(c)       (0 + ((c)->blk_u16 & 0xff))
 741
 742
 743
 744 /* given/when context */
 745 struct block_givwhen {
 746         OP *leave_op;
 747         SV *defsv_save; /* the original $_ */
 748 };
 749
 750
 751
 752 /* context common to subroutines, evals and loops */
 753 struct block {
 754     U8          blku_type;      /* what kind of context this is */
 755     U8          blku_gimme;     /* is this block running in list context? */
 756     U16         blku_u16;       /* used by block_sub and block_eval (so far) */
 757     I32         blku_oldsaveix; /* saved PL_savestack_ix */
 758     /* all the fields above must be aligned with same-sized fields as sbu */
 759     I32         blku_oldsp;     /* current sp floor: where nextstate pops to */
 760     I32         blku_oldmarksp; /* mark stack index */
 761     COP *       blku_oldcop;    /* old curcop pointer */
 762     PMOP *      blku_oldpm;     /* values of pattern match vars */
 763     SSize_t     blku_old_tmpsfloor;     /* saved PL_tmps_floor */
 764     I32         blku_oldscopesp;        /* scope stack index */
 765
 766     union {
 767         struct block_sub        blku_sub;
 768         struct block_format     blku_format;
 769         struct block_eval       blku_eval;
 770         struct block_loop       blku_loop;
 771         struct block_givwhen    blku_givwhen;
 772     } blk_u;
 773 };
 774 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
 775 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
 776 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
 777 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
 778 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
 779 #define blk_gimme       cx_u.cx_blk.blku_gimme
 780 #define blk_u16         cx_u.cx_blk.blku_u16
 781 #define blk_oldsaveix   cx_u.cx_blk.blku_oldsaveix
 782 #define blk_old_tmpsfloor cx_u.cx_blk.blku_old_tmpsfloor
 783 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
 784 #define blk_format      cx_u.cx_blk.blk_u.blku_format
 785 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
 786 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
 787 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
 788
 789 #define CX_DEBUG(cx, action)                                            \
 790     DEBUG_l(                                                            \
 791         Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) (save %ld,%ld) at %s:%d\n",\
 792                     (long)cxstack_ix,                                   \
 793                     action,                                             \
 794                     PL_block_type[CxTYPE(cx)],                          \
 795                     (long)PL_scopestack_ix,                             \
 796                     (long)(cx->blk_oldscopesp),                         \
 797                     (long)PL_savestack_ix,                              \
 798                     (long)(cx->blk_oldsaveix),                          \
 799                     __FILE__, __LINE__));
 800
 801
 802
 803 /* substitution context */
 804 struct subst {
 805     U8          sbu_type;       /* same as blku_type */
 806     U8          sbu_rflags;
 807     U16         sbu_rxtainted;
 808     I32         sbu_oldsaveix; /* same as blku_oldsaveix */
 809     /* all the fields above must be aligned with same-sized fields as blk_u */
 810     SSize_t     sbu_iters;
 811     SSize_t     sbu_maxiters;
 812     char *      sbu_orig;
 813     SV *        sbu_dstr;
 814     SV *        sbu_targ;
 815     char *      sbu_s;
 816     char *      sbu_m;
 817     char *      sbu_strend;
 818     void *      sbu_rxres;
 819     REGEXP *    sbu_rx;
 820 };
 821 #define sb_iters        cx_u.cx_subst.sbu_iters
 822 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
 823 #define sb_rflags       cx_u.cx_subst.sbu_rflags
 824 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
 825 #define sb_orig         cx_u.cx_subst.sbu_orig
 826 #define sb_dstr         cx_u.cx_subst.sbu_dstr
 827 #define sb_targ         cx_u.cx_subst.sbu_targ
 828 #define sb_s            cx_u.cx_subst.sbu_s
 829 #define sb_m            cx_u.cx_subst.sbu_m
 830 #define sb_strend       cx_u.cx_subst.sbu_strend
 831 #define sb_rxres        cx_u.cx_subst.sbu_rxres
 832 #define sb_rx           cx_u.cx_subst.sbu_rx
 833
 834 #ifdef PERL_CORE
 835 #  define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(),                        \
 836         cx->blk_oldsaveix = oldsave,                                    \
 837         cx->sb_iters            = iters,                                \
 838         cx->sb_maxiters         = maxiters,                             \
 839         cx->sb_rflags           = r_flags,                              \
 840         cx->sb_rxtainted        = rxtainted,                            \
 841         cx->sb_orig             = orig,                                 \
 842         cx->sb_dstr             = dstr,                                 \
 843         cx->sb_targ             = targ,                                 \
 844         cx->sb_s                = s,                                    \
 845         cx->sb_m                = m,                                    \
 846         cx->sb_strend           = strend,                               \
 847         cx->sb_rxres            = NULL,                                 \
 848         cx->sb_rx               = rx,                                   \
 849         cx->cx_type             = CXt_SUBST | (once ? CXp_ONCE : 0);    \
 850         rxres_save(&cx->sb_rxres, rx);                                  \
 851         (void)ReREFCNT_inc(rx);                                         \
 852         SvREFCNT_inc_void_NN(targ)
 853
 854 #  define CX_POPSUBST(cx) \
 855     STMT_START {                                                        \
 856         REGEXP *re;                                                     \
 857         assert(CxTYPE(cx) == CXt_SUBST);                                \
 858         rxres_free(&cx->sb_rxres);                                      \
 859         re = cx->sb_rx;                                                 \
 860         cx->sb_rx = NULL;                                               \
 861         ReREFCNT_dec(re);                                               \
 862         SvREFCNT_dec_NN(cx->sb_targ);                                   \
 863     } STMT_END
 864 #endif
 865
 866 #define CxONCE(cx)              ((cx)->cx_type & CXp_ONCE)
 867
 868 struct context {
 869     union {
 870         struct block    cx_blk;
 871         struct subst    cx_subst;
 872     } cx_u;
 873 };
 874 #define cx_type cx_u.cx_subst.sbu_type
 875
 876 /* If you re-order these, there is also an array of uppercase names in perl.h
 877    and a static array of context names in pp_ctl.c  */
 878 #define CXTYPEMASK      0xf
 879 #define CXt_NULL        0 /* currently only used for sort BLOCK */
 880 #define CXt_WHEN        1
 881 #define CXt_BLOCK       2
 882 /* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a
 883    jump table in pp_ctl.c
 884    The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c
 885 */
 886 #define CXt_GIVEN       3
 887
 888 /* be careful of the ordering of these five. Macros like CxTYPE_is_LOOP,
 889  * CxFOREACH compare ranges */
 890 #define CXt_LOOP_ARY    4 /* for (@ary)     { ...; } */
 891 #define CXt_LOOP_LAZYSV 5 /* for ('a'..'z') { ...; } */
 892 #define CXt_LOOP_LAZYIV 6 /* for (1..9)     { ...; } */
 893 #define CXt_LOOP_LIST   7 /* for (1,2,3)    { ...; } */
 894 #define CXt_LOOP_PLAIN  8 /* while (...)    { ...; }
 895                              or plain block { ...; } */
 896 #define CXt_SUB         9
 897 #define CXt_FORMAT     10
 898 #define CXt_EVAL       11
 899 #define CXt_SUBST      12
 900 /* SUBST doesn't feature in all switch statements.  */
 901
 902 /* private flags for CXt_SUB and CXt_FORMAT */
 903 #define CXp_MULTICALL   0x10    /* part of a multicall (so don't tear down
 904                                    context on exit). (not CXt_FORMAT) */
 905 #define CXp_HASARGS     0x20
 906 #define CXp_SUB_RE      0x40    /* code called within regex, i.e. (?{}) */
 907 #define CXp_SUB_RE_FAKE 0x80    /* fake sub CX for (?{}) in current scope */
 908
 909 /* private flags for CXt_EVAL */
 910 #define CXp_REAL        0x20    /* truly eval'', not a lookalike */
 911 #define CXp_TRYBLOCK    0x40    /* eval{}, not eval'' or similar */
 912
 913 /* private flags for CXt_LOOP */
 914
 915 /* this is only set in conjunction with CXp_FOR_GV */
 916 #define CXp_FOR_DEF     0x10    /* foreach using $_ */
 917 /* these 3 are mutually exclusive */
 918 #define CXp_FOR_LVREF   0x20    /* foreach using \$var */
 919 #define CXp_FOR_GV      0x40    /* foreach using package var */
 920 #define CXp_FOR_PAD     0x80    /* foreach using lexical var */
 921
 922 #define CxPADLOOP(c)    ((c)->cx_type & CXp_FOR_PAD)
 923
 924 /* private flags for CXt_SUBST */
 925 #define CXp_ONCE        0x10    /* What was sbu_once in struct subst */
 926
 927 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
 928 #define CxTYPE_is_LOOP(c) (   CxTYPE(cx) >= CXt_LOOP_ARY                \
 929                            && CxTYPE(cx) <= CXt_LOOP_PLAIN)
 930 #define CxMULTICALL(c)  ((c)->cx_type & CXp_MULTICALL)
 931 #define CxREALEVAL(c)   (((c)->cx_type & (CXTYPEMASK|CXp_REAL))         \
 932                          == (CXt_EVAL|CXp_REAL))
 933 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK))     \
 934                          == (CXt_EVAL|CXp_TRYBLOCK))
 935 #define CxFOREACH(c)    (   CxTYPE(cx) >= CXt_LOOP_ARY                  \
 936                          && CxTYPE(cx) <= CXt_LOOP_LIST)
 937
 938 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 939
 940 #define G_SCALAR        2
 941 #define G_ARRAY         3
 942 #define G_VOID          1
 943 #define G_WANT          3
 944
 945 /* extra flags for Perl_call_* routines */
 946 #define G_DISCARD         0x4   /* Call FREETMPS.
 947                                    Don't change this without consulting the
 948                                    hash actions codes defined in hv.h */
 949 #define G_EVAL            0x8   /* Assume eval {} around subroutine call. */
 950 #define G_NOARGS         0x10   /* Don't construct a @_ array. */
 951 #define G_KEEPERR        0x20   /* Warn for errors, don't overwrite $@ */
 952 #define G_NODEBUG        0x40   /* Disable debugging at toplevel.  */
 953 #define G_METHOD         0x80   /* Calling method. */
 954 #define G_FAKINGEVAL    0x100   /* Faking an eval context for call_sv or
 955                                    fold_constants. */
 956 #define G_UNDEF_FILL    0x200   /* Fill the stack with &PL_sv_undef
 957                                    A special case for UNSHIFT in
 958                                    Perl_magic_methcall().  */
 959 #define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling
 960                                     Perl_magic_methcall().  */
 961 #define G_RE_REPARSING  0x800   /* compiling a run-time /(?{..})/ */
 962 #define G_METHOD_NAMED 0x1000   /* calling named method, eg without :: or ' */
 963 #define G_RETHROW      0x2000   /* eval_sv(): re-throw any error */
 964
 965 /* flag bits for PL_in_eval */
 966 #define EVAL_NULL       0       /* not in an eval */
 967 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
 968 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
 969 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
 970 #define EVAL_INREQUIRE  8       /* The code is being required. */
 971 #define EVAL_RE_REPARSING 0x10  /* eval_sv() called with G_RE_REPARSING */
 972 /* if adding extra bits, make sure they can fit in CxOLD_OP_TYPE() */
 973
 974 /* Support for switching (stack and block) contexts.
 975  * This ensures magic doesn't invalidate local stack and cx pointers.
 976  * Which one to use (or add) is mostly, but not completely arbitrary:  See
 977  * http://nntp.perl.org/group/perl.perl5.porters/257169
 978  */
 979
 980 #define PERLSI_UNKNOWN          -1
 981 #define PERLSI_UNDEF            0
 982 #define PERLSI_MAIN             1
 983 #define PERLSI_MAGIC            2
 984 #define PERLSI_SORT             3
 985 #define PERLSI_SIGNAL           4
 986 #define PERLSI_OVERLOAD         5
 987 #define PERLSI_DESTROY          6
 988 #define PERLSI_WARNHOOK         7
 989 #define PERLSI_DIEHOOK          8
 990 #define PERLSI_REQUIRE          9
 991 #define PERLSI_MULTICALL       10
 992 #define PERLSI_REGCOMP         11
 993
 994 struct stackinfo {
 995     AV *                si_stack;       /* stack for current runlevel */
 996     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
 997     struct stackinfo *  si_prev;
 998     struct stackinfo *  si_next;
 999     I32                 si_cxix;        /* current context index */
1000     I32                 si_cxmax;       /* maximum allocated index */
1001     I32                 si_cxsubix;     /* topmost sub/eval/format */
1002     I32                 si_type;        /* type of runlevel */
1003     I32                 si_markoff;     /* offset where markstack begins for us.
1004                                          * currently used only with DEBUGGING,
1005                                          * but not #ifdef-ed for bincompat */
1006 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
1007 /* high water mark: for checking if the stack was correctly extended /
1008  * tested for extension by each pp function */
1009     SSize_t             si_stack_hwm;
1010 #endif
1011
1012 };
1013
1014 typedef struct stackinfo PERL_SI;
1015
1016 #define cxstack         (PL_curstackinfo->si_cxstack)
1017 #define cxstack_ix      (PL_curstackinfo->si_cxix)
1018 #define cxstack_max     (PL_curstackinfo->si_cxmax)
1019
1020 #ifdef DEBUGGING
1021 #  define       SET_MARK_OFFSET \
1022     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
1023 #else
1024 #  define       SET_MARK_OFFSET NOOP
1025 #endif
1026
1027 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
1028 #  define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0)
1029 #else
1030 #  define PUSHSTACK_INIT_HWM(si) NOOP
1031 #endif
1032
1033 #define PUSHSTACKi(type) \
1034     STMT_START {                                                        \
1035         PERL_SI *next = PL_curstackinfo->si_next;                       \
1036         DEBUG_l({                                                       \
1037             int i = 0; PERL_SI *p = PL_curstackinfo;                    \
1038             while (p) { i++; p = p->si_prev; }                          \
1039             Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n",              \
1040                          i, __FILE__, __LINE__);})                      \
1041         if (!next) {                                                    \
1042             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
1043             next->si_prev = PL_curstackinfo;                            \
1044             PL_curstackinfo->si_next = next;                            \
1045         }                                                               \
1046         next->si_type = type;                                           \
1047         next->si_cxix = -1;                                             \
1048         next->si_cxsubix = -1;                                          \
1049         PUSHSTACK_INIT_HWM(next);                                       \
1050         AvFILLp(next->si_stack) = 0;                                    \
1051         SWITCHSTACK(PL_curstack,next->si_stack);                        \
1052         PL_curstackinfo = next;                                         \
1053         SET_MARK_OFFSET;                                                \
1054     } STMT_END
1055
1056 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
1057
1058 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
1059  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
1060 #define POPSTACK \
1061     STMT_START {                                                        \
1062         dSP;                                                            \
1063         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
1064         DEBUG_l({                                                       \
1065             int i = -1; PERL_SI *p = PL_curstackinfo;                   \
1066             while (p) { i++; p = p->si_prev; }                          \
1067             Perl_deb(aTHX_ "pop  STACKINFO %d at %s:%d\n",              \
1068                          i, __FILE__, __LINE__);})                      \
1069         if (!prev) {                                                    \
1070             Perl_croak_popstack();                                      \
1071         }                                                               \
1072         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
1073         /* don't free prev here, free them all at the END{} */          \
1074         PL_curstackinfo = prev;                                         \
1075     } STMT_END
1076
1077 #define POPSTACK_TO(s) \
1078     STMT_START {                                                        \
1079         while (PL_curstack != s) {                                      \
1080             dounwind(-1);                                               \
1081             POPSTACK;                                                   \
1082         }                                                               \
1083     } STMT_END
1084
1085 /*
1086 =for apidoc_section Utility Functions
1087 =for apidoc Amn|bool|IN_PERL_COMPILETIME
1088 Returns 1 if this macro is being called during the compilation phase of the
1089 program; otherwise 0;
1090
1091 =for apidoc Amn|bool|IN_PERL_RUNTIME
1092 Returns 1 if this macro is being called during the execution phase of the
1093 program; otherwise 0;
1094
1095 =cut
1096 */
1097 #define IN_PERL_COMPILETIME     cBOOL(PL_curcop == &PL_compiling)
1098 #define IN_PERL_RUNTIME         cBOOL(PL_curcop != &PL_compiling)
1099
1100 /*
1101 =for apidoc_section Multicall Functions
1102
1103 =for apidoc Amns||dMULTICALL
1104 Declare local variables for a multicall.  See L<perlcall/LIGHTWEIGHT CALLBACKS>.
1105
1106 =for apidoc Ams||PUSH_MULTICALL|CV* the_cv
1107 Opening bracket for a lightweight callback.
1108 See L<perlcall/LIGHTWEIGHT CALLBACKS>.
1109
1110 =for apidoc Amns||MULTICALL
1111 Make a lightweight callback.  See L<perlcall/LIGHTWEIGHT CALLBACKS>.
1112
1113 =for apidoc Amns||POP_MULTICALL
1114 Closing bracket for a lightweight callback.
1115 See L<perlcall/LIGHTWEIGHT CALLBACKS>.
1116
1117 =cut
1118 */
1119
1120 #define dMULTICALL \
1121     OP  *multicall_cop;                                                 \
1122     bool multicall_oldcatch
1123
1124 #define PUSH_MULTICALL(the_cv) \
1125     PUSH_MULTICALL_FLAGS(the_cv, 0)
1126
1127 /* Like PUSH_MULTICALL, but allows you to specify extra flags
1128  * for the CX stack entry (this isn't part of the public API) */
1129
1130 #define PUSH_MULTICALL_FLAGS(the_cv, flags) \
1131     STMT_START {                                                        \
1132         PERL_CONTEXT *cx;                                               \
1133         CV * const _nOnclAshIngNamE_ = the_cv;                          \
1134         CV * const cv = _nOnclAshIngNamE_;                              \
1135         PADLIST * const padlist = CvPADLIST(cv);                        \
1136         multicall_oldcatch = CATCH_GET;                                 \
1137         CATCH_SET(TRUE);                                                \
1138         PUSHSTACKi(PERLSI_MULTICALL);                                   \
1139         cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), (U8)gimme,     \
1140                   PL_stack_sp, PL_savestack_ix);                        \
1141         cx_pushsub(cx, cv, NULL, 0);                                    \
1142         SAVEOP();                                                       \
1143         if (!(flags & CXp_SUB_RE_FAKE))                                 \
1144             CvDEPTH(cv)++;                                              \
1145         if (CvDEPTH(cv) >= 2)                                           \
1146             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
1147         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
1148         multicall_cop = CvSTART(cv);                                    \
1149     } STMT_END
1150
1151 #define MULTICALL \
1152     STMT_START {                                                        \
1153         PL_op = multicall_cop;                                          \
1154         CALLRUNOPS(aTHX);                                               \
1155     } STMT_END
1156
1157 #define POP_MULTICALL \
1158     STMT_START {                                                        \
1159         PERL_CONTEXT *cx;                                               \
1160         cx = CX_CUR();                                                  \
1161         CX_LEAVE_SCOPE(cx);                                             \
1162         cx_popsub_common(cx);                                           \
1163         gimme = cx->blk_gimme;                                          \
1164         PERL_UNUSED_VAR(gimme); /* for API */                           \
1165         cx_popblock(cx);                                                \
1166         CX_POP(cx);                                                     \
1167         POPSTACK;                                                       \
1168         CATCH_SET(multicall_oldcatch);                                  \
1169         SPAGAIN;                                                        \
1170     } STMT_END
1171
1172 /* Change the CV of an already-pushed MULTICALL CxSUB block.
1173  * (this isn't part of the public API) */
1174
1175 #define CHANGE_MULTICALL_FLAGS(the_cv, flags) \
1176     STMT_START {                                                        \
1177         CV * const _nOnclAshIngNamE_ = the_cv;                          \
1178         CV * const cv = _nOnclAshIngNamE_;                              \
1179         PADLIST * const padlist = CvPADLIST(cv);                        \
1180         PERL_CONTEXT *cx = CX_CUR();                                    \
1181         assert(CxMULTICALL(cx));                                        \
1182         cx_popsub_common(cx);                                           \
1183         cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags);                    \
1184         cx_pushsub(cx, cv, NULL, 0);                                    \
1185         if (!(flags & CXp_SUB_RE_FAKE))                                 \
1186             CvDEPTH(cv)++;                                              \
1187         if (CvDEPTH(cv) >= 2)                                           \
1188             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
1189         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
1190         multicall_cop = CvSTART(cv);                                    \
1191     } STMT_END
1192 /*
1193  * ex: set ts=8 sts=4 sw=4 et:
1194  */