cop.h

   1 /*    cop.h
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006 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 three ops OP_NEXTSTATE, OP_DBSTATE,
  10  * and OP_SETSTATE that (loosely speaking) are separate statements.
  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 start_env initialized when perl starts, and top_env
  18  * points to this initially, so top_env should always be non-null.
  19  *
  20  * Existence of a non-null top_env->je_prev implies it is valid to call
  21  * longjmp() at that runlevel (we make sure start_env.je_prev is always
  22  * null to ensure this).
  23  *
  24  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
  25  * establish a local jmpenv to handle exception traps.  Care must be taken
  26  * to restore the previous value of je_mustcatch before exiting the
  27  * stack frame iff JMPENV_PUSH was not called in that stack frame.
  28  * GSAR 97-03-27
  29  */
  30
  31 struct jmpenv {
  32     struct jmpenv *     je_prev;
  33     Sigjmp_buf          je_buf;         /* only for use if !je_throw */
  34     int                 je_ret;         /* last exception thrown */
  35     bool                je_mustcatch;   /* need to call longjmp()? */
  36 };
  37
  38 typedef struct jmpenv JMPENV;
  39
  40 #ifdef OP_IN_REGISTER
  41 #define OP_REG_TO_MEM   PL_opsave = op
  42 #define OP_MEM_TO_REG   op = PL_opsave
  43 #else
  44 #define OP_REG_TO_MEM   NOOP
  45 #define OP_MEM_TO_REG   NOOP
  46 #endif
  47
  48 /*
  49  * How to build the first jmpenv.
  50  *
  51  * top_env needs to be non-zero. It points to an area
  52  * in which longjmp() stuff is stored, as C callstack
  53  * info there at least is thread specific this has to
  54  * be per-thread. Otherwise a 'die' in a thread gives
  55  * that thread the C stack of last thread to do an eval {}!
  56  */
  57
  58 #define JMPENV_BOOTSTRAP \
  59     STMT_START {                                \
  60         Zero(&PL_start_env, 1, JMPENV);         \
  61         PL_start_env.je_ret = -1;               \
  62         PL_start_env.je_mustcatch = TRUE;       \
  63         PL_top_env = &PL_start_env;             \
  64     } STMT_END
  65
  66 /*
  67  *   PERL_FLEXIBLE_EXCEPTIONS
  68  *
  69  * All the flexible exceptions code has been removed.
  70  * See the following threads for details:
  71  *
  72  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
  73  *
  74  * Joshua's original patches (which weren't applied) and discussion:
  75  *
  76  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
  77  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
  78  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
  79  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
  80  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
  81  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
  82  *
  83  * Chip's reworked patch and discussion:
  84  *
  85  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
  86  *
  87  * The flaw in these patches (which went unnoticed at the time) was
  88  * that they moved some code that could potentially die() out of the
  89  * region protected by the setjmp()s.  This caused exceptions within
  90  * END blocks and such to not be handled by the correct setjmp().
  91  *
  92  * The original patches that introduces flexible exceptions were:
  93  *
  94  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=3386
  95  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=5162
  96  */
  97
  98 #define dJMPENV         JMPENV cur_env
  99
 100 #define JMPENV_PUSH(v) \
 101     STMT_START {                                                        \
 102         DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n",     \
 103                          (void*)&cur_env, (void*)PL_top_env));                  \
 104         cur_env.je_prev = PL_top_env;                                   \
 105         OP_REG_TO_MEM;                                                  \
 106         cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK);              \
 107         OP_MEM_TO_REG;                                                  \
 108         PL_top_env = &cur_env;                                          \
 109         cur_env.je_mustcatch = FALSE;                                   \
 110         (v) = cur_env.je_ret;                                           \
 111     } STMT_END
 112
 113 #define JMPENV_POP \
 114     STMT_START {                                                        \
 115         DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n",    \
 116                          (void*)PL_top_env, (void*)cur_env.je_prev));                   \
 117         PL_top_env = cur_env.je_prev;                                   \
 118     } STMT_END
 119
 120 #define JMPENV_JUMP(v) \
 121     STMT_START {                                                \
 122         OP_REG_TO_MEM;                                          \
 123         if (PL_top_env->je_prev)                                \
 124             PerlProc_longjmp(PL_top_env->je_buf, (v));          \
 125         if ((v) == 2)                                           \
 126             PerlProc_exit(STATUS_EXIT);                         \
 127         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
 128         PerlProc_exit(1);                                       \
 129     } STMT_END
 130
 131 #define CATCH_GET               (PL_top_env->je_mustcatch)
 132 #define CATCH_SET(v)            (PL_top_env->je_mustcatch = (v))
 133
 134
 135
 136 struct cop {
 137     BASEOP
 138     char *      cop_label;      /* label for this construct */
 139 #ifdef USE_ITHREADS
 140     char *      cop_stashpv;    /* package line was compiled in */
 141     char *      cop_file;       /* file name the following line # is from */
 142 #else
 143     HV *        cop_stash;      /* package line was compiled in */
 144     GV *        cop_filegv;     /* file the following line # is from */
 145 #endif
 146     U32         cop_hints;      /* hints bits from pragmata */
 147     U32         cop_seq;        /* parse sequence number */
 148     line_t      cop_line;       /* line # of this command */
 149     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
 150     STRLEN *    cop_warnings;   /* lexical warnings bitmask */
 151     /* compile time state of %^H.  See the comment in op.c for how this is
 152        used to recreate a hash to return from caller.  */
 153     struct refcounted_he * cop_hints_hash;
 154 };
 155
 156 #ifdef USE_ITHREADS
 157 #  define CopFILE(c)            ((c)->cop_file)
 158 #  define CopFILEGV(c)          (CopFILE(c) \
 159                                  ? gv_fetchfile(CopFILE(c)) : NULL)
 160
 161 #  ifdef NETWARE
 162 #    define CopFILE_set(c,pv)   ((c)->cop_file = savepv(pv))
 163 #  else
 164 #    define CopFILE_set(c,pv)   ((c)->cop_file = savesharedpv(pv))
 165 #  endif
 166
 167 #  define CopFILESV(c)          (CopFILE(c) \
 168                                  ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
 169 #  define CopFILEAV(c)          (CopFILE(c) \
 170                                  ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
 171 #  ifdef DEBUGGING
 172 #    define CopFILEAVx(c)       (assert(CopFILE(c)), \
 173                                    GvAV(gv_fetchfile(CopFILE(c))))
 174 #  else
 175 #    define CopFILEAVx(c)       (GvAV(gv_fetchfile(CopFILE(c))))
 176 #  endif
 177 #  define CopSTASHPV(c)         ((c)->cop_stashpv)
 178
 179 #  ifdef NETWARE
 180 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
 181 #  else
 182 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = savesharedpv(pv))
 183 #  endif
 184
 185 #  define CopSTASH(c)           (CopSTASHPV(c) \
 186                                  ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
 187 #  define CopSTASH_set(c,hv)    CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
 188 #  define CopSTASH_eq(c,hv)     ((hv) && stashpv_hvname_match(c,hv))
 189 #  define CopLABEL(c)           ((c)->cop_label)
 190 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
 191 #  ifdef NETWARE
 192 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
 193 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
 194 #    define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
 195 #    define CopLABEL_alloc(pv)  ((pv)?savepv(pv):NULL)
 196 #  else
 197 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
 198 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
 199 #    define CopLABEL_free(c)    (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
 200 #    define CopLABEL_alloc(pv)  ((pv)?savesharedpv(pv):NULL)
 201 #  endif
 202 #else
 203 #  define CopFILEGV(c)          ((c)->cop_filegv)
 204 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
 205 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
 206 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
 207 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
 208 #  ifdef DEBUGGING
 209 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
 210 #  else
 211 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
 212 # endif
 213 #  define CopFILE(c)            (CopFILESV(c) ? SvPVX(CopFILESV(c)) : NULL)
 214 #  define CopSTASH(c)           ((c)->cop_stash)
 215 #  define CopLABEL(c)           ((c)->cop_label)
 216 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
 217 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
 218    /* cop_stash is not refcounted */
 219 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
 220 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
 221 #  define CopLABEL_alloc(pv)    ((pv)?savepv(pv):NULL)
 222 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
 223 #  define CopSTASH_free(c)
 224 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
 225 #  define CopLABEL_free(c)      (Safefree(CopLABEL(c)),(CopLABEL(c) = NULL))
 226
 227 #endif /* USE_ITHREADS */
 228
 229 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
 230 #define CopLINE(c)              ((c)->cop_line)
 231 #define CopLINE_inc(c)          (++CopLINE(c))
 232 #define CopLINE_dec(c)          (--CopLINE(c))
 233 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
 234
 235 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
 236 #ifdef MACOS_TRADITIONAL
 237 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
 238 #else
 239 #  define OutCopFILE(c) CopFILE(c)
 240 #endif
 241
 242 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
 243    HINT_ARYBASE is set to indicate this.
 244    Setting it is ineficient due to the need to create 2 mortal SVs, but as
 245    using $[ is highly discouraged, no sane Perl code will be using it.  */
 246 #define CopARYBASE_get(c)       \
 247         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
 248          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
 249                                          "$[", 2, 0, 0))                \
 250          : 0)
 251 #define CopARYBASE_set(c, b) STMT_START { \
 252         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
 253             (c)->cop_hints |= HINT_ARYBASE;                             \
 254             if ((c) == &PL_compiling)                                   \
 255                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
 256             (c)->cop_hints_hash                                         \
 257                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
 258                                         sv_2mortal(newSVpvs("$[")),     \
 259                                         sv_2mortal(newSViv(b)));        \
 260         }                                                               \
 261     } STMT_END
 262
 263 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
 264 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
 265 #define CopHINTS_set(c, h)      STMT_START {                            \
 266                                     (c)->cop_hints = (h);               \
 267                                 } STMT_END
 268
 269 /*
 270  * Here we have some enormously heavy (or at least ponderous) wizardry.
 271  */
 272
 273 /* subroutine context */
 274 struct block_sub {
 275     CV *        cv;
 276     GV *        gv;
 277     GV *        dfoutgv;
 278     AV *        savearray;
 279     AV *        argarray;
 280     I32         olddepth;
 281     U8          hasargs;
 282     U8          lval;           /* XXX merge lval and hasargs? */
 283     PAD         *oldcomppad;
 284     OP *        retop;  /* op to execute on exit from sub */
 285 };
 286
 287 /* base for the next two macros. Don't use directly.
 288  * Note that the refcnt of the cv is incremented twice;  The CX one is
 289  * decremented by LEAVESUB, the other by LEAVE. */
 290
 291 #define PUSHSUB_BASE(cx)                                                \
 292         cx->blk_sub.cv = cv;                                            \
 293         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
 294         cx->blk_sub.hasargs = hasargs;                                  \
 295         cx->blk_sub.retop = NULL;                                       \
 296         if (!CvDEPTH(cv)) {                                             \
 297             SvREFCNT_inc_simple_void_NN(cv);                            \
 298             SvREFCNT_inc_simple_void_NN(cv);                            \
 299             SAVEFREESV(cv);                                             \
 300         }
 301
 302
 303 #define PUSHSUB(cx)                                                     \
 304         PUSHSUB_BASE(cx)                                                \
 305         cx->blk_sub.lval = PL_op->op_private &                          \
 306                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
 307
 308 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
 309 #define PUSHSUB_DB(cx)                                                  \
 310         PUSHSUB_BASE(cx)                                                \
 311         cx->blk_sub.lval = 0;
 312
 313
 314 #define PUSHFORMAT(cx)                                                  \
 315         cx->blk_sub.cv = cv;                                            \
 316         cx->blk_sub.gv = gv;                                            \
 317         cx->blk_sub.retop = NULL;                                       \
 318         cx->blk_sub.hasargs = 0;                                        \
 319         cx->blk_sub.dfoutgv = PL_defoutgv;                              \
 320         SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
 321
 322 #define POP_SAVEARRAY()                                         \
 323     STMT_START {                                                        \
 324         SvREFCNT_dec(GvAV(PL_defgv));                                   \
 325         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
 326     } STMT_END
 327
 328 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
 329  * leave any (a fast av_clear(ary), basically) */
 330 #define CLEAR_ARGARRAY(ary) \
 331     STMT_START {                                                        \
 332         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
 333         AvARRAY(ary) = AvALLOC(ary);                                    \
 334         AvFILLp(ary) = -1;                                              \
 335     } STMT_END
 336
 337 #define POPSUB(cx,sv)                                                   \
 338     STMT_START {                                                        \
 339         if (cx->blk_sub.hasargs) {                                      \
 340             POP_SAVEARRAY();                                            \
 341             /* abandon @_ if it got reified */                          \
 342             if (AvREAL(cx->blk_sub.argarray)) {                         \
 343                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
 344                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
 345                 cx->blk_sub.argarray = newAV();                         \
 346                 av_extend(cx->blk_sub.argarray, fill);                  \
 347                 AvREIFY_only(cx->blk_sub.argarray);                     \
 348                 CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray;       \
 349             }                                                           \
 350             else {                                                      \
 351                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
 352             }                                                           \
 353         }                                                               \
 354         sv = (SV*)cx->blk_sub.cv;                                       \
 355         if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))            \
 356             sv = NULL;                                          \
 357     } STMT_END
 358
 359 #define LEAVESUB(sv)                                                    \
 360     STMT_START {                                                        \
 361         if (sv)                                                         \
 362             SvREFCNT_dec(sv);                                           \
 363     } STMT_END
 364
 365 #define POPFORMAT(cx)                                                   \
 366         setdefout(cx->blk_sub.dfoutgv);                                 \
 367         SvREFCNT_dec(cx->blk_sub.dfoutgv);
 368
 369 /* eval context */
 370 struct block_eval {
 371     U8          old_in_eval;
 372     U16         old_op_type;
 373     SV *        old_namesv;
 374     OP *        old_eval_root;
 375     SV *        cur_text;
 376     CV *        cv;
 377     OP *        retop;  /* op to execute on exit from eval */
 378     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
 379 };
 380
 381 #define PUSHEVAL(cx,n,fgv)                                              \
 382     STMT_START {                                                        \
 383         cx->blk_eval.old_in_eval = PL_in_eval;                          \
 384         cx->blk_eval.old_op_type = PL_op->op_type;                      \
 385         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
 386         cx->blk_eval.old_eval_root = PL_eval_root;                      \
 387         cx->blk_eval.cur_text = PL_linestr;                             \
 388         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
 389         cx->blk_eval.retop = NULL;                                      \
 390         cx->blk_eval.cur_top_env = PL_top_env;                          \
 391     } STMT_END
 392
 393 #define POPEVAL(cx)                                                     \
 394     STMT_START {                                                        \
 395         PL_in_eval = cx->blk_eval.old_in_eval;                          \
 396         optype = cx->blk_eval.old_op_type;                              \
 397         PL_eval_root = cx->blk_eval.old_eval_root;                      \
 398         if (cx->blk_eval.old_namesv)                                    \
 399             sv_2mortal(cx->blk_eval.old_namesv);                        \
 400     } STMT_END
 401
 402 /* loop context */
 403 struct block_loop {
 404     char *      label;
 405     I32         resetsp;
 406     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
 407     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
 408         why next_op is conditionally defined below.)  */
 409 #ifdef USE_ITHREADS
 410     void *      iterdata;
 411     PAD         *oldcomppad;
 412 #else
 413     OP *        next_op;
 414     SV **       itervar;
 415 #endif
 416     SV *        itersave;
 417     /* (from inspection of source code) for a .. range of strings this is the
 418        current string.  */
 419     SV *        iterlval;
 420     /* (from inspection of source code) for a foreach loop this is the array
 421        being iterated over. For a .. range of numbers it's the current value.
 422        A check is often made on the SvTYPE of iterary to determine whether
 423        we are iterating over an array or a range. (numbers or strings)  */
 424     AV *        iterary;
 425     IV          iterix;
 426     /* (from inspection of source code) for a .. range of numbers this is the
 427        maximum value.  */
 428     IV          itermax;
 429 };
 430 /* It might be possible to squeeze this structure further. As best I can tell
 431    itermax and iterlval are never used at the same time, so it might be possible
 432    to make them into a union. However, I'm not confident that there are enough
 433    flag bits/NULLable pointers in this structure alone to encode which is
 434    active. There is, however, U8 of space free in struct block, which could be
 435    used. Right now it may not be worth squeezing this structure further, as it's
 436    the largest part of struct block, and currently struct block is 64 bytes on
 437    an ILP32 system, which will give good cache alignment.
 438 */
 439
 440 #ifdef USE_ITHREADS
 441 #  define CxITERVAR(c)                                                  \
 442         ((c)->blk_loop.iterdata                                         \
 443          ? (CxPADLOOP(cx)                                               \
 444             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
 445                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
 446             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
 447          : (SV**)NULL)
 448 #  define CX_ITERDATA_SET(cx,idata)                                     \
 449         CX_CURPAD_SAVE(cx->blk_loop);                                   \
 450         if ((cx->blk_loop.iterdata = (idata)))                          \
 451             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 452         else                                                            \
 453             cx->blk_loop.itersave = NULL;
 454 #else
 455 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
 456 #  define CX_ITERDATA_SET(cx,ivar)                                      \
 457         if ((cx->blk_loop.itervar = (SV**)(ivar)))                      \
 458             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 459         else                                                            \
 460             cx->blk_loop.itersave = NULL;
 461 #endif
 462
 463 #ifdef USE_ITHREADS
 464 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
 465 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
 466 #else
 467 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
 468 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
 469 #endif
 470
 471 #define PUSHLOOP(cx, dat, s)                                            \
 472         cx->blk_loop.label = PL_curcop->cop_label;                      \
 473         cx->blk_loop.resetsp = s - PL_stack_base;                       \
 474         cx->blk_loop.my_op = cLOOP;                                     \
 475         PUSHLOOP_OP_NEXT;                                               \
 476         cx->blk_loop.iterlval = NULL;                                   \
 477         cx->blk_loop.iterary = NULL;                                    \
 478         cx->blk_loop.iterix = -1;                                       \
 479         CX_ITERDATA_SET(cx,dat);
 480
 481 #define POPLOOP(cx)                                                     \
 482         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
 483         if (CxITERVAR(cx)) {                                            \
 484             if (SvPADMY(cx->blk_loop.itersave)) {                       \
 485                 SV ** const s_v_p = CxITERVAR(cx);                      \
 486                 sv_2mortal(*s_v_p);                                     \
 487                 *s_v_p = cx->blk_loop.itersave;                         \
 488             }                                                           \
 489             else {                                                      \
 490                 SvREFCNT_dec(cx->blk_loop.itersave);                    \
 491             }                                                           \
 492         }                                                               \
 493         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
 494             SvREFCNT_dec(cx->blk_loop.iterary);
 495
 496 /* given/when context */
 497 struct block_givwhen {
 498         OP *leave_op;
 499 };
 500
 501 #define PUSHGIVEN(cx)                                                   \
 502         cx->blk_givwhen.leave_op = cLOGOP->op_other;
 503
 504 #define PUSHWHEN PUSHGIVEN
 505
 506 /* context common to subroutines, evals and loops */
 507 struct block {
 508     U16         blku_type;      /* what kind of context this is */
 509     U8          blku_gimme;     /* is this block running in list context? */
 510     U8          blku_spare;     /* Padding to match with struct subst */
 511     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
 512     COP *       blku_oldcop;    /* old curcop pointer */
 513     I32         blku_oldmarksp; /* mark stack index */
 514     I32         blku_oldscopesp;        /* scope stack index */
 515     PMOP *      blku_oldpm;     /* values of pattern match vars */
 516
 517     union {
 518         struct block_sub        blku_sub;
 519         struct block_eval       blku_eval;
 520         struct block_loop       blku_loop;
 521         struct block_givwhen    blku_givwhen;
 522     } blk_u;
 523 };
 524 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
 525 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
 526 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
 527 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
 528 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
 529 #define blk_gimme       cx_u.cx_blk.blku_gimme
 530 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
 531 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
 532 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
 533 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
 534
 535 /* Enter a block. */
 536 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
 537         cx->cx_type             = t,                                    \
 538         cx->blk_oldsp           = sp - PL_stack_base,                   \
 539         cx->blk_oldcop          = PL_curcop,                            \
 540         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
 541         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
 542         cx->blk_oldpm           = PL_curpm,                             \
 543         cx->blk_gimme           = (U8)gimme;                            \
 544         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
 545                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
 546
 547 /* Exit a block (RETURN and LAST). */
 548 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
 549         newsp            = PL_stack_base + cx->blk_oldsp,               \
 550         PL_curcop        = cx->blk_oldcop,                              \
 551         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 552         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 553         pm               = cx->blk_oldpm,                               \
 554         gimme            = cx->blk_gimme;                               \
 555         DEBUG_SCOPE("POPBLOCK");                                        \
 556         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
 557                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
 558
 559 /* Continue a block elsewhere (NEXT and REDO). */
 560 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
 561         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
 562         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 563         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 564         PL_curpm         = cx->blk_oldpm;                               \
 565         DEBUG_SCOPE("TOPBLOCK");
 566
 567 /* substitution context */
 568 struct subst {
 569     U16         sbu_type;       /* what kind of context this is */
 570     U8          sbu_once;       /* Actually both booleans, but U8 to matches */
 571     U8          sbu_rxtainted;  /* struct block */
 572     I32         sbu_iters;
 573     I32         sbu_maxiters;
 574     I32         sbu_rflags;
 575     I32         sbu_oldsave;
 576     char *      sbu_orig;
 577     SV *        sbu_dstr;
 578     SV *        sbu_targ;
 579     char *      sbu_s;
 580     char *      sbu_m;
 581     char *      sbu_strend;
 582     void *      sbu_rxres;
 583     REGEXP *    sbu_rx;
 584 };
 585 #define sb_iters        cx_u.cx_subst.sbu_iters
 586 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
 587 #define sb_rflags       cx_u.cx_subst.sbu_rflags
 588 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
 589 #define sb_once         cx_u.cx_subst.sbu_once
 590 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
 591 #define sb_orig         cx_u.cx_subst.sbu_orig
 592 #define sb_dstr         cx_u.cx_subst.sbu_dstr
 593 #define sb_targ         cx_u.cx_subst.sbu_targ
 594 #define sb_s            cx_u.cx_subst.sbu_s
 595 #define sb_m            cx_u.cx_subst.sbu_m
 596 #define sb_strend       cx_u.cx_subst.sbu_strend
 597 #define sb_rxres        cx_u.cx_subst.sbu_rxres
 598 #define sb_rx           cx_u.cx_subst.sbu_rx
 599
 600 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
 601         cx->sb_iters            = iters,                                \
 602         cx->sb_maxiters         = maxiters,                             \
 603         cx->sb_rflags           = r_flags,                              \
 604         cx->sb_oldsave          = oldsave,                              \
 605         cx->sb_once             = once,                                 \
 606         cx->sb_rxtainted        = rxtainted,                            \
 607         cx->sb_orig             = orig,                                 \
 608         cx->sb_dstr             = dstr,                                 \
 609         cx->sb_targ             = targ,                                 \
 610         cx->sb_s                = s,                                    \
 611         cx->sb_m                = m,                                    \
 612         cx->sb_strend           = strend,                               \
 613         cx->sb_rxres            = NULL,                                 \
 614         cx->sb_rx               = rx,                                   \
 615         cx->cx_type             = CXt_SUBST;                            \
 616         rxres_save(&cx->sb_rxres, rx);                                  \
 617         (void)ReREFCNT_inc(rx)
 618
 619 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
 620         rxres_free(&cx->sb_rxres);                                      \
 621         ReREFCNT_dec(cx->sb_rx)
 622
 623 struct context {
 624     union {
 625         struct block    cx_blk;
 626         struct subst    cx_subst;
 627     } cx_u;
 628 };
 629 #define cx_type cx_u.cx_subst.sbu_type
 630
 631 #define CXTYPEMASK      0xff
 632 #define CXt_NULL        0
 633 #define CXt_SUB         1
 634 #define CXt_EVAL        2
 635 #define CXt_LOOP        3
 636 #define CXt_SUBST       4
 637 #define CXt_BLOCK       5
 638 #define CXt_FORMAT      6
 639 #define CXt_GIVEN       7
 640 #define CXt_WHEN        8
 641
 642 /* private flags for CXt_SUB and CXt_NULL */
 643 #define CXp_MULTICALL   0x00000400      /* part of a multicall (so don't
 644                                            tear down context on exit). */
 645
 646 /* private flags for CXt_EVAL */
 647 #define CXp_REAL        0x00000100      /* truly eval'', not a lookalike */
 648 #define CXp_TRYBLOCK    0x00000200      /* eval{}, not eval'' or similar */
 649
 650 /* private flags for CXt_LOOP */
 651 #define CXp_FOREACH     0x00000200      /* a foreach loop */
 652 #define CXp_FOR_DEF     0x00000400      /* foreach using $_ */
 653 #ifdef USE_ITHREADS
 654 #  define CXp_PADVAR    0x00000100      /* itervar lives on pad, iterdata
 655                                            has pad offset; if not set,
 656                                            iterdata holds GV* */
 657 #  define CxPADLOOP(c)  (((c)->cx_type & (CXt_LOOP|CXp_PADVAR))         \
 658                          == (CXt_LOOP|CXp_PADVAR))
 659 #endif
 660
 661 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
 662 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
 663                          == CXp_MULTICALL)
 664 #define CxREALEVAL(c)   (((c)->cx_type & (CXt_EVAL|CXp_REAL))           \
 665                          == (CXt_EVAL|CXp_REAL))
 666 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))       \
 667                          == (CXt_EVAL|CXp_TRYBLOCK))
 668 #define CxFOREACH(c)    (((c)->cx_type & (CXt_LOOP|CXp_FOREACH))        \
 669                          == (CXt_LOOP|CXp_FOREACH))
 670 #define CxFOREACHDEF(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))\
 671                          == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
 672
 673 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 674
 675 /*
 676 =head1 "Gimme" Values
 677 */
 678
 679 /*
 680 =for apidoc AmU||G_SCALAR
 681 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
 682 L<perlcall>.
 683
 684 =for apidoc AmU||G_ARRAY
 685 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
 686 L<perlcall>.
 687
 688 =for apidoc AmU||G_VOID
 689 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
 690
 691 =for apidoc AmU||G_DISCARD
 692 Indicates that arguments returned from a callback should be discarded.  See
 693 L<perlcall>.
 694
 695 =for apidoc AmU||G_EVAL
 696
 697 Used to force a Perl C<eval> wrapper around a callback.  See
 698 L<perlcall>.
 699
 700 =for apidoc AmU||G_NOARGS
 701
 702 Indicates that no arguments are being sent to a callback.  See
 703 L<perlcall>.
 704
 705 =cut
 706 */
 707
 708 #define G_SCALAR        0
 709 #define G_ARRAY         1
 710 #define G_VOID          128     /* skip this bit when adding flags below */
 711
 712 /* extra flags for Perl_call_* routines */
 713 #define G_DISCARD       2       /* Call FREETMPS. */
 714 #define G_EVAL          4       /* Assume eval {} around subroutine call. */
 715 #define G_NOARGS        8       /* Don't construct a @_ array. */
 716 #define G_KEEPERR      16       /* Append errors to $@, don't overwrite it */
 717 #define G_NODEBUG      32       /* Disable debugging at toplevel.  */
 718 #define G_METHOD       64       /* Calling method. */
 719 #define G_FAKINGEVAL  256       /* Faking en eval context for call_sv or
 720                                    fold_constants. */
 721
 722 /* flag bits for PL_in_eval */
 723 #define EVAL_NULL       0       /* not in an eval */
 724 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
 725 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
 726 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
 727 #define EVAL_INREQUIRE  8       /* The code is being required. */
 728
 729 /* Support for switching (stack and block) contexts.
 730  * This ensures magic doesn't invalidate local stack and cx pointers.
 731  */
 732
 733 #define PERLSI_UNKNOWN          -1
 734 #define PERLSI_UNDEF            0
 735 #define PERLSI_MAIN             1
 736 #define PERLSI_MAGIC            2
 737 #define PERLSI_SORT             3
 738 #define PERLSI_SIGNAL           4
 739 #define PERLSI_OVERLOAD         5
 740 #define PERLSI_DESTROY          6
 741 #define PERLSI_WARNHOOK         7
 742 #define PERLSI_DIEHOOK          8
 743 #define PERLSI_REQUIRE          9
 744
 745 struct stackinfo {
 746     AV *                si_stack;       /* stack for current runlevel */
 747     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
 748     I32                 si_cxix;        /* current context index */
 749     I32                 si_cxmax;       /* maximum allocated index */
 750     I32                 si_type;        /* type of runlevel */
 751     struct stackinfo *  si_prev;
 752     struct stackinfo *  si_next;
 753     I32                 si_markoff;     /* offset where markstack begins for us.
 754                                          * currently used only with DEBUGGING,
 755                                          * but not #ifdef-ed for bincompat */
 756 };
 757
 758 typedef struct stackinfo PERL_SI;
 759
 760 #define cxstack         (PL_curstackinfo->si_cxstack)
 761 #define cxstack_ix      (PL_curstackinfo->si_cxix)
 762 #define cxstack_max     (PL_curstackinfo->si_cxmax)
 763
 764 #ifdef DEBUGGING
 765 #  define       SET_MARK_OFFSET \
 766     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
 767 #else
 768 #  define       SET_MARK_OFFSET NOOP
 769 #endif
 770
 771 #define PUSHSTACKi(type) \
 772     STMT_START {                                                        \
 773         PERL_SI *next = PL_curstackinfo->si_next;                       \
 774         if (!next) {                                                    \
 775             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
 776             next->si_prev = PL_curstackinfo;                            \
 777             PL_curstackinfo->si_next = next;                            \
 778         }                                                               \
 779         next->si_type = type;                                           \
 780         next->si_cxix = -1;                                             \
 781         AvFILLp(next->si_stack) = 0;                                    \
 782         SWITCHSTACK(PL_curstack,next->si_stack);                        \
 783         PL_curstackinfo = next;                                         \
 784         SET_MARK_OFFSET;                                                \
 785     } STMT_END
 786
 787 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
 788
 789 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
 790  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
 791 #define POPSTACK \
 792     STMT_START {                                                        \
 793         dSP;                                                            \
 794         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
 795         if (!prev) {                                                    \
 796             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
 797             my_exit(1);                                                 \
 798         }                                                               \
 799         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
 800         /* don't free prev here, free them all at the END{} */          \
 801         PL_curstackinfo = prev;                                         \
 802     } STMT_END
 803
 804 #define POPSTACK_TO(s) \
 805     STMT_START {                                                        \
 806         while (PL_curstack != s) {                                      \
 807             dounwind(-1);                                               \
 808             POPSTACK;                                                   \
 809         }                                                               \
 810     } STMT_END
 811
 812 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
 813 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
 814
 815 /*
 816 =head1 Multicall Functions
 817
 818 =for apidoc Ams||dMULTICALL
 819 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
 820
 821 =for apidoc Ams||PUSH_MULTICALL
 822 Opening bracket for a lightweight callback.
 823 See L<perlcall/Lightweight Callbacks>.
 824
 825 =for apidoc Ams||MULTICALL
 826 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
 827
 828 =for apidoc Ams||POP_MULTICALL
 829 Closing bracket for a lightweight callback.
 830 See L<perlcall/Lightweight Callbacks>.
 831
 832 =cut
 833 */
 834
 835 #define dMULTICALL \
 836     SV **newsp;                 /* set by POPBLOCK */                   \
 837     PERL_CONTEXT *cx;                                                   \
 838     CV *multicall_cv;                                                   \
 839     OP *multicall_cop;                                                  \
 840     bool multicall_oldcatch;                                            \
 841     U8 hasargs = 0              /* used by PUSHSUB */
 842
 843 #define PUSH_MULTICALL(the_cv) \
 844     STMT_START {                                                        \
 845         CV * const _nOnclAshIngNamE_ = the_cv;                          \
 846         CV * const cv = _nOnclAshIngNamE_;                              \
 847         AV * const padlist = CvPADLIST(cv);                             \
 848         ENTER;                                                          \
 849         multicall_oldcatch = CATCH_GET;                                 \
 850         SAVETMPS; SAVEVPTR(PL_op);                                      \
 851         CATCH_SET(TRUE);                                                \
 852         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
 853         PUSHSUB(cx);                                                    \
 854         if (++CvDEPTH(cv) >= 2) {                                       \
 855             PERL_STACK_OVERFLOW_CHECK();                                \
 856             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
 857         }                                                               \
 858         SAVECOMPPAD();                                                  \
 859         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
 860         multicall_cv = cv;                                              \
 861         multicall_cop = CvSTART(cv);                                    \
 862     } STMT_END
 863
 864 #define MULTICALL \
 865     STMT_START {                                                        \
 866         PL_op = multicall_cop;                                          \
 867         CALLRUNOPS(aTHX);                                               \
 868     } STMT_END
 869
 870 #define POP_MULTICALL \
 871     STMT_START {                                                        \
 872         LEAVESUB(multicall_cv);                                         \
 873         CvDEPTH(multicall_cv)--;                                        \
 874         POPBLOCK(cx,PL_curpm);                                          \
 875         CATCH_SET(multicall_oldcatch);                                  \
 876         LEAVE;                                                          \
 877     } STMT_END
 878
 879 /*
 880  * Local variables:
 881  * c-indentation-style: bsd
 882  * c-basic-offset: 4
 883  * indent-tabs-mode: t
 884  * End:
 885  *
 886  * ex: set ts=8 sts=4 sw=4 noet:
 887  */