/* scope.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "For the fashion of Minas Tirith was such that it was built on seven * levels..." */ /* This file contains functions to manipulate several of Perl's stacks; * in particular it contains code to push various types of things onto * the savestack, then to pop them off and perform the correct restorative * action for each one. This corresponds to the cleanup Perl does at * each scope exit. */ #include "EXTERN.h" #define PERL_IN_SCOPE_C #include "perl.h" SV** Perl_stack_grow(pTHX_ SV **sp, SV **p, int n) 1207 { 1207 PL_stack_sp = sp; #ifndef STRESS_REALLOC 1207 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); #else av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1); #endif 1207 return PL_stack_sp; } #ifndef STRESS_REALLOC #define GROW(old) ((old) * 3 / 2) #else #define GROW(old) ((old) + 1) #endif PERL_SI * Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) 6421 { 6421 PERL_SI *si; 6421 New(56, si, 1, PERL_SI); 6421 si->si_stack = newAV(); 6421 AvREAL_off(si->si_stack); 6421 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); 6421 AvALLOC(si->si_stack)[0] = &PL_sv_undef; 6421 AvFILLp(si->si_stack) = 0; 6421 si->si_prev = 0; 6421 si->si_next = 0; 6421 si->si_cxmax = cxitems - 1; 6421 si->si_cxix = -1; 6421 si->si_type = PERLSI_UNDEF; 6421 New(56, si->si_cxstack, cxitems, PERL_CONTEXT); /* Without any kind of initialising PUSHSUBST() * in pp_subst() will read uninitialised heap. */ 6421 Poison(si->si_cxstack, cxitems, PERL_CONTEXT); 6421 return si; } I32 Perl_cxinc(pTHX) 42 { 42 const IV old_max = cxstack_max; 42 cxstack_max = GROW(cxstack_max); 42 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */ /* Without any kind of initialising deep enough recursion * will end up reading uninitialised PERL_CONTEXTs. */ 42 Poison(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT); 42 return cxstack_ix + 1; } void Perl_push_scope(pTHX) 42796435 { 42796435 if (PL_scopestack_ix == PL_scopestack_max) { 3369 PL_scopestack_max = GROW(PL_scopestack_max); 3369 Renew(PL_scopestack, PL_scopestack_max, I32); } 42796435 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; } void Perl_pop_scope(pTHX) 40725852 { 40725852 const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; 40725852 LEAVE_SCOPE(oldsave); } void Perl_markstack_grow(pTHX) 10 { 10 const I32 oldmax = PL_markstack_max - PL_markstack; 10 const I32 newmax = GROW(oldmax); 10 Renew(PL_markstack, newmax, I32); 10 PL_markstack_ptr = PL_markstack + oldmax; 10 PL_markstack_max = PL_markstack + newmax; } void Perl_savestack_grow(pTHX) 16714 { 16714 PL_savestack_max = GROW(PL_savestack_max) + 4; 16714 Renew(PL_savestack, PL_savestack_max, ANY); } void Perl_savestack_grow_cnt(pTHX_ I32 need) 1 { 1 PL_savestack_max = PL_savestack_ix + need; 1 Renew(PL_savestack, PL_savestack_max, ANY); } #undef GROW void Perl_tmps_grow(pTHX_ I32 n) 3678 { #ifndef STRESS_REALLOC 3678 if (n < 128) 3470 n = (PL_tmps_max < 512) ? 128 : 512; #endif 3678 PL_tmps_max = PL_tmps_ix + n + 1; 3678 Renew(PL_tmps_stack, PL_tmps_max, SV*); } void Perl_free_tmps(pTHX) 22201817 { /* XXX should tmps_floor live in cxstack? */ 22201817 const I32 myfloor = PL_tmps_floor; 73482224 while (PL_tmps_ix > myfloor) { /* clean up after last statement */ 51280407 SV* const sv = PL_tmps_stack[PL_tmps_ix]; 51280407 PL_tmps_stack[PL_tmps_ix--] = Nullsv; 51280407 if (sv && sv != &PL_sv_undef) { 51280406 SvTEMP_off(sv); 51280406 SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */ } } } STATIC SV * S_save_scalar_at(pTHX_ SV **sptr) 18607077 { 18607077 SV * const osv = *sptr; 18607077 register SV * const sv = *sptr = NEWSV(0,0); 18607077 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) { 237134 if (SvGMAGICAL(osv)) { 232415 const bool oldtainted = PL_tainted; 232415 SvFLAGS(osv) |= (SvFLAGS(osv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; 232415 PL_tainted = oldtainted; } 237134 mg_localize(osv, sv); } 18607077 return sv; } SV * Perl_save_scalar(pTHX_ GV *gv) 18584691 { 18584691 SV **sptr = &GvSV(gv); 18584691 SvGETMAGIC(*sptr); 18584690 SSCHECK(3); 18584690 SSPUSHPTR(SvREFCNT_inc(gv)); 18584690 SSPUSHPTR(SvREFCNT_inc(*sptr)); 18584690 SSPUSHINT(SAVEt_SV); 18584690 return save_scalar_at(sptr); } SV* Perl_save_svref(pTHX_ SV **sptr) ###### { ###### SvGETMAGIC(*sptr); ###### SSCHECK(3); ###### SSPUSHPTR(sptr); ###### SSPUSHPTR(SvREFCNT_inc(*sptr)); ###### SSPUSHINT(SAVEt_SVREF); ###### return save_scalar_at(sptr); } /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to * restore a global SV to its prior contents, freeing new value. */ void Perl_save_generic_svref(pTHX_ SV **sptr) 434871 { 434871 SSCHECK(3); 434871 SSPUSHPTR(sptr); 434871 SSPUSHPTR(SvREFCNT_inc(*sptr)); 434871 SSPUSHINT(SAVEt_GENERIC_SVREF); } /* Like save_pptr(), but also Safefree()s the new value if it is different * from the old one. Can be used to restore a global char* to its prior * contents, freeing new value. */ void Perl_save_generic_pvref(pTHX_ char **str) 1898988 { 1898988 SSCHECK(3); 1898988 SSPUSHPTR(str); 1898988 SSPUSHPTR(*str); 1898988 SSPUSHINT(SAVEt_GENERIC_PVREF); } /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree(). * Can be used to restore a shared global char* to its prior * contents, freeing new value. */ void Perl_save_shared_pvref(pTHX_ char **str) ###### { ###### SSCHECK(3); ###### SSPUSHPTR(str); ###### SSPUSHPTR(*str); ###### SSPUSHINT(SAVEt_SHARED_PVREF); } /* set the SvFLAGS specified by mask to the values in val */ void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) 418925 { 418925 SSCHECK(4); 418925 SSPUSHPTR(sv); 418925 SSPUSHINT(mask); 418925 SSPUSHINT(val); 418925 SSPUSHINT(SAVEt_SET_SVFLAGS); } void Perl_save_gp(pTHX_ GV *gv, I32 empty) 30481 { 30481 SSGROW(6); 30481 SSPUSHIV((IV)SvLEN(gv)); 30481 SvLEN_set(gv, 0); /* forget that anything was allocated here */ 30481 SSPUSHIV((IV)SvCUR(gv)); 30481 SSPUSHPTR(SvPVX_const(gv)); 30481 SvPOK_off(gv); 30481 SSPUSHPTR(SvREFCNT_inc(gv)); 30481 SSPUSHPTR(GvGP(gv)); 30481 SSPUSHINT(SAVEt_GP); 30481 if (empty) { 13797 register GP *gp; 13797 Newz(602, gp, 1, GP); 13797 if (GvCVu(gv)) 4 PL_sub_generation++; /* taking a method out of circulation */ 13797 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { 3 gp->gp_io = newIO(); 3 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; } 13797 GvGP(gv) = gp_ref(gp); 13797 GvSV(gv) = NEWSV(72,0); 13797 GvLINE(gv) = CopLINE(PL_curcop); /* XXX Ideally this cast would be replaced with a change to const char* in the struct. */ 13797 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) ""; 13797 GvEGV(gv) = gv; } else { 16684 gp_ref(GvGP(gv)); 16684 GvINTRO_on(gv); } } AV * Perl_save_ary(pTHX_ GV *gv) 3010 { 3010 AV * const oav = GvAVn(gv); 3010 AV *av; 3010 if (!AvREAL(oav) && AvREIFY(oav)) 3 av_reify(oav); 3010 SSCHECK(3); 3010 SSPUSHPTR(gv); 3010 SSPUSHPTR(oav); 3010 SSPUSHINT(SAVEt_AV); 3010 GvAV(gv) = Null(AV*); 3010 av = GvAVn(gv); 3010 if (SvMAGIC(oav)) 348 mg_localize((SV*)oav, (SV*)av); 3010 return av; } HV * Perl_save_hash(pTHX_ GV *gv) 3235 { 3235 HV *ohv, *hv; 3235 SSCHECK(3); 3235 SSPUSHPTR(gv); 3235 SSPUSHPTR(ohv = GvHVn(gv)); 3235 SSPUSHINT(SAVEt_HV); 3235 GvHV(gv) = Null(HV*); 3235 hv = GvHVn(gv); 3235 if (SvMAGIC(ohv)) 20 mg_localize((SV*)ohv, (SV*)hv); 3235 return hv; } void Perl_save_item(pTHX_ register SV *item) 524848 { 524848 register SV * const sv = newSVsv(item); 524848 SSCHECK(3); 524848 SSPUSHPTR(item); /* remember the pointer */ 524848 SSPUSHPTR(sv); /* remember the value */ 524848 SSPUSHINT(SAVEt_ITEM); } void Perl_save_int(pTHX_ int *intp) 33728259 { 33728259 SSCHECK(3); 33728259 SSPUSHINT(*intp); 33728259 SSPUSHPTR(intp); 33728259 SSPUSHINT(SAVEt_INT); } void Perl_save_long(pTHX_ long int *longp) ###### { ###### SSCHECK(3); ###### SSPUSHLONG(*longp); ###### SSPUSHPTR(longp); ###### SSPUSHINT(SAVEt_LONG); } void Perl_save_bool(pTHX_ bool *boolp) 47186 { 47186 SSCHECK(3); 47186 SSPUSHBOOL(*boolp); 47186 SSPUSHPTR(boolp); 47186 SSPUSHINT(SAVEt_BOOL); } void Perl_save_I32(pTHX_ I32 *intp) 18003367 { 18003367 SSCHECK(3); 18003367 SSPUSHINT(*intp); 18003367 SSPUSHPTR(intp); 18003367 SSPUSHINT(SAVEt_I32); } void Perl_save_I16(pTHX_ I16 *intp) ###### { ###### SSCHECK(3); ###### SSPUSHINT(*intp); ###### SSPUSHPTR(intp); ###### SSPUSHINT(SAVEt_I16); } void Perl_save_I8(pTHX_ I8 *bytep) ###### { ###### SSCHECK(3); ###### SSPUSHINT(*bytep); ###### SSPUSHPTR(bytep); ###### SSPUSHINT(SAVEt_I8); } void Perl_save_iv(pTHX_ IV *ivp) ###### { ###### SSCHECK(3); ###### SSPUSHIV(*ivp); ###### SSPUSHPTR(ivp); ###### SSPUSHINT(SAVEt_IV); } /* Cannot use save_sptr() to store a char* since the SV** cast will * force word-alignment and we'll miss the pointer. */ void Perl_save_pptr(pTHX_ char **pptr) 6740830 { 6740830 SSCHECK(3); 6740830 SSPUSHPTR(*pptr); 6740830 SSPUSHPTR(pptr); 6740830 SSPUSHINT(SAVEt_PPTR); } void Perl_save_vptr(pTHX_ void *ptr) 6962531 { 6962531 SSCHECK(3); 6962531 SSPUSHPTR(*(char**)ptr); 6962531 SSPUSHPTR(ptr); 6962531 SSPUSHINT(SAVEt_VPTR); } void Perl_save_sptr(pTHX_ SV **sptr) 7108729 { 7108729 SSCHECK(3); 7108729 SSPUSHPTR(*sptr); 7108729 SSPUSHPTR(sptr); 7108729 SSPUSHINT(SAVEt_SPTR); } void Perl_save_padsv(pTHX_ PADOFFSET off) ###### { ###### SSCHECK(4); ###### ASSERT_CURPAD_ACTIVE("save_padsv"); ###### SSPUSHPTR(PL_curpad[off]); ###### SSPUSHPTR(PL_comppad); ###### SSPUSHLONG((long)off); ###### SSPUSHINT(SAVEt_PADSV); } SV ** Perl_save_threadsv(pTHX_ PADOFFSET i) ###### { ###### Perl_croak(aTHX_ "panic: save_threadsv called in non-threaded perl"); PERL_UNUSED_ARG(i); NORETURN_FUNCTION_END; } void Perl_save_nogv(pTHX_ GV *gv) ###### { ###### SSCHECK(2); ###### SSPUSHPTR(gv); ###### SSPUSHINT(SAVEt_NSTAB); } void Perl_save_hptr(pTHX_ HV **hptr) 39793 { 39793 SSCHECK(3); 39793 SSPUSHPTR(*hptr); 39793 SSPUSHPTR(hptr); 39793 SSPUSHINT(SAVEt_HPTR); } void Perl_save_aptr(pTHX_ AV **aptr) 332 { 332 SSCHECK(3); 332 SSPUSHPTR(*aptr); 332 SSPUSHPTR(aptr); 332 SSPUSHINT(SAVEt_APTR); } void Perl_save_freesv(pTHX_ SV *sv) 10287657 { 10287657 SSCHECK(2); 10287657 SSPUSHPTR(sv); 10287657 SSPUSHINT(SAVEt_FREESV); } void Perl_save_mortalizesv(pTHX_ SV *sv) 101767 { 101767 SSCHECK(2); 101767 SSPUSHPTR(sv); 101767 SSPUSHINT(SAVEt_MORTALIZESV); } void Perl_save_freeop(pTHX_ OP *o) 508297 { 508297 SSCHECK(2); 508297 SSPUSHPTR(o); 508297 SSPUSHINT(SAVEt_FREEOP); } void Perl_save_freepv(pTHX_ char *pv) 531330 { 531330 SSCHECK(2); 531330 SSPUSHPTR(pv); 531330 SSPUSHINT(SAVEt_FREEPV); } void Perl_save_clearsv(pTHX_ SV **svp) 46263878 { 46263878 ASSERT_CURPAD_ACTIVE("save_clearsv"); 46263878 SSCHECK(2); 46263878 SSPUSHLONG((long)(svp-PL_curpad)); 46263878 SSPUSHINT(SAVEt_CLEARSV); 46263878 SvPADSTALE_off(*svp); /* mark lexical as active */ } void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) 66792 { 66792 SSCHECK(4); 66792 SSPUSHINT(klen); 66792 SSPUSHPTR(key); 66792 SSPUSHPTR(SvREFCNT_inc(hv)); 66792 SSPUSHINT(SAVEt_DELETE); } void Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg) ###### { ###### register I32 i; ###### for (i = 1; i <= maxsarg; i++) { ###### register SV * const sv = NEWSV(0,0); ###### sv_setsv(sv,sarg[i]); ###### SSCHECK(3); ###### SSPUSHPTR(sarg[i]); /* remember the pointer */ ###### SSPUSHPTR(sv); /* remember the value */ ###### SSPUSHINT(SAVEt_ITEM); } } void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) ###### { ###### SSCHECK(3); ###### SSPUSHDPTR(f); ###### SSPUSHPTR(p); ###### SSPUSHINT(SAVEt_DESTRUCTOR); } void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) 17811852 { 17811852 SSCHECK(3); 17811852 SSPUSHDXPTR(f); 17811852 SSPUSHPTR(p); 17811852 SSPUSHINT(SAVEt_DESTRUCTOR_X); } void Perl_save_aelem(pTHX_ const AV *av, I32 idx, SV **sptr) 13 { 13 SV *sv; 13 SvGETMAGIC(*sptr); 13 SSCHECK(4); 13 SSPUSHPTR(SvREFCNT_inc(av)); 13 SSPUSHINT(idx); 13 SSPUSHPTR(SvREFCNT_inc(*sptr)); 13 SSPUSHINT(SAVEt_AELEM); /* if it gets reified later, the restore will have the wrong refcnt */ 13 if (!AvREAL(av) && AvREIFY(av)) 2 (void)SvREFCNT_inc(*sptr); 13 save_scalar_at(sptr); 13 sv = *sptr; /* If we're localizing a tied array element, this new sv * won't actually be stored in the array - so it won't get * reaped when the localize ends. Ensure it gets reaped by * mortifying it instead. DAPM */ 13 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) 3 sv_2mortal(sv); } void Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr) 22374 { 22374 SV *sv; 22374 SvGETMAGIC(*sptr); 22374 SSCHECK(4); 22374 SSPUSHPTR(SvREFCNT_inc(hv)); 22374 SSPUSHPTR(SvREFCNT_inc(key)); 22374 SSPUSHPTR(SvREFCNT_inc(*sptr)); 22374 SSPUSHINT(SAVEt_HELEM); 22374 save_scalar_at(sptr); 22374 sv = *sptr; /* If we're localizing a tied hash element, this new sv * won't actually be stored in the hash - so it won't get * reaped when the localize ends. Ensure it gets reaped by * mortifying it instead. DAPM */ 22374 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem)) 3 sv_2mortal(sv); } void Perl_save_op(pTHX) 2476607 { 2476607 SSCHECK(2); 2476607 SSPUSHPTR(PL_op); 2476607 SSPUSHINT(SAVEt_OP); } I32 Perl_save_alloc(pTHX_ I32 size, I32 pad) 19521198 { 19521198 register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] 19521198 - (char*)PL_savestack); 19521198 register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); /* SSCHECK may not be good enough */ 19521206 while (PL_savestack_ix + elems + 2 > PL_savestack_max) 8 savestack_grow(); 19521198 PL_savestack_ix += elems; 19521198 SSPUSHINT(elems); 19521198 SSPUSHINT(SAVEt_ALLOC); 19521198 return start; } void Perl_leave_scope(pTHX_ I32 base) 67636052 { 67636052 register SV *sv; 67636052 register SV *value; 67636052 register GV *gv; 67636052 register AV *av; 67636052 register HV *hv; 67636052 register void* ptr; 67636052 register char* str; 67636052 I32 i; 67636052 if (base < -1) ###### Perl_croak(aTHX_ "panic: corrupt saved stack index"); 247365429 while (PL_savestack_ix > base) { 179729377 switch (SSPOPINT) { case SAVEt_ITEM: /* normal string */ 524850 value = (SV*)SSPOPPTR; 524850 sv = (SV*)SSPOPPTR; 524850 sv_replace(sv,value); 524850 PL_localizing = 2; 524850 SvSETMAGIC(sv); 524850 PL_localizing = 0; 524850 break; case SAVEt_SV: /* scalar reference */ 18584680 value = (SV*)SSPOPPTR; 18584680 gv = (GV*)SSPOPPTR; 18584680 ptr = &GvSV(gv); 18584680 av = (AV*)gv; /* what to refcnt_dec */ 18584680 goto restore_sv; case SAVEt_GENERIC_PVREF: /* generic pv */ 1898994 str = (char*)SSPOPPTR; 1898994 ptr = SSPOPPTR; 1898994 if (*(char**)ptr != str) { 1851649 Safefree(*(char**)ptr); 1851649 *(char**)ptr = str; } 1851649 break; case SAVEt_SHARED_PVREF: /* shared pv */ ###### str = (char*)SSPOPPTR; ###### ptr = SSPOPPTR; ###### if (*(char**)ptr != str) { #ifdef NETWARE PerlMem_free(*(char**)ptr); #else ###### PerlMemShared_free(*(char**)ptr); #endif ###### *(char**)ptr = str; } ###### break; case SAVEt_GENERIC_SVREF: /* generic sv */ 434880 value = (SV*)SSPOPPTR; 434880 ptr = SSPOPPTR; 434880 sv = *(SV**)ptr; 434880 *(SV**)ptr = value; 434880 SvREFCNT_dec(sv); 434880 SvREFCNT_dec(value); ###### break; case SAVEt_SVREF: /* scalar reference */ ###### value = (SV*)SSPOPPTR; ###### ptr = SSPOPPTR; ###### av = Nullav; /* what to refcnt_dec */ restore_sv: 18607067 sv = *(SV**)ptr; DEBUG_S(PerlIO_printf(Perl_debug_log, "restore svref: %p %p:%s -> %p:%s\n", ptr, sv, SvPEEK(sv), value, SvPEEK(value))); 18607067 *(SV**)ptr = value; 18607067 SvREFCNT_dec(sv); 18607067 PL_localizing = 2; 18607067 SvSETMAGIC(value); 18607067 PL_localizing = 0; 18607067 SvREFCNT_dec(value); 18607067 if (av) /* actually an av, hv or gv */ 18607067 SvREFCNT_dec(av); ###### break; case SAVEt_AV: /* array reference */ 3011 av = (AV*)SSPOPPTR; 3011 gv = (GV*)SSPOPPTR; 3011 if (GvAV(gv)) { 3011 AV * const goner = GvAV(gv); /* FIXME - this is a temporary hack until we work out what the correct behaviour for magic should be. */ 3011 sv_unmagic((SV*)goner, PERL_MAGIC_arylen_p); 3011 SvMAGIC_set(av, SvMAGIC(goner)); 3011 SvFLAGS((SV*)av) |= SvMAGICAL(goner); 3011 SvMAGICAL_off(goner); 3011 SvMAGIC_set(goner, NULL); 3011 SvREFCNT_dec(goner); } 3011 GvAV(gv) = av; 3011 if (SvMAGICAL(av)) { 349 PL_localizing = 2; 349 SvSETMAGIC((SV*)av); 349 PL_localizing = 0; } 349 break; case SAVEt_HV: /* hash reference */ 3235 hv = (HV*)SSPOPPTR; 3235 gv = (GV*)SSPOPPTR; 3235 if (GvHV(gv)) { 3235 HV * const goner = GvHV(gv); 3235 SvMAGIC_set(hv, SvMAGIC(goner)); 3235 SvFLAGS(hv) |= SvMAGICAL(goner); 3235 SvMAGICAL_off(goner); 3235 SvMAGIC_set(goner, NULL); 3235 SvREFCNT_dec(goner); } 3235 GvHV(gv) = hv; 3235 if (SvMAGICAL(hv)) { 20 PL_localizing = 2; 20 SvSETMAGIC((SV*)hv); 20 PL_localizing = 0; } 20 break; case SAVEt_INT: /* int reference */ 33728289 ptr = SSPOPPTR; 33728289 *(int*)ptr = (int)SSPOPINT; 33728289 break; case SAVEt_LONG: /* long reference */ ###### ptr = SSPOPPTR; ###### *(long*)ptr = (long)SSPOPLONG; ###### break; case SAVEt_BOOL: /* bool reference */ 47186 ptr = SSPOPPTR; 47186 *(bool*)ptr = (bool)SSPOPBOOL; 47186 break; case SAVEt_I32: /* I32 reference */ 18003427 ptr = SSPOPPTR; 18003427 *(I32*)ptr = (I32)SSPOPINT; 18003427 break; case SAVEt_I16: /* I16 reference */ ###### ptr = SSPOPPTR; ###### *(I16*)ptr = (I16)SSPOPINT; ###### break; case SAVEt_I8: /* I8 reference */ ###### ptr = SSPOPPTR; ###### *(I8*)ptr = (I8)SSPOPINT; ###### break; case SAVEt_IV: /* IV reference */ ###### ptr = SSPOPPTR; ###### *(IV*)ptr = (IV)SSPOPIV; ###### break; case SAVEt_SPTR: /* SV* reference */ 7108756 ptr = SSPOPPTR; 7108756 *(SV**)ptr = (SV*)SSPOPPTR; 7108756 break; case SAVEt_VPTR: /* random* reference */ case SAVEt_PPTR: /* char* reference */ 13703389 ptr = SSPOPPTR; 13703389 *(char**)ptr = (char*)SSPOPPTR; 13703389 break; case SAVEt_HPTR: /* HV* reference */ 39793 ptr = SSPOPPTR; 39793 *(HV**)ptr = (HV*)SSPOPPTR; 39793 break; case SAVEt_APTR: /* AV* reference */ 332 ptr = SSPOPPTR; 332 *(AV**)ptr = (AV*)SSPOPPTR; 332 break; case SAVEt_NSTAB: ###### gv = (GV*)SSPOPPTR; ###### (void)sv_clear((SV*)gv); ###### break; case SAVEt_GP: /* scalar reference */ 30481 ptr = SSPOPPTR; 30481 gv = (GV*)SSPOPPTR; 30481 if (SvPVX_const(gv) && SvLEN(gv) > 0) { 14 Safefree(SvPVX_mutable(gv)); } 30481 SvPV_set(gv, (char *)SSPOPPTR); 30481 SvCUR_set(gv, (STRLEN)SSPOPIV); 30481 SvLEN_set(gv, (STRLEN)SSPOPIV); 30481 gp_free(gv); 30481 GvGP(gv) = (GP*)ptr; 30481 if (GvCVu(gv)) 8186 PL_sub_generation++; /* putting a method back into circulation */ 30481 SvREFCNT_dec(gv); ###### break; case SAVEt_FREESV: 10287689 ptr = SSPOPPTR; 10287689 SvREFCNT_dec((SV*)ptr); ###### break; case SAVEt_MORTALIZESV: 101768 ptr = SSPOPPTR; 101768 sv_2mortal((SV*)ptr); 101768 break; case SAVEt_FREEOP: 508300 ptr = SSPOPPTR; 508300 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */ 508300 op_free((OP*)ptr); 508300 break; case SAVEt_FREEPV: 531274 ptr = SSPOPPTR; 531274 Safefree(ptr); 531274 break; case SAVEt_CLEARSV: 46263879 ptr = (void*)&PL_curpad[SSPOPLONG]; 46263879 sv = *(SV**)ptr; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv), (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon" 46263879 )); /* Can clear pad variable in place? */ 46263879 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { /* * if a my variable that was made readonly is going out of * scope, we want to remove the readonlyness so that it can * go out of scope quietly */ 45840230 if (SvPADMY(sv) && !SvFAKE(sv)) 45726180 SvREADONLY_off(sv); 45840230 if (SvTHINKFIRST(sv)) 10319253 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); 45840230 if (SvMAGICAL(sv)) 1462297 mg_free(sv); 45840230 switch (SvTYPE(sv)) { case SVt_NULL: 1062153 break; case SVt_PVAV: 1062153 av_clear((AV*)sv); 1062153 break; case SVt_PVHV: 102619 hv_clear((HV*)sv); 102619 break; case SVt_PVCV: ###### Perl_croak(aTHX_ "panic: leave_scope pad code"); default: 43952104 SvOK_off(sv); 45840230 break; } 45840230 SvPADSTALE_on(sv); /* mark as no longer live */ } else { /* Someone has a claim on this, so abandon it. */ 423649 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP); 423649 switch (SvTYPE(sv)) { /* Console ourselves with a new value */ 230944 case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break; 48506 case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break; 144199 default: *(SV**)ptr = NEWSV(0,0); break; } 423649 SvREFCNT_dec(sv); /* Cast current value to the winds. */ /* preserve pad nature, but also mark as not live * for any closure capturing */ 423649 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE; } 423649 break; case SAVEt_DELETE: 66793 ptr = SSPOPPTR; 66793 hv = (HV*)ptr; 66793 ptr = SSPOPPTR; 66793 (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD); 66793 SvREFCNT_dec(hv); 66793 Safefree(ptr); 66793 break; case SAVEt_DESTRUCTOR: ###### ptr = SSPOPPTR; ###### (*SSPOPDPTR)(ptr); ###### break; case SAVEt_DESTRUCTOR_X: 192121 ptr = SSPOPPTR; 192121 (*SSPOPDXPTR)(aTHX_ ptr); 192121 break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: 2442924 i = SSPOPINT; 2442924 PL_savestack_ix -= i; /* regexp must have croaked */ 2442924 break; case SAVEt_STACK_POS: /* Position on Perl stack */ 7 i = SSPOPINT; 7 PL_stack_sp = PL_stack_base + i; 7 break; case SAVEt_AELEM: /* array element */ 13 value = (SV*)SSPOPPTR; 13 i = SSPOPINT; 13 av = (AV*)SSPOPPTR; 13 if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */ 2 SvREFCNT_dec(value); 13 ptr = av_fetch(av,i,1); 13 if (ptr) { 13 sv = *(SV**)ptr; 13 if (sv && sv != &PL_sv_undef) { 13 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied)) 3 (void)SvREFCNT_inc(sv); 3 goto restore_sv; } } ###### SvREFCNT_dec(av); ###### SvREFCNT_dec(value); ###### break; case SAVEt_HELEM: /* hash element */ 22374 value = (SV*)SSPOPPTR; 22374 sv = (SV*)SSPOPPTR; 22374 hv = (HV*)SSPOPPTR; 22374 ptr = hv_fetch_ent(hv, sv, 1, 0); 22374 if (ptr) { 22374 const SV * const oval = HeVAL((HE*)ptr); 22374 if (oval && oval != &PL_sv_undef) { 22374 ptr = &HeVAL((HE*)ptr); 22374 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) 3 (void)SvREFCNT_inc(*(SV**)ptr); 22374 SvREFCNT_dec(sv); 22374 av = (AV*)hv; /* what to refcnt_dec */ 22374 goto restore_sv; } } ###### SvREFCNT_dec(hv); ###### SvREFCNT_dec(sv); ###### SvREFCNT_dec(value); ###### break; case SAVEt_OP: 2476609 PL_op = (OP*)SSPOPPTR; 2476609 break; case SAVEt_HINTS: 1589167 if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) { 247 SvREFCNT_dec((SV*)GvHV(PL_hintgv)); 247 GvHV(PL_hintgv) = NULL; } 1589167 *(I32*)&PL_hints = (I32)SSPOPINT; 1589167 if (PL_hints & HINT_LOCALIZE_HH) { 331 SvREFCNT_dec((SV*)GvHV(PL_hintgv)); 331 GvHV(PL_hintgv) = (HV*)SSPOPPTR; } 331 break; case SAVEt_COMPPAD: 20715939 PL_comppad = (PAD*)SSPOPPTR; 20715939 if (PL_comppad) 20498734 PL_curpad = AvARRAY(PL_comppad); else 217205 PL_curpad = Null(SV**); 217205 break; case SAVEt_PADSV: { ###### const PADOFFSET off = (PADOFFSET)SSPOPLONG; ###### ptr = SSPOPPTR; ###### if (ptr) ###### AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR; } ###### break; case SAVEt_SAVESWITCHSTACK: { 289 dSP; 289 AV* t = (AV*)SSPOPPTR; 289 AV* f = (AV*)SSPOPPTR; 289 SWITCHSTACK(t,f); 289 PL_curstackinfo->si_stack = f; } 289 break; case SAVEt_SET_SVFLAGS: { 418928 const U32 val = (U32)SSPOPINT; 418928 const U32 mask = (U32)SSPOPINT; 418928 sv = (SV*)SSPOPPTR; 418928 SvFLAGS(sv) &= ~mask; 418928 SvFLAGS(sv) |= val; } 418928 break; default: ###### Perl_croak(aTHX_ "panic: leave_scope inconsistency"); } } } void Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) ###### { #ifdef DEBUGGING ###### PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); ###### if (CxTYPE(cx) != CXt_SUBST) { ###### PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); ###### PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n", PTR2UV(cx->blk_oldcop)); ###### PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); ###### PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); ###### PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n", PTR2UV(cx->blk_oldpm)); ###### PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); } ###### switch (CxTYPE(cx)) { case CXt_NULL: case CXt_BLOCK: ###### break; case CXt_FORMAT: ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.cv)); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.gv)); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.dfoutgv)); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", (int)cx->blk_sub.hasargs); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.retop)); ###### break; case CXt_SUB: ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.cv)); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", (long)cx->blk_sub.olddepth); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", (int)cx->blk_sub.hasargs); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)cx->blk_sub.lval); ###### PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n", PTR2UV(cx->blk_sub.retop)); ###### break; case CXt_EVAL: ###### PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", (long)cx->blk_eval.old_in_eval); ###### PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", PL_op_name[cx->blk_eval.old_op_type], PL_op_desc[cx->blk_eval.old_op_type]); ###### if (cx->blk_eval.old_namesv) ###### PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", SvPVX_const(cx->blk_eval.old_namesv)); ###### PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n", PTR2UV(cx->blk_eval.old_eval_root)); ###### PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n", PTR2UV(cx->blk_eval.retop)); ###### break; case CXt_LOOP: ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", cx->blk_loop.label); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", (long)cx->blk_loop.resetsp); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.redo_op)); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.next_op)); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.last_op)); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", (long)cx->blk_loop.iterix); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.iterary)); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n", PTR2UV(CxITERVAR(cx))); ###### if (CxITERVAR(cx)) ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.itersave)); ###### PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n", PTR2UV(cx->blk_loop.iterlval)); ###### break; case CXt_SUBST: ###### PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", (long)cx->sb_iters); ###### PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", (long)cx->sb_maxiters); ###### PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", (long)cx->sb_rflags); ###### PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", (long)cx->sb_once); ###### PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", cx->sb_orig); ###### PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n", PTR2UV(cx->sb_dstr)); ###### PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n", PTR2UV(cx->sb_targ)); ###### PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n", PTR2UV(cx->sb_s)); ###### PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n", PTR2UV(cx->sb_m)); ###### PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n", PTR2UV(cx->sb_strend)); ###### PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n", PTR2UV(cx->sb_rxres)); break; } #endif /* DEBUGGING */ } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */