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