1 /* scope.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 */ 10 11 /* 12 * For the fashion of Minas Tirith was such that it was built on seven 13 * levels... 14 * 15 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"] 16 */ 17 18 /* This file contains functions to manipulate several of Perl's stacks; 19 * in particular it contains code to push various types of things onto 20 * the savestack, then to pop them off and perform the correct restorative 21 * action for each one. This corresponds to the cleanup Perl does at 22 * each scope exit. 23 */ 24 25 #include "EXTERN.h" 26 #define PERL_IN_SCOPE_C 27 #include "perl.h" 28 #include "feature.h" 29 30 SV** 31 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) 32 { 33 SSize_t extra; 34 SSize_t current = (p - PL_stack_base); 35 36 PERL_ARGS_ASSERT_STACK_GROW; 37 38 if (UNLIKELY(n < 0)) 39 Perl_croak(aTHX_ 40 "panic: stack_grow() negative count (%" IVdf ")", (IV)n); 41 42 PL_stack_sp = sp; 43 extra = 44 #ifdef STRESS_REALLOC 45 1; 46 #else 47 128; 48 #endif 49 /* If the total might wrap, panic instead. This is really testing 50 * that (current + n + extra < SSize_t_MAX), but done in a way that 51 * can't wrap */ 52 if (UNLIKELY( current > SSize_t_MAX - extra 53 || current + extra > SSize_t_MAX - n 54 )) 55 /* diag_listed_as: Out of memory during %s extend */ 56 Perl_croak(aTHX_ "Out of memory during stack extend"); 57 58 av_extend(PL_curstack, current + n + extra); 59 #ifdef DEBUGGING 60 PL_curstackinfo->si_stack_hwm = current + n + extra; 61 #endif 62 63 return PL_stack_sp; 64 } 65 66 #ifdef STRESS_REALLOC 67 #define GROW(old) ((old) + 1) 68 #else 69 #define GROW(old) ((old) * 3 / 2) 70 #endif 71 72 PERL_SI * 73 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) 74 { 75 PERL_SI *si; 76 Newx(si, 1, PERL_SI); 77 si->si_stack = newAV(); 78 AvREAL_off(si->si_stack); 79 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); 80 AvALLOC(si->si_stack)[0] = &PL_sv_undef; 81 AvFILLp(si->si_stack) = 0; 82 si->si_prev = 0; 83 si->si_next = 0; 84 si->si_cxmax = cxitems - 1; 85 si->si_cxix = -1; 86 si->si_cxsubix = -1; 87 si->si_type = PERLSI_UNDEF; 88 Newx(si->si_cxstack, cxitems, PERL_CONTEXT); 89 /* Without any kind of initialising CX_PUSHSUBST() 90 * in pp_subst() will read uninitialised heap. */ 91 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT); 92 return si; 93 } 94 95 I32 96 Perl_cxinc(pTHX) 97 { 98 const IV old_max = cxstack_max; 99 const IV new_max = GROW(cxstack_max); 100 Renew(cxstack, new_max + 1, PERL_CONTEXT); 101 cxstack_max = new_max; 102 /* Without any kind of initialising deep enough recursion 103 * will end up reading uninitialised PERL_CONTEXTs. */ 104 PoisonNew(cxstack + old_max + 1, new_max - old_max, PERL_CONTEXT); 105 return cxstack_ix + 1; 106 } 107 108 /* 109 =for apidoc_section $callback 110 =for apidoc push_scope 111 112 Implements L<perlapi/C<ENTER>> 113 114 =cut 115 */ 116 117 void 118 Perl_push_scope(pTHX) 119 { 120 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) { 121 const IV new_max = GROW(PL_scopestack_max); 122 Renew(PL_scopestack, new_max, I32); 123 #ifdef DEBUGGING 124 Renew(PL_scopestack_name, new_max, const char*); 125 #endif 126 PL_scopestack_max = new_max; 127 } 128 #ifdef DEBUGGING 129 PL_scopestack_name[PL_scopestack_ix] = "unknown"; 130 #endif 131 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; 132 133 } 134 135 /* 136 =for apidoc_section $callback 137 =for apidoc pop_scope 138 139 Implements L<perlapi/C<LEAVE>> 140 141 =cut 142 */ 143 144 void 145 Perl_pop_scope(pTHX) 146 { 147 const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; 148 LEAVE_SCOPE(oldsave); 149 } 150 151 I32 * 152 Perl_markstack_grow(pTHX) 153 { 154 const I32 oldmax = PL_markstack_max - PL_markstack; 155 const I32 newmax = GROW(oldmax); 156 157 Renew(PL_markstack, newmax, I32); 158 PL_markstack_max = PL_markstack + newmax; 159 PL_markstack_ptr = PL_markstack + oldmax; 160 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, 161 "MARK grow %p %" IVdf " by %" IVdf "\n", 162 PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax))); 163 return PL_markstack_ptr; 164 } 165 166 void 167 Perl_savestack_grow(pTHX) 168 { 169 const I32 by = PL_savestack_max - PL_savestack_ix; 170 Perl_savestack_grow_cnt(aTHX_ by); 171 } 172 173 void 174 Perl_savestack_grow_cnt(pTHX_ I32 need) 175 { 176 /* NOTE: PL_savestack_max and PL_savestack_ix are I32. 177 * 178 * This makes sense when you consider that having I32_MAX items on 179 * the stack would be quite large. 180 * 181 * However, we use IV here so that we can detect if the new requested 182 * amount is larger than I32_MAX. 183 */ 184 const IV new_floor = PL_savestack_max + need; /* what we need */ 185 /* the GROW() macro normally does scales by 1.5 but under 186 * STRESS_REALLOC it simply adds 1 */ 187 IV new_max = GROW(new_floor); /* and some extra */ 188 189 /* the new_max < PL_savestack_max is for cases where IV is I32 190 * and we have rolled over from I32_MAX to a small value */ 191 if (new_max > I32_MAX || new_max < PL_savestack_max) { 192 if (new_floor > I32_MAX || new_floor < PL_savestack_max) { 193 Perl_croak(aTHX_ "panic: savestack overflows I32_MAX"); 194 } 195 new_max = new_floor; 196 } 197 198 /* Note that we add an additional SS_MAXPUSH slots on top of 199 * PL_savestack_max so that SS_ADD_END(), SSGROW() etc can do 200 * a simper check and if necessary realloc *after* apparently 201 * overwriting the current PL_savestack_max. See scope.h. 202 * 203 * The +1 is because new_max/PL_savestack_max is the highest 204 * index, by Renew needs the number of items, which is one 205 * larger than the highest index. */ 206 Renew(PL_savestack, new_max + SS_MAXPUSH + 1, ANY); 207 PL_savestack_max = new_max; 208 } 209 210 #undef GROW 211 212 /* The original function was called Perl_tmps_grow and was removed from public 213 API, Perl_tmps_grow_p is the replacement and it used in public macros but 214 isn't public itself. 215 216 Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by, 217 where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max 218 Upon return, PL_tmps_stack[ix] will be a valid address. For machine code 219 optimization and register usage reasons, the proposed ix passed into 220 tmps_grow is returned to the caller which the caller can then use to write 221 an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in 222 pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of 223 tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller 224 must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is 225 appropriate. The assignment to PL_temps_ix can happen before or after 226 tmps_grow call since tmps_grow doesn't look at PL_tmps_ix. 227 */ 228 229 SSize_t 230 Perl_tmps_grow_p(pTHX_ SSize_t ix) 231 { 232 SSize_t extend_to = ix; 233 #ifndef STRESS_REALLOC 234 if (ix - PL_tmps_max < 128) 235 extend_to += (PL_tmps_max < 512) ? 128 : 512; 236 #endif 237 Renew(PL_tmps_stack, extend_to + 1, SV*); 238 PL_tmps_max = extend_to + 1; 239 return ix; 240 } 241 242 243 void 244 Perl_free_tmps(pTHX) 245 { 246 /* XXX should tmps_floor live in cxstack? */ 247 const SSize_t myfloor = PL_tmps_floor; 248 while (PL_tmps_ix > myfloor) { /* clean up after last statement */ 249 SV* const sv = PL_tmps_stack[PL_tmps_ix--]; 250 #ifdef PERL_POISON 251 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); 252 #endif 253 if (LIKELY(sv)) { 254 SvTEMP_off(sv); 255 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ 256 } 257 } 258 } 259 260 /* 261 =for apidoc save_scalar_at 262 263 A helper function for localizing the SV referenced by C<*sptr>. 264 265 If C<SAVEf_KEEPOLDELEM> is set in in C<flags>, the function returns the input 266 scalar untouched. 267 268 Otherwise it replaces C<*sptr> with a new C<undef> scalar, and returns that. 269 The new scalar will have the old one's magic (if any) copied to it. 270 If there is such magic, and C<SAVEf_SETMAGIC> is set in in C<flags>, 'set' 271 magic will be processed on the new scalar. If unset, 'set' magic will be 272 skipped. The latter typically means that assignment will soon follow (I<e.g.>, 273 S<C<'local $x = $y'>>), and that will handle the magic. 274 275 =for apidoc Amnh ||SAVEf_KEEPOLDELEM 276 =for apidoc Amnh ||SAVEf_SETMAGIC 277 278 =cut 279 */ 280 281 STATIC SV * 282 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) 283 { 284 SV * osv; 285 SV *sv; 286 287 PERL_ARGS_ASSERT_SAVE_SCALAR_AT; 288 289 osv = *sptr; 290 if (flags & SAVEf_KEEPOLDELEM) 291 sv = osv; 292 else { 293 sv = (*sptr = newSV_type(SVt_NULL)); 294 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) 295 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC)); 296 } 297 298 return sv; 299 } 300 301 void 302 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) 303 { 304 dSS_ADD; 305 SS_ADD_PTR(ptr1); 306 SS_ADD_PTR(ptr2); 307 SS_ADD_UV(type); 308 SS_ADD_END(3); 309 } 310 311 SV * 312 Perl_save_scalar(pTHX_ GV *gv) 313 { 314 SV ** const sptr = &GvSVn(gv); 315 316 PERL_ARGS_ASSERT_SAVE_SCALAR; 317 318 if (UNLIKELY(SvGMAGICAL(*sptr))) { 319 PL_localizing = 1; 320 (void)mg_get(*sptr); 321 PL_localizing = 0; 322 } 323 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV); 324 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 325 } 326 327 /* 328 =for apidoc save_generic_svref 329 330 Implements C<SAVEGENERICSV>. 331 332 Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to 333 restore a global SV to its prior contents, freeing new value. 334 335 =cut 336 */ 337 338 void 339 Perl_save_generic_svref(pTHX_ SV **sptr) 340 { 341 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; 342 343 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); 344 } 345 346 347 /* 348 =for apidoc save_rcpv 349 350 Implements C<SAVERCPV>. 351 352 Saves and restores a refcounted string, similar to what 353 save_generic_svref would do for a SV*. Can be used to restore 354 a refcounted string to its previous state. Performs the 355 appropriate refcount counting so that nothing should leak 356 or be prematurely freed. 357 358 =cut 359 */ 360 void 361 Perl_save_rcpv(pTHX_ char **prcpv) { 362 PERL_ARGS_ASSERT_SAVE_RCPV; 363 save_pushptrptr(prcpv, rcpv_copy(*prcpv), SAVEt_RCPV); 364 } 365 366 /* 367 =for apidoc save_freercpv 368 369 Implements C<SAVEFREERCPV>. 370 371 Saves and frees a refcounted string. Calls rcpv_free() 372 on the argument when the current pseudo block is finished. 373 374 =cut 375 */ 376 void 377 Perl_save_freercpv(pTHX_ char *rcpv) { 378 PERL_ARGS_ASSERT_SAVE_FREERCPV; 379 save_pushptr(rcpv, SAVEt_FREERCPV); 380 } 381 382 383 /* 384 =for apidoc_section $callback 385 =for apidoc save_generic_pvref 386 387 Implements C<SAVEGENERICPV>. 388 389 Like save_pptr(), but also Safefree()s the new value if it is different 390 from the old one. Can be used to restore a global char* to its prior 391 contents, freeing new value. 392 393 =cut 394 */ 395 396 void 397 Perl_save_generic_pvref(pTHX_ char **str) 398 { 399 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; 400 401 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); 402 } 403 404 /* 405 =for apidoc_section $callback 406 =for apidoc save_shared_pvref 407 408 Implements C<SAVESHAREDPV>. 409 410 Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). 411 Can be used to restore a shared global char* to its prior 412 contents, freeing new value. 413 414 =cut 415 */ 416 417 void 418 Perl_save_shared_pvref(pTHX_ char **str) 419 { 420 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; 421 422 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); 423 } 424 425 426 /* 427 =for apidoc_section $callback 428 =for apidoc save_set_svflags 429 430 Implements C<SAVESETSVFLAGS>. 431 432 Set the SvFLAGS specified by mask to the values in val 433 434 =cut 435 */ 436 437 void 438 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) 439 { 440 dSS_ADD; 441 442 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; 443 444 SS_ADD_PTR(sv); 445 SS_ADD_INT(mask); 446 SS_ADD_INT(val); 447 SS_ADD_UV(SAVEt_SET_SVFLAGS); 448 SS_ADD_END(4); 449 } 450 451 /* 452 453 =for apidoc_section $GV 454 455 =for apidoc save_gp 456 457 Saves the current GP of gv on the save stack to be restored on scope exit. 458 459 If C<empty> is true, replace the GP with a new GP. 460 461 If C<empty> is false, mark C<gv> with C<GVf_INTRO> so the next reference 462 assigned is localized, which is how S<C< local *foo = $someref; >> works. 463 464 =cut 465 */ 466 467 void 468 Perl_save_gp(pTHX_ GV *gv, I32 empty) 469 { 470 PERL_ARGS_ASSERT_SAVE_GP; 471 472 /* XXX For now, we just upgrade any coderef in the stash to a full GV 473 during localisation. Maybe at some point we could make localis- 474 ation work without needing the upgrade. (In which case our 475 callers should probably call a different function, not save_gp.) 476 */ 477 if (!isGV(gv)) { 478 assert(isGV_or_RVCV(gv)); 479 (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */ 480 assert(isGV(gv)); 481 } 482 483 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); 484 485 if (empty) { 486 GP *gp = Perl_newGP(aTHX_ gv); 487 HV * const stash = GvSTASH(gv); 488 bool isa_changed = 0; 489 490 if (stash && HvHasENAME(stash)) { 491 if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) 492 isa_changed = TRUE; 493 else if (GvCVu(gv)) 494 /* taking a method out of circulation ("local")*/ 495 mro_method_changed_in(stash); 496 } 497 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { 498 gp->gp_io = newIO(); 499 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; 500 } 501 GvGP_set(gv,gp); 502 if (isa_changed) mro_isa_changed_in(stash); 503 } 504 else { 505 gp_ref(GvGP(gv)); 506 GvINTRO_on(gv); 507 } 508 } 509 510 AV * 511 Perl_save_ary(pTHX_ GV *gv) 512 { 513 AV * const oav = GvAVn(gv); 514 AV *av; 515 516 PERL_ARGS_ASSERT_SAVE_ARY; 517 518 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav))) 519 av_reify(oav); 520 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV); 521 522 GvAV(gv) = NULL; 523 av = GvAVn(gv); 524 if (UNLIKELY(SvMAGIC(oav))) 525 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); 526 return av; 527 } 528 529 HV * 530 Perl_save_hash(pTHX_ GV *gv) 531 { 532 HV *ohv, *hv; 533 534 PERL_ARGS_ASSERT_SAVE_HASH; 535 536 save_pushptrptr( 537 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV 538 ); 539 540 GvHV(gv) = NULL; 541 hv = GvHVn(gv); 542 if (UNLIKELY(SvMAGIC(ohv))) 543 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); 544 return hv; 545 } 546 547 void 548 Perl_save_item(pTHX_ SV *item) 549 { 550 SV * const sv = newSVsv(item); 551 552 PERL_ARGS_ASSERT_SAVE_ITEM; 553 554 save_pushptrptr(item, /* remember the pointer */ 555 sv, /* remember the value */ 556 SAVEt_ITEM); 557 } 558 559 void 560 Perl_save_bool(pTHX_ bool *boolp) 561 { 562 dSS_ADD; 563 564 PERL_ARGS_ASSERT_SAVE_BOOL; 565 566 SS_ADD_PTR(boolp); 567 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8)); 568 SS_ADD_END(2); 569 } 570 571 void 572 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) 573 { 574 dSS_ADD; 575 576 SS_ADD_INT(i); 577 SS_ADD_PTR(ptr); 578 SS_ADD_UV(type); 579 SS_ADD_END(3); 580 } 581 582 void 583 Perl_save_int(pTHX_ int *intp) 584 { 585 const int i = *intp; 586 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL); 587 int size = 2; 588 dSS_ADD; 589 590 PERL_ARGS_ASSERT_SAVE_INT; 591 592 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) { 593 SS_ADD_INT(i); 594 type = SAVEt_INT; 595 size++; 596 } 597 SS_ADD_PTR(intp); 598 SS_ADD_UV(type); 599 SS_ADD_END(size); 600 } 601 602 void 603 Perl_save_I8(pTHX_ I8 *bytep) 604 { 605 dSS_ADD; 606 607 PERL_ARGS_ASSERT_SAVE_I8; 608 609 SS_ADD_PTR(bytep); 610 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8)); 611 SS_ADD_END(2); 612 } 613 614 void 615 Perl_save_I16(pTHX_ I16 *intp) 616 { 617 dSS_ADD; 618 619 PERL_ARGS_ASSERT_SAVE_I16; 620 621 SS_ADD_PTR(intp); 622 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8)); 623 SS_ADD_END(2); 624 } 625 626 void 627 Perl_save_I32(pTHX_ I32 *intp) 628 { 629 const I32 i = *intp; 630 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL); 631 int size = 2; 632 dSS_ADD; 633 634 PERL_ARGS_ASSERT_SAVE_I32; 635 636 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) { 637 SS_ADD_INT(i); 638 type = SAVEt_I32; 639 size++; 640 } 641 SS_ADD_PTR(intp); 642 SS_ADD_UV(type); 643 SS_ADD_END(size); 644 } 645 646 void 647 Perl_save_strlen(pTHX_ STRLEN *ptr) 648 { 649 const IV i = *ptr; 650 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_STRLEN_SMALL); 651 int size = 2; 652 dSS_ADD; 653 654 PERL_ARGS_ASSERT_SAVE_STRLEN; 655 656 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) { 657 SS_ADD_IV(*ptr); 658 type = SAVEt_STRLEN; 659 size++; 660 } 661 662 SS_ADD_PTR(ptr); 663 SS_ADD_UV(type); 664 SS_ADD_END(size); 665 } 666 667 void 668 Perl_save_iv(pTHX_ IV *ivp) 669 { 670 PERL_ARGS_ASSERT_SAVE_IV; 671 672 SSGROW(3); 673 SSPUSHIV(*ivp); 674 SSPUSHPTR(ivp); 675 SSPUSHUV(SAVEt_IV); 676 } 677 678 /* Cannot use save_sptr() to store a char* since the SV** cast will 679 * force word-alignment and we'll miss the pointer. 680 */ 681 void 682 Perl_save_pptr(pTHX_ char **pptr) 683 { 684 PERL_ARGS_ASSERT_SAVE_PPTR; 685 686 save_pushptrptr(*pptr, pptr, SAVEt_PPTR); 687 } 688 689 /* 690 =for apidoc_section $callback 691 =for apidoc save_vptr 692 693 Implements C<SAVEVPTR>. 694 695 =cut 696 */ 697 698 void 699 Perl_save_vptr(pTHX_ void *ptr) 700 { 701 PERL_ARGS_ASSERT_SAVE_VPTR; 702 703 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); 704 } 705 706 void 707 Perl_save_sptr(pTHX_ SV **sptr) 708 { 709 PERL_ARGS_ASSERT_SAVE_SPTR; 710 711 save_pushptrptr(*sptr, sptr, SAVEt_SPTR); 712 } 713 714 /* 715 =for apidoc_section $callback 716 =for apidoc save_padsv_and_mortalize 717 718 Implements C<SAVEPADSVANDMORTALIZE>. 719 720 =cut 721 */ 722 723 void 724 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) 725 { 726 dSS_ADD; 727 728 ASSERT_CURPAD_ACTIVE("save_padsv"); 729 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off])); 730 SS_ADD_PTR(PL_comppad); 731 SS_ADD_UV((UV)off); 732 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE); 733 SS_ADD_END(4); 734 } 735 736 void 737 Perl_save_hptr(pTHX_ HV **hptr) 738 { 739 PERL_ARGS_ASSERT_SAVE_HPTR; 740 741 save_pushptrptr(*hptr, hptr, SAVEt_HPTR); 742 } 743 744 void 745 Perl_save_aptr(pTHX_ AV **aptr) 746 { 747 PERL_ARGS_ASSERT_SAVE_APTR; 748 749 save_pushptrptr(*aptr, aptr, SAVEt_APTR); 750 } 751 752 /* 753 =for apidoc_section $callback 754 =for apidoc save_pushptr 755 756 The refcnt of object C<ptr> will be decremented at the end of the current 757 I<pseudo-block>. C<type> gives the type of C<ptr>, expressed as one of the 758 constants in F<scope.h> whose name begins with C<SAVEt_>. 759 760 This is the underlying implementation of several macros, like 761 C<SAVEFREESV>. 762 763 =cut 764 */ 765 766 void 767 Perl_save_pushptr(pTHX_ void *const ptr, const int type) 768 { 769 dSS_ADD; 770 SS_ADD_PTR(ptr); 771 SS_ADD_UV(type); 772 SS_ADD_END(2); 773 } 774 775 void 776 Perl_save_clearsv(pTHX_ SV **svp) 777 { 778 const UV offset = svp - PL_curpad; 779 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT; 780 781 PERL_ARGS_ASSERT_SAVE_CLEARSV; 782 783 ASSERT_CURPAD_ACTIVE("save_clearsv"); 784 assert(*svp); 785 SvPADSTALE_off(*svp); /* mark lexical as active */ 786 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) { 787 Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)", 788 offset, svp, PL_curpad); 789 } 790 791 { 792 dSS_ADD; 793 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV); 794 SS_ADD_END(1); 795 } 796 } 797 798 void 799 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) 800 { 801 PERL_ARGS_ASSERT_SAVE_DELETE; 802 803 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); 804 } 805 806 /* 807 =for apidoc_section $callback 808 =for apidoc save_hdelete 809 810 Implements C<SAVEHDELETE>. 811 812 =cut 813 */ 814 815 void 816 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) 817 { 818 STRLEN len; 819 I32 klen; 820 const char *key; 821 822 PERL_ARGS_ASSERT_SAVE_HDELETE; 823 824 key = SvPV_const(keysv, len); 825 klen = SvUTF8(keysv) ? -(I32)len : (I32)len; 826 SvREFCNT_inc_simple_void_NN(hv); 827 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE); 828 } 829 830 /* 831 =for apidoc_section $callback 832 =for apidoc save_adelete 833 834 Implements C<SAVEADELETE>. 835 836 =cut 837 */ 838 839 void 840 Perl_save_adelete(pTHX_ AV *av, SSize_t key) 841 { 842 dSS_ADD; 843 844 PERL_ARGS_ASSERT_SAVE_ADELETE; 845 846 SvREFCNT_inc_void(av); 847 SS_ADD_UV(key); 848 SS_ADD_PTR(av); 849 SS_ADD_IV(SAVEt_ADELETE); 850 SS_ADD_END(3); 851 } 852 853 void 854 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) 855 { 856 dSS_ADD; 857 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; 858 859 SS_ADD_DPTR(f); 860 SS_ADD_PTR(p); 861 SS_ADD_UV(SAVEt_DESTRUCTOR); 862 SS_ADD_END(3); 863 } 864 865 void 866 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) 867 { 868 dSS_ADD; 869 870 SS_ADD_DXPTR(f); 871 SS_ADD_PTR(p); 872 SS_ADD_UV(SAVEt_DESTRUCTOR_X); 873 SS_ADD_END(3); 874 } 875 876 /* 877 =for apidoc_section $callback 878 =for apidoc save_hints 879 880 Implements C<SAVEHINTS>. 881 882 =cut 883 */ 884 885 void 886 Perl_save_hints(pTHX) 887 { 888 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); 889 if (PL_hints & HINT_LOCALIZE_HH) { 890 HV *oldhh = GvHV(PL_hintgv); 891 { 892 dSS_ADD; 893 SS_ADD_INT(PL_hints); 894 SS_ADD_PTR(save_cophh); 895 SS_ADD_PTR(oldhh); 896 SS_ADD_UV(SAVEt_HINTS_HH | (PL_prevailing_version << 8)); 897 SS_ADD_END(4); 898 } 899 GvHV(PL_hintgv) = NULL; /* in case copying dies */ 900 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh); 901 SAVEFEATUREBITS(); 902 } else { 903 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS | (PL_prevailing_version << 8)); 904 } 905 } 906 907 static void 908 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, 909 const int type) 910 { 911 dSS_ADD; 912 SS_ADD_PTR(ptr1); 913 SS_ADD_INT(i); 914 SS_ADD_PTR(ptr2); 915 SS_ADD_UV(type); 916 SS_ADD_END(4); 917 } 918 919 /* 920 =for apidoc_section $callback 921 =for apidoc save_aelem 922 =for apidoc_item save_aelem_flags 923 924 These each arrange for the value of the array element C<av[idx]> to be restored 925 at the end of the enclosing I<pseudo-block>. 926 927 In C<save_aelem>, the SV at C**sptr> will be replaced by a new C<undef> 928 scalar. That scalar will inherit any magic from the original C<**sptr>, 929 and any 'set' magic will be processed. 930 931 In C<save_aelem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes 932 the function to forgo all that: the scalar at C<**sptr> is untouched. 933 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a 934 new C<undef> scalar. That scalar will inherit any magic from the original 935 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC> 936 is set in in C<flags>. 937 938 =cut 939 */ 940 941 void 942 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, 943 const U32 flags) 944 { 945 dSS_ADD; 946 SV *sv; 947 948 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; 949 950 SvGETMAGIC(*sptr); 951 SS_ADD_PTR(SvREFCNT_inc_simple(av)); 952 SS_ADD_IV(idx); 953 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 954 SS_ADD_UV(SAVEt_AELEM); 955 SS_ADD_END(4); 956 /* The array needs to hold a reference count on its new element, so it 957 must be AvREAL. */ 958 if (UNLIKELY(!AvREAL(av) && AvREIFY(av))) 959 av_reify(av); 960 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ 961 if (flags & SAVEf_KEEPOLDELEM) 962 return; 963 sv = *sptr; 964 /* If we're localizing a tied array element, this new sv 965 * won't actually be stored in the array - so it won't get 966 * reaped when the localize ends. Ensure it gets reaped by 967 * mortifying it instead. DAPM */ 968 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) 969 sv_2mortal(sv); 970 } 971 972 /* 973 =for apidoc_section $callback 974 =for apidoc save_helem 975 =for apidoc_item save_helem_flags 976 977 These each arrange for the value of the hash element (in Perlish terms) 978 C<$hv{key}]> to be restored at the end of the enclosing I<pseudo-block>. 979 980 In C<save_helem>, the SV at C**sptr> will be replaced by a new C<undef> 981 scalar. That scalar will inherit any magic from the original C<**sptr>, 982 and any 'set' magic will be processed. 983 984 In C<save_helem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes 985 the function to forgo all that: the scalar at C<**sptr> is untouched. 986 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a 987 new C<undef> scalar. That scalar will inherit any magic from the original 988 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC> 989 is set in in C<flags>. 990 991 =cut 992 */ 993 994 void 995 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) 996 { 997 SV *sv; 998 999 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS; 1000 1001 SvGETMAGIC(*sptr); 1002 { 1003 dSS_ADD; 1004 SS_ADD_PTR(SvREFCNT_inc_simple(hv)); 1005 SS_ADD_PTR(newSVsv(key)); 1006 SS_ADD_PTR(SvREFCNT_inc(*sptr)); 1007 SS_ADD_UV(SAVEt_HELEM); 1008 SS_ADD_END(4); 1009 } 1010 save_scalar_at(sptr, flags); 1011 if (flags & SAVEf_KEEPOLDELEM) 1012 return; 1013 sv = *sptr; 1014 /* If we're localizing a tied hash element, this new sv 1015 * won't actually be stored in the hash - so it won't get 1016 * reaped when the localize ends. Ensure it gets reaped by 1017 * mortifying it instead. DAPM */ 1018 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))) 1019 sv_2mortal(sv); 1020 } 1021 1022 SV* 1023 Perl_save_svref(pTHX_ SV **sptr) 1024 { 1025 PERL_ARGS_ASSERT_SAVE_SVREF; 1026 1027 SvGETMAGIC(*sptr); 1028 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF); 1029 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */ 1030 } 1031 1032 1033 void 1034 Perl_savetmps(pTHX) 1035 { 1036 dSS_ADD; 1037 SS_ADD_IV(PL_tmps_floor); 1038 PL_tmps_floor = PL_tmps_ix; 1039 SS_ADD_UV(SAVEt_TMPSFLOOR); 1040 SS_ADD_END(2); 1041 } 1042 1043 /* 1044 =for apidoc_section $stack 1045 =for apidoc save_alloc 1046 1047 Implements L<perlapi/C<SSNEW>> and kin, which should be used instead of this 1048 function. 1049 1050 =cut 1051 */ 1052 1053 SSize_t 1054 Perl_save_alloc(pTHX_ SSize_t size, I32 pad) 1055 { 1056 const SSize_t start = pad + ((char*)&PL_savestack[PL_savestack_ix] 1057 - (char*)PL_savestack); 1058 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); 1059 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT; 1060 1061 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)) 1062 Perl_croak(aTHX_ 1063 "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")", 1064 elems, (IV)size, (IV)pad); 1065 1066 SSGROW(elems + 1); 1067 1068 PL_savestack_ix += elems; 1069 SSPUSHUV(SAVEt_ALLOC | elems_shifted); 1070 return start; 1071 } 1072 1073 1074 1075 /* 1076 =for apidoc_section $callback 1077 =for apidoc leave_scope 1078 1079 Implements C<LEAVE_SCOPE> which you should use instead. 1080 1081 =cut 1082 */ 1083 1084 void 1085 Perl_leave_scope(pTHX_ I32 base) 1086 { 1087 /* Localise the effects of the TAINT_NOT inside the loop. */ 1088 bool was = TAINT_get; 1089 1090 if (UNLIKELY(base < -1)) 1091 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); 1092 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n", 1093 (long)PL_savestack_ix, (long)base)); 1094 while (PL_savestack_ix > base) { 1095 UV uv; 1096 U8 type; 1097 ANY *ap; /* arg pointer */ 1098 ANY a0, a1, a2; /* up to 3 args */ 1099 1100 TAINT_NOT; 1101 1102 { 1103 U8 argcount; 1104 I32 ix = PL_savestack_ix - 1; 1105 1106 ap = &PL_savestack[ix]; 1107 uv = ap->any_uv; 1108 type = (U8)uv & SAVE_MASK; 1109 argcount = leave_scope_arg_counts[type]; 1110 PL_savestack_ix = ix - argcount; 1111 ap -= argcount; 1112 } 1113 1114 switch (type) { 1115 case SAVEt_ITEM: /* normal string */ 1116 a0 = ap[0]; a1 = ap[1]; 1117 sv_replace(a0.any_sv, a1.any_sv); 1118 if (UNLIKELY(SvSMAGICAL(a0.any_sv))) { 1119 PL_localizing = 2; 1120 mg_set(a0.any_sv); 1121 PL_localizing = 0; 1122 } 1123 break; 1124 1125 /* This would be a mathom, but Perl_save_svref() calls a static 1126 function, S_save_scalar_at(), so has to stay in this file. */ 1127 case SAVEt_SVREF: /* scalar reference */ 1128 a0 = ap[0]; a1 = ap[1]; 1129 a2.any_svp = a0.any_svp; 1130 a0.any_sv = NULL; /* what to refcnt_dec */ 1131 goto restore_sv; 1132 1133 case SAVEt_SV: /* scalar reference */ 1134 a0 = ap[0]; a1 = ap[1]; 1135 a2.any_svp = &GvSV(a0.any_gv); 1136 restore_sv: 1137 { 1138 /* do *a2.any_svp = a1 and free a0 */ 1139 SV * const sv = *a2.any_svp; 1140 *a2.any_svp = a1.any_sv; 1141 SvREFCNT_dec(sv); 1142 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) { 1143 /* mg_set could die, skipping the freeing of a0 and 1144 * a1; Ensure that they're always freed in that case */ 1145 dSS_ADD; 1146 SS_ADD_PTR(a1.any_sv); 1147 SS_ADD_UV(SAVEt_FREESV); 1148 SS_ADD_PTR(a0.any_sv); 1149 SS_ADD_UV(SAVEt_FREESV); 1150 SS_ADD_END(4); 1151 PL_localizing = 2; 1152 mg_set(a1.any_sv); 1153 PL_localizing = 0; 1154 break; 1155 } 1156 SvREFCNT_dec_NN(a1.any_sv); 1157 SvREFCNT_dec(a0.any_sv); 1158 break; 1159 } 1160 1161 case SAVEt_GENERIC_PVREF: /* generic pv */ 1162 a0 = ap[0]; a1 = ap[1]; 1163 if (*a1.any_pvp != a0.any_pv) { 1164 Safefree(*a1.any_pvp); 1165 *a1.any_pvp = a0.any_pv; 1166 } 1167 break; 1168 1169 case SAVEt_SHARED_PVREF: /* shared pv */ 1170 a0 = ap[0]; a1 = ap[1]; 1171 if (*a0.any_pvp != a1.any_pv) { 1172 PerlMemShared_free(*a0.any_pvp); 1173 *a0.any_pvp = a1.any_pv; 1174 } 1175 break; 1176 1177 case SAVEt_GVSV: /* scalar slot in GV */ 1178 a0 = ap[0]; a1 = ap[1]; 1179 a0.any_svp = &GvSV(a0.any_gv); 1180 goto restore_svp; 1181 1182 1183 case SAVEt_GENERIC_SVREF: /* generic sv */ 1184 a0 = ap[0]; a1 = ap[1]; 1185 restore_svp: 1186 { 1187 /* do *a0.any_svp = a1 */ 1188 SV * const sv = *a0.any_svp; 1189 *a0.any_svp = a1.any_sv; 1190 SvREFCNT_dec(sv); 1191 SvREFCNT_dec(a1.any_sv); 1192 break; 1193 } 1194 1195 case SAVEt_RCPV: /* like generic sv, but for struct rcpv */ 1196 { 1197 a0 = ap[0]; a1 = ap[1]; 1198 char *old = *a0.any_pvp; 1199 *a0.any_pvp = a1.any_pv; 1200 (void)rcpv_free(old); 1201 (void)rcpv_free(a1.any_pv); 1202 break; 1203 } 1204 1205 case SAVEt_FREERCPV: /* like SAVEt_FREEPV but for a RCPV */ 1206 { 1207 a0 = ap[0]; 1208 char *rcpv = a0.any_pv; 1209 (void)rcpv_free(rcpv); 1210 break; 1211 } 1212 1213 case SAVEt_GVSLOT: /* any slot in GV */ 1214 { 1215 HV * hv; 1216 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1217 hv = GvSTASH(a0.any_gv); 1218 if (hv && HvHasENAME(hv) && ( 1219 (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV) 1220 || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV) 1221 )) 1222 { 1223 if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv) 1224 || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp) 1225 || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */ 1226 PL_sub_generation++; 1227 else mro_method_changed_in(hv); 1228 } 1229 a0.any_svp = a1.any_svp; 1230 a1.any_sv = a2.any_sv; 1231 goto restore_svp; 1232 } 1233 1234 case SAVEt_AV: /* array reference */ 1235 a0 = ap[0]; a1 = ap[1]; 1236 SvREFCNT_dec(GvAV(a0.any_gv)); 1237 GvAV(a0.any_gv) = a1.any_av; 1238 avhv_common: 1239 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) { 1240 /* mg_set might die, so make sure a0 isn't leaked */ 1241 dSS_ADD; 1242 SS_ADD_PTR(a0.any_sv); 1243 SS_ADD_UV(SAVEt_FREESV); 1244 SS_ADD_END(2); 1245 PL_localizing = 2; 1246 mg_set(a1.any_sv); 1247 PL_localizing = 0; 1248 break; 1249 } 1250 SvREFCNT_dec_NN(a0.any_sv); 1251 break; 1252 1253 case SAVEt_HV: /* hash reference */ 1254 a0 = ap[0]; a1 = ap[1]; 1255 SvREFCNT_dec(GvHV(a0.any_gv)); 1256 GvHV(a0.any_gv) = a1.any_hv; 1257 goto avhv_common; 1258 1259 case SAVEt_INT_SMALL: 1260 a0 = ap[0]; 1261 *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT); 1262 break; 1263 1264 case SAVEt_INT: /* int reference */ 1265 a0 = ap[0]; a1 = ap[1]; 1266 *(int*)a1.any_ptr = (int)a0.any_i32; 1267 break; 1268 1269 case SAVEt_STRLEN_SMALL: 1270 a0 = ap[0]; 1271 *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT); 1272 break; 1273 1274 case SAVEt_STRLEN: /* STRLEN/size_t ref */ 1275 a0 = ap[0]; a1 = ap[1]; 1276 *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv; 1277 break; 1278 1279 case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */ 1280 a0 = ap[0]; 1281 PL_tmps_floor = (SSize_t)a0.any_iv; 1282 break; 1283 1284 case SAVEt_BOOL: /* bool reference */ 1285 a0 = ap[0]; 1286 *(bool*)a0.any_ptr = cBOOL(uv >> 8); 1287 #ifdef NO_TAINT_SUPPORT 1288 PERL_UNUSED_VAR(was); 1289 #else 1290 if (UNLIKELY(a0.any_ptr == &(PL_tainted))) { 1291 /* If we don't update <was>, to reflect what was saved on the 1292 * stack for PL_tainted, then we will overwrite this attempt to 1293 * restore it when we exit this routine. Note that this won't 1294 * work if this value was saved in a wider-than necessary type, 1295 * such as I32 */ 1296 was = *(bool*)a0.any_ptr; 1297 } 1298 #endif 1299 break; 1300 1301 case SAVEt_I32_SMALL: 1302 a0 = ap[0]; 1303 *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT); 1304 break; 1305 1306 case SAVEt_I32: /* I32 reference */ 1307 a0 = ap[0]; a1 = ap[1]; 1308 #ifdef PERL_DEBUG_READONLY_OPS 1309 if (*(I32*)a1.any_ptr != a0.any_i32) 1310 #endif 1311 *(I32*)a1.any_ptr = a0.any_i32; 1312 break; 1313 1314 case SAVEt_SPTR: /* SV* reference */ 1315 case SAVEt_VPTR: /* random* reference */ 1316 case SAVEt_PPTR: /* char* reference */ 1317 case SAVEt_HPTR: /* HV* reference */ 1318 case SAVEt_APTR: /* AV* reference */ 1319 a0 = ap[0]; a1 = ap[1]; 1320 *a1.any_svp= a0.any_sv; 1321 break; 1322 1323 case SAVEt_GP: /* scalar reference */ 1324 { 1325 HV *hv; 1326 bool had_method; 1327 1328 a0 = ap[0]; a1 = ap[1]; 1329 /* possibly taking a method out of circulation */ 1330 had_method = cBOOL(GvCVu(a0.any_gv)); 1331 gp_free(a0.any_gv); 1332 GvGP_set(a0.any_gv, (GP*)a1.any_ptr); 1333 if ((hv=GvSTASH(a0.any_gv)) && HvHasENAME(hv)) { 1334 if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA")) 1335 mro_isa_changed_in(hv); 1336 else if (had_method || GvCVu(a0.any_gv)) 1337 /* putting a method back into circulation ("local")*/ 1338 gv_method_changed(a0.any_gv); 1339 } 1340 SvREFCNT_dec_NN(a0.any_gv); 1341 break; 1342 } 1343 1344 case SAVEt_FREESV: 1345 a0 = ap[0]; 1346 SvREFCNT_dec(a0.any_sv); 1347 break; 1348 1349 case SAVEt_FREEPADNAME: 1350 a0 = ap[0]; 1351 PadnameREFCNT_dec((PADNAME *)a0.any_ptr); 1352 break; 1353 1354 case SAVEt_FREECOPHH: 1355 a0 = ap[0]; 1356 cophh_free((COPHH *)a0.any_ptr); 1357 break; 1358 1359 case SAVEt_MORTALIZESV: 1360 a0 = ap[0]; 1361 sv_2mortal(a0.any_sv); 1362 break; 1363 1364 case SAVEt_FREEOP: 1365 a0 = ap[0]; 1366 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); 1367 op_free(a0.any_op); 1368 break; 1369 1370 case SAVEt_FREEPV: 1371 a0 = ap[0]; 1372 Safefree(a0.any_ptr); 1373 break; 1374 1375 case SAVEt_CLEARPADRANGE: 1376 { 1377 I32 i; 1378 SV **svp; 1379 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK); 1380 svp = &PL_curpad[uv >> 1381 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1; 1382 goto clearsv; 1383 case SAVEt_CLEARSV: 1384 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT]; 1385 i = 1; 1386 clearsv: 1387 for (; i; i--, svp--) { 1388 SV *sv = *svp; 1389 1390 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1391 "Pad 0x%" UVxf "[0x%" UVxf "] clearsv: %ld sv=0x%" UVxf "<%" IVdf "> %s\n", 1392 PTR2UV(PL_comppad), PTR2UV(PL_curpad), 1393 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), 1394 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" 1395 )); 1396 1397 /* Can clear pad variable in place? */ 1398 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) { 1399 1400 /* these flags are the union of all the relevant flags 1401 * in the individual conditions within */ 1402 if (UNLIKELY(SvFLAGS(sv) & ( 1403 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/ 1404 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */ 1405 | SVf_OOK 1406 | SVf_THINKFIRST))) 1407 { 1408 /* if a my variable that was made readonly is 1409 * going out of scope, we want to remove the 1410 * readonlyness so that it can go out of scope 1411 * quietly 1412 */ 1413 if (SvREADONLY(sv)) 1414 SvREADONLY_off(sv); 1415 1416 if (SvTYPE(sv) == SVt_PVHV && HvHasAUX(sv)) 1417 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); 1418 else if(SvOOK(sv)) 1419 sv_backoff(sv); 1420 1421 if (SvMAGICAL(sv)) { 1422 /* note that backrefs (either in HvAUX or magic) 1423 * must be removed before other magic */ 1424 sv_unmagic(sv, PERL_MAGIC_backref); 1425 if (SvTYPE(sv) != SVt_PVCV) 1426 mg_free(sv); 1427 } 1428 if (SvTHINKFIRST(sv)) 1429 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF 1430 |SV_COW_DROP_PV); 1431 1432 } 1433 switch (SvTYPE(sv)) { 1434 case SVt_NULL: 1435 break; 1436 case SVt_PVAV: 1437 av_clear(MUTABLE_AV(sv)); 1438 break; 1439 case SVt_PVHV: 1440 hv_clear(MUTABLE_HV(sv)); 1441 break; 1442 case SVt_PVCV: 1443 { 1444 HEK *hek = CvGvNAME_HEK(sv); 1445 assert(hek); 1446 (void)share_hek_hek(hek); 1447 cv_undef((CV *)sv); 1448 CvNAME_HEK_set(sv, hek); 1449 CvLEXICAL_on(sv); 1450 break; 1451 } 1452 default: 1453 /* This looks odd, but these two macros are for use in 1454 expressions and finish with a trailing comma, so 1455 adding a ; after them would be wrong. */ 1456 assert_not_ROK(sv) 1457 assert_not_glob(sv) 1458 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8); 1459 break; 1460 } 1461 SvPADTMP_off(sv); 1462 SvPADSTALE_on(sv); /* mark as no longer live */ 1463 } 1464 else { /* Someone has a claim on this, so abandon it. */ 1465 switch (SvTYPE(sv)) { /* Console ourselves with a new value */ 1466 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break; 1467 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break; 1468 case SVt_PVCV: 1469 { 1470 HEK * const hek = CvGvNAME_HEK(sv); 1471 1472 /* Create a stub */ 1473 *svp = newSV_type(SVt_PVCV); 1474 1475 /* Share name */ 1476 CvNAME_HEK_set(*svp, 1477 share_hek_hek(hek)); 1478 CvLEXICAL_on(*svp); 1479 break; 1480 } 1481 default: *svp = newSV_type(SVt_NULL); break; 1482 } 1483 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */ 1484 /* preserve pad nature, but also mark as not live 1485 * for any closure capturing */ 1486 SvFLAGS(*svp) |= SVs_PADSTALE; 1487 } 1488 } 1489 break; 1490 } 1491 1492 case SAVEt_DELETE: 1493 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1494 /* hv_delete could die, so free the key and SvREFCNT_dec the 1495 * hv by pushing new save actions 1496 */ 1497 /* ap[0] is the key */ 1498 ap[1].any_uv = SAVEt_FREEPV; /* was len */ 1499 /* ap[2] is the hv */ 1500 ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */ 1501 PL_savestack_ix += 4; 1502 (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD); 1503 break; 1504 1505 case SAVEt_ADELETE: 1506 a0 = ap[0]; a1 = ap[1]; 1507 /* av_delete could die, so SvREFCNT_dec the av by pushing a 1508 * new save action 1509 */ 1510 ap[0].any_av = a1.any_av; 1511 ap[1].any_uv = SAVEt_FREESV; 1512 PL_savestack_ix += 2; 1513 (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD); 1514 break; 1515 1516 case SAVEt_DESTRUCTOR_X: 1517 a0 = ap[0]; a1 = ap[1]; 1518 (*a0.any_dxptr)(aTHX_ a1.any_ptr); 1519 break; 1520 1521 case SAVEt_REGCONTEXT: 1522 /* regexp must have croaked */ 1523 case SAVEt_ALLOC: 1524 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT; 1525 break; 1526 1527 case SAVEt_STACK_POS: /* Position on Perl stack */ 1528 a0 = ap[0]; 1529 PL_stack_sp = PL_stack_base + a0.any_i32; 1530 break; 1531 1532 case SAVEt_AELEM: /* array element */ 1533 { 1534 SV **svp; 1535 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1536 svp = av_fetch(a0.any_av, a1.any_iv, 1); 1537 if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */ 1538 SvREFCNT_dec(a2.any_sv); 1539 if (LIKELY(svp)) { 1540 SV * const sv = *svp; 1541 if (LIKELY(sv && sv != &PL_sv_undef)) { 1542 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied))) 1543 SvREFCNT_inc_void_NN(sv); 1544 a1.any_sv = a2.any_sv; 1545 a2.any_svp = svp; 1546 goto restore_sv; 1547 } 1548 } 1549 SvREFCNT_dec(a0.any_av); 1550 SvREFCNT_dec(a2.any_sv); 1551 break; 1552 } 1553 1554 case SAVEt_HELEM: /* hash element */ 1555 { 1556 HE *he; 1557 1558 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1559 he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0); 1560 SvREFCNT_dec(a1.any_sv); 1561 if (LIKELY(he)) { 1562 const SV * const oval = HeVAL(he); 1563 if (LIKELY(oval && oval != &PL_sv_undef)) { 1564 SV **svp = &HeVAL(he); 1565 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied))) 1566 SvREFCNT_inc_void(*svp); 1567 a1.any_sv = a2.any_sv; 1568 a2.any_svp = svp; 1569 goto restore_sv; 1570 } 1571 } 1572 SvREFCNT_dec(a0.any_hv); 1573 SvREFCNT_dec(a2.any_sv); 1574 break; 1575 } 1576 1577 case SAVEt_OP: 1578 a0 = ap[0]; 1579 PL_op = (OP*)a0.any_ptr; 1580 break; 1581 1582 case SAVEt_HINTS_HH: 1583 a2 = ap[2]; 1584 /* FALLTHROUGH */ 1585 case SAVEt_HINTS: 1586 a0 = ap[0]; a1 = ap[1]; 1587 if ((PL_hints & HINT_LOCALIZE_HH)) { 1588 while (GvHV(PL_hintgv)) { 1589 HV *hv = GvHV(PL_hintgv); 1590 GvHV(PL_hintgv) = NULL; 1591 SvREFCNT_dec(MUTABLE_SV(hv)); 1592 } 1593 } 1594 cophh_free(CopHINTHASH_get(&PL_compiling)); 1595 CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr); 1596 *(I32*)&PL_hints = a0.any_i32; 1597 PL_prevailing_version = (U16)(uv >> 8); 1598 if (type == SAVEt_HINTS_HH) { 1599 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); 1600 GvHV(PL_hintgv) = MUTABLE_HV(a2.any_ptr); 1601 } 1602 if (!GvHV(PL_hintgv)) { 1603 /* Need to add a new one manually, else rv2hv can 1604 add one via GvHVn and it won't have the magic set. */ 1605 HV *const hv = newHV(); 1606 hv_magic(hv, NULL, PERL_MAGIC_hints); 1607 GvHV(PL_hintgv) = hv; 1608 } 1609 assert(GvHV(PL_hintgv)); 1610 break; 1611 1612 case SAVEt_COMPPAD: 1613 a0 = ap[0]; 1614 PL_comppad = (PAD*)a0.any_ptr; 1615 if (LIKELY(PL_comppad)) 1616 PL_curpad = AvARRAY(PL_comppad); 1617 else 1618 PL_curpad = NULL; 1619 break; 1620 1621 case SAVEt_PADSV_AND_MORTALIZE: 1622 { 1623 SV **svp; 1624 1625 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1626 assert (a1.any_ptr); 1627 svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv; 1628 /* This mortalizing used to be done by CX_POOPLOOP() via 1629 itersave. But as we have all the information here, we 1630 can do it here, save even having to have itersave in 1631 the struct. 1632 */ 1633 sv_2mortal(*svp); 1634 *svp = a0.any_sv; 1635 } 1636 break; 1637 1638 case SAVEt_SAVESWITCHSTACK: 1639 { 1640 dSP; 1641 1642 a0 = ap[0]; a1 = ap[1]; 1643 SWITCHSTACK(a1.any_av, a0.any_av); 1644 PL_curstackinfo->si_stack = a0.any_av; 1645 } 1646 break; 1647 1648 case SAVEt_SET_SVFLAGS: 1649 a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; 1650 SvFLAGS(a0.any_sv) &= ~(a1.any_u32); 1651 SvFLAGS(a0.any_sv) |= a2.any_u32; 1652 break; 1653 1654 /* These are only saved in mathoms.c */ 1655 case SAVEt_NSTAB: 1656 a0 = ap[0]; 1657 (void)sv_clear(a0.any_sv); 1658 break; 1659 1660 case SAVEt_LONG: /* long reference */ 1661 a0 = ap[0]; a1 = ap[1]; 1662 *(long*)a1.any_ptr = a0.any_long; 1663 break; 1664 1665 case SAVEt_IV: /* IV reference */ 1666 a0 = ap[0]; a1 = ap[1]; 1667 *(IV*)a1.any_ptr = a0.any_iv; 1668 break; 1669 1670 case SAVEt_I16: /* I16 reference */ 1671 a0 = ap[0]; 1672 *(I16*)a0.any_ptr = (I16)(uv >> 8); 1673 break; 1674 1675 case SAVEt_I8: /* I8 reference */ 1676 a0 = ap[0]; 1677 *(I8*)a0.any_ptr = (I8)(uv >> 8); 1678 break; 1679 1680 case SAVEt_DESTRUCTOR: 1681 a0 = ap[0]; a1 = ap[1]; 1682 (*a0.any_dptr)(a1.any_ptr); 1683 break; 1684 1685 case SAVEt_COMPILE_WARNINGS: 1686 /* NOTE: we can't put &PL_compiling or PL_curcop on the save 1687 * stack directly, as we currently cannot translate 1688 * them to the correct addresses after a thread start 1689 * or win32 fork start. - Yves 1690 */ 1691 a0 = ap[0]; 1692 free_and_set_cop_warnings(&PL_compiling, a0.any_pv); 1693 break; 1694 1695 case SAVEt_CURCOP_WARNINGS: 1696 /* NOTE: see comment above about SAVEt_COMPILE_WARNINGS */ 1697 a0 = ap[0]; 1698 free_and_set_cop_warnings(PL_curcop, a0.any_pv); 1699 break; 1700 1701 case SAVEt_PARSER: 1702 a0 = ap[0]; 1703 parser_free((yy_parser *)a0.any_ptr); 1704 break; 1705 1706 case SAVEt_READONLY_OFF: 1707 a0 = ap[0]; 1708 SvREADONLY_off(a0.any_sv); 1709 break; 1710 1711 default: 1712 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", 1713 (U8)uv & SAVE_MASK); 1714 } 1715 } 1716 1717 TAINT_set(was); 1718 } 1719 1720 void 1721 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) 1722 { 1723 PERL_ARGS_ASSERT_CX_DUMP; 1724 1725 #ifdef DEBUGGING 1726 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); 1727 if (CxTYPE(cx) != CXt_SUBST) { 1728 const char *gimme_text; 1729 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); 1730 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n", 1731 PTR2UV(cx->blk_oldcop)); 1732 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); 1733 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); 1734 PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix); 1735 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n", 1736 PTR2UV(cx->blk_oldpm)); 1737 switch (cx->blk_gimme) { 1738 case G_VOID: 1739 gimme_text = "VOID"; 1740 break; 1741 case G_SCALAR: 1742 gimme_text = "SCALAR"; 1743 break; 1744 case G_LIST: 1745 gimme_text = "LIST"; 1746 break; 1747 default: 1748 gimme_text = "UNKNOWN"; 1749 break; 1750 } 1751 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text); 1752 } 1753 switch (CxTYPE(cx)) { 1754 case CXt_NULL: 1755 case CXt_BLOCK: 1756 case CXt_DEFER: 1757 break; 1758 case CXt_FORMAT: 1759 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n", 1760 PTR2UV(cx->blk_format.cv)); 1761 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n", 1762 PTR2UV(cx->blk_format.gv)); 1763 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n", 1764 PTR2UV(cx->blk_format.dfoutgv)); 1765 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n", 1766 (int)CxHASARGS(cx)); 1767 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n", 1768 PTR2UV(cx->blk_format.retop)); 1769 break; 1770 case CXt_SUB: 1771 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n", 1772 PTR2UV(cx->blk_sub.cv)); 1773 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", 1774 (long)cx->blk_sub.olddepth); 1775 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", 1776 (int)CxHASARGS(cx)); 1777 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); 1778 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n", 1779 PTR2UV(cx->blk_sub.retop)); 1780 break; 1781 case CXt_EVAL: 1782 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", 1783 (long)CxOLD_IN_EVAL(cx)); 1784 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", 1785 PL_op_name[CxOLD_OP_TYPE(cx)], 1786 PL_op_desc[CxOLD_OP_TYPE(cx)]); 1787 if (cx->blk_eval.old_namesv) 1788 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", 1789 SvPVX_const(cx->blk_eval.old_namesv)); 1790 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n", 1791 PTR2UV(cx->blk_eval.old_eval_root)); 1792 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n", 1793 PTR2UV(cx->blk_eval.retop)); 1794 break; 1795 1796 case CXt_LOOP_PLAIN: 1797 case CXt_LOOP_LAZYIV: 1798 case CXt_LOOP_LAZYSV: 1799 case CXt_LOOP_LIST: 1800 case CXt_LOOP_ARY: 1801 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); 1802 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n", 1803 PTR2UV(cx->blk_loop.my_op)); 1804 if (CxTYPE(cx) != CXt_LOOP_PLAIN) { 1805 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n", 1806 PTR2UV(CxITERVAR(cx))); 1807 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n", 1808 PTR2UV(cx->blk_loop.itersave)); 1809 } 1810 if (CxTYPE(cx) == CXt_LOOP_ARY) { 1811 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n", 1812 PTR2UV(cx->blk_loop.state_u.ary.ary)); 1813 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", 1814 (long)cx->blk_loop.state_u.ary.ix); 1815 } 1816 break; 1817 1818 case CXt_SUBST: 1819 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", 1820 (long)cx->sb_iters); 1821 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", 1822 (long)cx->sb_maxiters); 1823 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", 1824 (long)cx->sb_rflags); 1825 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", 1826 (long)CxONCE(cx)); 1827 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", 1828 cx->sb_orig); 1829 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n", 1830 PTR2UV(cx->sb_dstr)); 1831 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n", 1832 PTR2UV(cx->sb_targ)); 1833 PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n", 1834 PTR2UV(cx->sb_s)); 1835 PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n", 1836 PTR2UV(cx->sb_m)); 1837 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n", 1838 PTR2UV(cx->sb_strend)); 1839 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n", 1840 PTR2UV(cx->sb_rxres)); 1841 break; 1842 } 1843 #else 1844 PERL_UNUSED_CONTEXT; 1845 PERL_UNUSED_ARG(cx); 1846 #endif /* DEBUGGING */ 1847 } 1848 1849 /* 1850 =for apidoc_section $callback 1851 =for apidoc mortal_destructor_sv 1852 1853 This function arranges for either a Perl code reference, or a C function 1854 reference to be called at the B<end of the current statement>. 1855 1856 The C<coderef> argument determines the type of function that will be 1857 called. If it is C<SvROK()> it is assumed to be a reference to a CV and 1858 will arrange for the coderef to be called. If it is not SvROK() then it 1859 is assumed to be a C<SvIV()> which is C<SvIOK()> whose value is a pointer 1860 to a C function of type C<DESTRUCTORFUNC_t> created using C<PTR2INT()>. 1861 Either way the C<args> parameter will be provided to the callback as a 1862 parameter, although the rules for doing so differ between the Perl and 1863 C mode. Normally this function is only used directly for the Perl case 1864 and the wrapper C<mortal_destructor_x()> is used for the C function case. 1865 1866 When operating in Perl callback mode the C<args> parameter may be NULL 1867 in which case the code reference is called with no arguments, otherwise 1868 if it is an AV (SvTYPE(args) == SVt_PVAV) then the contents of the AV 1869 will be used as the arguments to the code reference, and if it is any 1870 other type then the C<args> SV will be provided as a single argument to 1871 the code reference. 1872 1873 When operating in a C callback mode the C<args> parameter will be passed 1874 directly to the C function as a C<void *> pointer. No additional 1875 processing of the argument will be peformed, and it is the callers 1876 responsibility to free the C<args> parameter if necessary. 1877 1878 Be aware that there is a signficant difference in timing between the 1879 I<end of the current statement> and the I<end of the current pseudo 1880 block>. If you are looking for a mechanism to trigger a function at the 1881 end of the B<current pseudo block> you should look at 1882 C<SAVEDESTRUCTORX()> instead of this function. 1883 1884 =for apidoc mortal_svfunc_x 1885 1886 This function arranges for a C function reference to be called at the 1887 B<end of the current statement> with the arguments provided. It is a 1888 wrapper around C<mortal_destructor_sv()> which ensures that the latter 1889 function is called appropriately. 1890 1891 Be aware that there is a signficant difference in timing between the 1892 I<end of the current statement> and the I<end of the current pseudo 1893 block>. If you are looking for a mechanism to trigger a function at the 1894 end of the B<current pseudo block> you should look at 1895 C<SAVEDESTRUCTORX()> instead of this function. 1896 1897 =for apidoc magic_freedestruct 1898 1899 This function is called via magic to implement the 1900 C<mortal_destructor_sv()> and C<mortal_destructor_x()> functions. It 1901 should not be called directly and has no user servicable parts. 1902 1903 =cut 1904 */ 1905 1906 void 1907 Perl_mortal_destructor_sv(pTHX_ SV *coderef, SV *args) { 1908 PERL_ARGS_ASSERT_MORTAL_DESTRUCTOR_SV; 1909 assert( 1910 (SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) /* perl coderef */ 1911 || 1912 (SvIOK(coderef) && !SvROK(coderef)) /* C function ref */ 1913 ); 1914 SV *variable = newSV_type_mortal(SVt_IV); 1915 (void)sv_magicext(variable, coderef, PERL_MAGIC_destruct, 1916 &PL_vtbl_destruct, (char *)args, args ? HEf_SVKEY : 0); 1917 } 1918 1919 1920 void 1921 Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f, SV *sv) { 1922 PERL_ARGS_ASSERT_MORTAL_SVFUNC_X; 1923 SV *sviv = newSViv(PTR2IV(f)); 1924 mortal_destructor_sv(sviv,sv); 1925 } 1926 1927 1928 int 1929 Perl_magic_freedestruct(pTHX_ SV* sv, MAGIC* mg) { 1930 PERL_ARGS_ASSERT_MAGIC_FREEDESTRUCT; 1931 dSP; 1932 union { 1933 SV *sv; 1934 AV *av; 1935 char *pv; 1936 } args_any; 1937 SV *coderef; 1938 1939 IV nargs = 0; 1940 if (PL_phase == PERL_PHASE_DESTRUCT) { 1941 Perl_warn(aTHX_ "Can't call destructor for 0x%p in global destruction\n", sv); 1942 return 1; 1943 } 1944 1945 args_any.pv = mg->mg_ptr; 1946 coderef = mg->mg_obj; 1947 1948 /* Deal with C function destructor */ 1949 if (SvTYPE(coderef) == SVt_IV && !SvROK(coderef)) { 1950 SVFUNC_t f = INT2PTR(SVFUNC_t, SvIV(coderef)); 1951 (f)(aTHX_ args_any.sv); 1952 return 0; 1953 } 1954 1955 if (args_any.sv) { 1956 if (SvTYPE(args_any.sv) == SVt_PVAV) { 1957 nargs = av_len(args_any.av) + 1; 1958 } else { 1959 nargs = 1; 1960 } 1961 } 1962 PUSHSTACKi(PERLSI_MAGIC); 1963 ENTER_with_name("call_freedestruct"); 1964 SAVETMPS; 1965 EXTEND(SP, nargs); 1966 PUSHMARK(SP); 1967 if (args_any.sv) { 1968 if (SvTYPE(args_any.sv) == SVt_PVAV) { 1969 IV n; 1970 for (n = 0 ; n < nargs ; n++ ) { 1971 SV **argp = av_fetch(args_any.av, n, 0); 1972 if (argp && *argp) 1973 PUSHs(*argp); 1974 } 1975 } else { 1976 PUSHs(args_any.sv); 1977 } 1978 } 1979 PUTBACK; 1980 (void)call_sv(coderef, G_VOID | G_EVAL | G_KEEPERR); 1981 FREETMPS; 1982 LEAVE_with_name("call_freedestruct"); 1983 POPSTACK; 1984 return 0; 1985 } 1986 1987 1988 /* 1989 * ex: set ts=8 sts=4 sw=4 et: 1990 */ 1991