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 */ 896