[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/i586-linux-thread-multi/CORE/ -> cop.h (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1