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
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.
12 * For the fashion of Minas Tirith was such that it was built on seven
15 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"]
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
26 #define PERL_IN_SCOPE_C
30 Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
34 PERL_ARGS_ASSERT_STACK_GROW;
37 #ifndef STRESS_REALLOC
38 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
40 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
45 #ifndef STRESS_REALLOC
46 #define GROW(old) ((old) * 3 / 2)
48 #define GROW(old) ((old) + 1)
52 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
57 si->si_stack = newAV();
58 AvREAL_off(si->si_stack);
59 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
60 AvALLOC(si->si_stack)[0] = &PL_sv_undef;
61 AvFILLp(si->si_stack) = 0;
64 si->si_cxmax = cxitems - 1;
66 si->si_type = PERLSI_UNDEF;
67 Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
68 /* Without any kind of initialising PUSHSUBST()
69 * in pp_subst() will read uninitialised heap. */
70 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
78 const IV old_max = cxstack_max;
79 cxstack_max = GROW(cxstack_max);
80 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);
81 /* Without any kind of initialising deep enough recursion
82 * will end up reading uninitialised PERL_CONTEXTs. */
83 PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
84 return cxstack_ix + 1;
91 if (PL_scopestack_ix == PL_scopestack_max) {
92 PL_scopestack_max = GROW(PL_scopestack_max);
93 Renew(PL_scopestack, PL_scopestack_max, I32);
95 Renew(PL_scopestack_name, PL_scopestack_max, const char*);
99 PL_scopestack_name[PL_scopestack_ix] = "unknown";
101 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
109 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
110 LEAVE_SCOPE(oldsave);
114 Perl_markstack_grow(pTHX)
117 const I32 oldmax = PL_markstack_max - PL_markstack;
118 const I32 newmax = GROW(oldmax);
120 Renew(PL_markstack, newmax, I32);
121 PL_markstack_ptr = PL_markstack + oldmax;
122 PL_markstack_max = PL_markstack + newmax;
126 Perl_savestack_grow(pTHX)
129 PL_savestack_max = GROW(PL_savestack_max) + 4;
130 Renew(PL_savestack, PL_savestack_max, ANY);
134 Perl_savestack_grow_cnt(pTHX_ I32 need)
137 PL_savestack_max = PL_savestack_ix + need;
138 Renew(PL_savestack, PL_savestack_max, ANY);
144 Perl_tmps_grow(pTHX_ I32 n)
147 #ifndef STRESS_REALLOC
149 n = (PL_tmps_max < 512) ? 128 : 512;
151 PL_tmps_max = PL_tmps_ix + n + 1;
152 Renew(PL_tmps_stack, PL_tmps_max, SV*);
160 /* XXX should tmps_floor live in cxstack? */
161 const I32 myfloor = PL_tmps_floor;
162 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
163 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
165 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
167 if (sv && sv != &PL_sv_undef) {
169 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
175 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
181 PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
184 sv = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0));
186 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) {
187 if (SvGMAGICAL(osv)) {
188 SvFLAGS(osv) |= (SvFLAGS(osv) &
189 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
191 if (!(flags & SAVEf_KEEPOLDELEM))
192 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
199 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
210 Perl_save_scalar(pTHX_ GV *gv)
213 SV ** const sptr = &GvSVn(gv);
215 PERL_ARGS_ASSERT_SAVE_SCALAR;
217 if (SvGMAGICAL(*sptr)) {
222 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
223 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
226 /* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
227 * restore a global SV to its prior contents, freeing new value. */
229 Perl_save_generic_svref(pTHX_ SV **sptr)
233 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
235 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
238 /* Like save_pptr(), but also Safefree()s the new value if it is different
239 * from the old one. Can be used to restore a global char* to its prior
240 * contents, freeing new value. */
242 Perl_save_generic_pvref(pTHX_ char **str)
246 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
248 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
251 /* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
252 * Can be used to restore a shared global char* to its prior
253 * contents, freeing new value. */
255 Perl_save_shared_pvref(pTHX_ char **str)
259 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
261 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
264 /* set the SvFLAGS specified by mask to the values in val */
267 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
272 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
277 SS_ADD_UV(SAVEt_SET_SVFLAGS);
282 Perl_save_gp(pTHX_ GV *gv, I32 empty)
286 PERL_ARGS_ASSERT_SAVE_GP;
288 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
291 GP *gp = Perl_newGP(aTHX_ gv);
292 HV * const stash = GvSTASH(gv);
293 bool isa_changed = 0;
295 if (stash && HvENAME(stash)) {
296 if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3))
299 /* taking a method out of circulation ("local")*/
300 mro_method_changed_in(stash);
302 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
304 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
307 if (isa_changed) mro_isa_changed_in(stash);
316 Perl_save_ary(pTHX_ GV *gv)
319 AV * const oav = GvAVn(gv);
322 PERL_ARGS_ASSERT_SAVE_ARY;
324 if (!AvREAL(oav) && AvREIFY(oav))
326 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
331 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
336 Perl_save_hash(pTHX_ GV *gv)
341 PERL_ARGS_ASSERT_SAVE_HASH;
344 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
350 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
355 Perl_save_item(pTHX_ SV *item)
358 SV * const sv = newSVsv(item);
360 PERL_ARGS_ASSERT_SAVE_ITEM;
362 save_pushptrptr(item, /* remember the pointer */
363 sv, /* remember the value */
368 Perl_save_bool(pTHX_ bool *boolp)
373 PERL_ARGS_ASSERT_SAVE_BOOL;
376 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
381 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
393 Perl_save_int(pTHX_ int *intp)
397 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
401 PERL_ARGS_ASSERT_SAVE_INT;
403 if ((int)(type >> SAVE_TIGHT_SHIFT) != i) {
414 Perl_save_I8(pTHX_ I8 *bytep)
419 PERL_ARGS_ASSERT_SAVE_I8;
422 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
427 Perl_save_I16(pTHX_ I16 *intp)
432 PERL_ARGS_ASSERT_SAVE_I16;
435 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
440 Perl_save_I32(pTHX_ I32 *intp)
444 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
448 PERL_ARGS_ASSERT_SAVE_I32;
450 if ((I32)(type >> SAVE_TIGHT_SHIFT) != i) {
460 /* Cannot use save_sptr() to store a char* since the SV** cast will
461 * force word-alignment and we'll miss the pointer.
464 Perl_save_pptr(pTHX_ char **pptr)
468 PERL_ARGS_ASSERT_SAVE_PPTR;
470 save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
474 Perl_save_vptr(pTHX_ void *ptr)
478 PERL_ARGS_ASSERT_SAVE_VPTR;
480 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
484 Perl_save_sptr(pTHX_ SV **sptr)
488 PERL_ARGS_ASSERT_SAVE_SPTR;
490 save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
494 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
499 ASSERT_CURPAD_ACTIVE("save_padsv");
500 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
501 SS_ADD_PTR(PL_comppad);
503 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
508 Perl_save_hptr(pTHX_ HV **hptr)
512 PERL_ARGS_ASSERT_SAVE_HPTR;
514 save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
518 Perl_save_aptr(pTHX_ AV **aptr)
522 PERL_ARGS_ASSERT_SAVE_APTR;
524 save_pushptrptr(*aptr, aptr, SAVEt_APTR);
528 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
538 Perl_save_clearsv(pTHX_ SV **svp)
541 const UV offset = svp - PL_curpad;
542 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
544 PERL_ARGS_ASSERT_SAVE_CLEARSV;
546 ASSERT_CURPAD_ACTIVE("save_clearsv");
547 SvPADSTALE_off(*svp); /* mark lexical as active */
548 if ((offset_shifted >> SAVE_TIGHT_SHIFT) != offset) {
549 Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
550 offset, svp, PL_curpad);
555 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
561 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
565 PERL_ARGS_ASSERT_SAVE_DELETE;
567 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
571 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
577 PERL_ARGS_ASSERT_SAVE_HDELETE;
579 key = SvPV_const(keysv, len);
580 klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
581 SvREFCNT_inc_simple_void_NN(hv);
582 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
586 Perl_save_adelete(pTHX_ AV *av, I32 key)
590 PERL_ARGS_ASSERT_SAVE_ADELETE;
592 SvREFCNT_inc_void(av);
593 save_pushi32ptr(key, av, SAVEt_ADELETE);
597 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
602 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
606 SS_ADD_UV(SAVEt_DESTRUCTOR);
611 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
618 SS_ADD_UV(SAVEt_DESTRUCTOR_X);
623 Perl_save_hints(pTHX)
626 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
627 if (PL_hints & HINT_LOCALIZE_HH) {
628 HV *oldhh = GvHV(PL_hintgv);
629 save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
630 GvHV(PL_hintgv) = NULL; /* in case copying dies */
631 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
633 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
638 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
650 Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
655 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
658 save_pushptri32ptr(SvREFCNT_inc_simple(av), idx, SvREFCNT_inc(*sptr),
660 /* The array needs to hold a reference count on its new element, so it
662 if (!AvREAL(av) && AvREIFY(av))
664 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
665 if (flags & SAVEf_KEEPOLDELEM)
668 /* If we're localizing a tied array element, this new sv
669 * won't actually be stored in the array - so it won't get
670 * reaped when the localize ends. Ensure it gets reaped by
671 * mortifying it instead. DAPM */
672 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
677 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
682 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
687 SS_ADD_PTR(SvREFCNT_inc_simple(hv));
688 SS_ADD_PTR(newSVsv(key));
689 SS_ADD_PTR(SvREFCNT_inc(*sptr));
690 SS_ADD_UV(SAVEt_HELEM);
693 save_scalar_at(sptr, flags);
694 if (flags & SAVEf_KEEPOLDELEM)
697 /* If we're localizing a tied hash element, this new sv
698 * won't actually be stored in the hash - so it won't get
699 * reaped when the localize ends. Ensure it gets reaped by
700 * mortifying it instead. DAPM */
701 if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
706 Perl_save_svref(pTHX_ SV **sptr)
710 PERL_ARGS_ASSERT_SAVE_SVREF;
713 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
714 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
718 Perl_save_alloc(pTHX_ I32 size, I32 pad)
721 const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
722 - (char*)PL_savestack);
723 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
724 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
726 if ((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)
728 "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")",
729 elems, (IV)size, (IV)pad);
733 PL_savestack_ix += elems;
734 SSPUSHUV(SAVEt_ALLOC | elems_shifted);
740 #define ARG0_SV MUTABLE_SV(arg0.any_ptr)
741 #define ARG0_AV MUTABLE_AV(arg0.any_ptr)
742 #define ARG0_HV MUTABLE_HV(arg0.any_ptr)
743 #define ARG0_PTR arg0.any_ptr
744 #define ARG0_PV (char*)(arg0.any_ptr)
745 #define ARG0_PVP (char**)(arg0.any_ptr)
746 #define ARG0_I32 (arg0.any_i32)
748 #define ARG1_SV MUTABLE_SV(arg1.any_ptr)
749 #define ARG1_AV MUTABLE_AV(arg1.any_ptr)
750 #define ARG1_GV MUTABLE_GV(arg1.any_ptr)
751 #define ARG1_SVP (SV**)(arg1.any_ptr)
752 #define ARG1_PVP (char**)(arg1.any_ptr)
753 #define ARG1_PTR arg1.any_ptr
754 #define ARG1_PV (char*)(arg1.any_ptr)
755 #define ARG1_I32 (arg1.any_i32)
757 #define ARG2_SV MUTABLE_SV(arg2.any_ptr)
758 #define ARG2_AV MUTABLE_AV(arg2.any_ptr)
759 #define ARG2_HV MUTABLE_HV(arg2.any_ptr)
760 #define ARG2_GV MUTABLE_GV(arg2.any_ptr)
761 #define ARG2_PV (char*)(arg2.any_ptr)
764 Perl_leave_scope(pTHX_ I32 base)
768 /* Localise the effects of the TAINT_NOT inside the loop. */
769 bool was = TAINT_get;
771 ANY arg0, arg1, arg2;
773 /* these initialisations are logically unnecessary, but they shut up
774 * spurious 'may be used uninitialized' compiler warnings */
780 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
781 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
782 (long)PL_savestack_ix, (long)base));
783 while (PL_savestack_ix > base) {
793 I32 ix = PL_savestack_ix - 1;
794 ANY *p = &PL_savestack[ix];
796 type = (U8)uv & SAVE_MASK;
797 if (type > SAVEt_ARG0_MAX) {
800 if (type > SAVEt_ARG1_MAX) {
802 if (type > SAVEt_ARG2_MAX) {
808 PL_savestack_ix = ix;
812 case SAVEt_ITEM: /* normal string */
813 sv_replace(ARG1_SV, ARG0_SV);
814 if (SvSMAGICAL(ARG1_SV)) {
821 /* This would be a mathom, but Perl_save_svref() calls a static
822 function, S_save_scalar_at(), so has to stay in this file. */
823 case SAVEt_SVREF: /* scalar reference */
825 refsv = NULL; /* what to refcnt_dec */
828 case SAVEt_SV: /* scalar reference */
829 svp = &GvSV(ARG1_GV);
830 refsv = ARG1_SV; /* what to refcnt_dec */
833 SV * const sv = *svp;
836 if (SvSMAGICAL(ARG0_SV)) {
841 SvREFCNT_dec_NN(ARG0_SV);
845 case SAVEt_GENERIC_PVREF: /* generic pv */
846 if (*ARG0_PVP != ARG1_PV) {
851 case SAVEt_SHARED_PVREF: /* shared pv */
852 if (*ARG1_PVP != ARG0_PV) {
854 PerlMem_free(*ARG1_PVP);
856 PerlMemShared_free(*ARG1_PVP);
861 case SAVEt_GVSV: /* scalar slot in GV */
862 svp = &GvSV(ARG1_GV);
864 case SAVEt_GENERIC_SVREF: /* generic sv */
868 SV * const sv = *svp;
871 SvREFCNT_dec(ARG0_SV);
874 case SAVEt_GVSLOT: /* any slot in GV */
876 HV *const hv = GvSTASH(ARG2_GV);
878 if (hv && HvENAME(hv) && (
879 (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
880 || (*svp && SvTYPE(*svp) == SVt_PVCV)
883 if ((char *)svp < (char *)GvGP(ARG2_GV)
884 || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
885 || GvREFCNT(ARG2_GV) > 1)
887 else mro_method_changed_in(hv);
891 case SAVEt_AV: /* array reference */
892 SvREFCNT_dec(GvAV(ARG1_GV));
893 GvAV(ARG1_GV) = ARG0_AV;
894 if (SvSMAGICAL(ARG0_SV)) {
899 SvREFCNT_dec_NN(ARG1_GV);
901 case SAVEt_HV: /* hash reference */
902 SvREFCNT_dec(GvHV(ARG1_GV));
903 GvHV(ARG1_GV) = ARG0_HV;
904 if (SvSMAGICAL(ARG0_SV)) {
909 SvREFCNT_dec_NN(ARG1_GV);
911 case SAVEt_INT_SMALL:
912 *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
914 case SAVEt_INT: /* int reference */
915 *(int*)ARG0_PTR = (int)ARG1_I32;
917 case SAVEt_BOOL: /* bool reference */
918 *(bool*)ARG0_PTR = cBOOL(uv >> 8);
919 #ifdef NO_TAINT_SUPPORT
920 PERL_UNUSED_VAR(was);
922 if (ARG0_PTR == &(TAINT_get)) {
923 /* If we don't update <was>, to reflect what was saved on the
924 * stack for PL_tainted, then we will overwrite this attempt to
925 * restore it when we exit this routine. Note that this won't
926 * work if this value was saved in a wider-than necessary type,
928 was = *(bool*)ARG0_PTR;
932 case SAVEt_I32_SMALL:
933 *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
935 case SAVEt_I32: /* I32 reference */
936 #ifdef PERL_DEBUG_READONLY_OPS
937 if (*(I32*)ARG0_PTR != ARG1_I32)
939 *(I32*)ARG0_PTR = ARG1_I32;
941 case SAVEt_SPTR: /* SV* reference */
942 *(SV**)(ARG0_PTR)= ARG1_SV;
944 case SAVEt_VPTR: /* random* reference */
945 case SAVEt_PPTR: /* char* reference */
948 case SAVEt_HPTR: /* HV* reference */
949 *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
951 case SAVEt_APTR: /* AV* reference */
952 *(AV**)ARG0_PTR = ARG1_AV;
954 case SAVEt_GP: /* scalar reference */
957 /* possibly taking a method out of circulation */
958 const bool had_method = !!GvCVu(ARG1_GV);
960 GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
961 if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
962 if ( GvNAMELEN(ARG1_GV) == 3
963 && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
965 mro_isa_changed_in(hv);
966 else if (had_method || GvCVu(ARG1_GV))
967 /* putting a method back into circulation ("local")*/
968 gv_method_changed(ARG1_GV);
970 SvREFCNT_dec_NN(ARG1_GV);
974 SvREFCNT_dec(ARG0_SV);
976 case SAVEt_FREECOPHH:
977 cophh_free((COPHH *)ARG0_PTR);
979 case SAVEt_MORTALIZESV:
983 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
984 op_free((OP*)ARG0_PTR);
995 case SAVEt_CLEARPADRANGE:
996 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
997 svp = &PL_curpad[uv >>
998 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1001 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1004 for (; i; i--, svp--) {
1007 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1008 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
1009 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1010 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1011 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1014 /* Can clear pad variable in place? */
1015 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
1017 * if a my variable that was made readonly is going out of
1018 * scope, we want to remove the readonlyness so that it can
1019 * go out of scope quietly
1021 if (SvPADMY(sv) && !SvFAKE(sv))
1024 if (SvTHINKFIRST(sv))
1025 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1027 if (SvTYPE(sv) == SVt_PVHV)
1028 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1031 sv_unmagic(sv, PERL_MAGIC_backref);
1032 if (SvTYPE(sv) != SVt_PVCV)
1036 switch (SvTYPE(sv)) {
1040 av_clear(MUTABLE_AV(sv));
1043 hv_clear(MUTABLE_HV(sv));
1047 HEK * const hek = CvNAME_HEK((CV *)sv);
1051 CvNAME_HEK_set(sv, hek);
1058 SvPADSTALE_on(sv); /* mark as no longer live */
1060 else { /* Someone has a claim on this, so abandon it. */
1061 assert( SvFLAGS(sv) & SVs_PADMY);
1062 assert(!(SvFLAGS(sv) & SVs_PADTMP));
1063 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
1064 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
1065 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
1069 *svp = newSV_type(SVt_PVCV);
1072 assert(CvNAMED(sv));
1073 CvNAME_HEK_set(*svp,
1074 share_hek_hek(CvNAME_HEK((CV *)sv)));
1077 default: *svp = newSV(0); break;
1079 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1080 /* preserve pad nature, but also mark as not live
1081 * for any closure capturing */
1082 SvFLAGS(*svp) |= (SVs_PADMY|SVs_PADSTALE);
1088 (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
1089 SvREFCNT_dec(ARG0_HV);
1090 Safefree(arg2.any_ptr);
1093 (void)av_delete(ARG0_AV, ARG1_I32, G_DISCARD);
1094 SvREFCNT_dec(ARG0_AV);
1096 case SAVEt_DESTRUCTOR_X:
1097 (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
1099 case SAVEt_REGCONTEXT:
1100 /* regexp must have croaked */
1102 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1104 case SAVEt_STACK_POS: /* Position on Perl stack */
1105 PL_stack_sp = PL_stack_base + arg0.any_i32;
1107 case SAVEt_STACK_CXPOS: /* blk_oldsp on context stack */
1108 cxstack[ARG0_I32].blk_oldsp = ARG1_I32;
1110 case SAVEt_AELEM: /* array element */
1111 svp = av_fetch(ARG2_AV, ARG1_I32, 1);
1112 if (!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV)) /* undo reify guard */
1113 SvREFCNT_dec(ARG0_SV);
1115 SV * const sv = *svp;
1116 if (sv && sv != &PL_sv_undef) {
1117 if (SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied))
1118 SvREFCNT_inc_void_NN(sv);
1123 SvREFCNT_dec(ARG2_AV);
1124 SvREFCNT_dec(ARG0_SV);
1126 case SAVEt_HELEM: /* hash element */
1128 HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
1129 SvREFCNT_dec(ARG1_SV);
1131 const SV * const oval = HeVAL(he);
1132 if (oval && oval != &PL_sv_undef) {
1134 if (SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied))
1135 SvREFCNT_inc_void(*svp);
1136 refsv = ARG2_SV; /* what to refcnt_dec */
1140 SvREFCNT_dec(ARG2_HV);
1141 SvREFCNT_dec(ARG0_SV);
1145 PL_op = (OP*)ARG0_PTR;
1148 if ((PL_hints & HINT_LOCALIZE_HH)) {
1149 while (GvHV(PL_hintgv)) {
1150 HV *hv = GvHV(PL_hintgv);
1151 GvHV(PL_hintgv) = NULL;
1152 SvREFCNT_dec(MUTABLE_SV(hv));
1155 cophh_free(CopHINTHASH_get(&PL_compiling));
1156 CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
1157 *(I32*)&PL_hints = ARG1_I32;
1158 if (PL_hints & HINT_LOCALIZE_HH) {
1159 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1160 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
1162 if (!GvHV(PL_hintgv)) {
1163 /* Need to add a new one manually, else rv2hv can
1164 add one via GvHVn and it won't have the magic set. */
1165 HV *const hv = newHV();
1166 hv_magic(hv, NULL, PERL_MAGIC_hints);
1167 GvHV(PL_hintgv) = hv;
1169 assert(GvHV(PL_hintgv));
1172 PL_comppad = (PAD*)ARG0_PTR;
1174 PL_curpad = AvARRAY(PL_comppad);
1178 case SAVEt_PADSV_AND_MORTALIZE:
1182 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
1183 /* This mortalizing used to be done by POPLOOP() via itersave.
1184 But as we have all the information here, we can do it here,
1185 save even having to have itersave in the struct. */
1190 case SAVEt_SAVESWITCHSTACK:
1193 SWITCHSTACK(ARG0_AV, ARG1_AV);
1194 PL_curstackinfo->si_stack = ARG1_AV;
1197 case SAVEt_SET_SVFLAGS:
1198 SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
1199 SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
1202 /* These are only saved in mathoms.c */
1204 (void)sv_clear(ARG0_SV);
1206 case SAVEt_LONG: /* long reference */
1207 *(long*)ARG0_PTR = arg1.any_long;
1209 case SAVEt_IV: /* IV reference */
1210 *(IV*)ARG0_PTR = arg1.any_iv;
1213 case SAVEt_I16: /* I16 reference */
1214 *(I16*)ARG0_PTR = (I16)(uv >> 8);
1216 case SAVEt_I8: /* I8 reference */
1217 *(I8*)ARG0_PTR = (I8)(uv >> 8);
1219 case SAVEt_DESTRUCTOR:
1220 (*arg1.any_dptr)(ARG0_PTR);
1222 case SAVEt_COMPILE_WARNINGS:
1223 if (!specialWARN(PL_compiling.cop_warnings))
1224 PerlMemShared_free(PL_compiling.cop_warnings);
1226 PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
1229 parser_free((yy_parser *) ARG0_PTR);
1231 case SAVEt_READONLY_OFF:
1232 SvREADONLY_off(ARG0_SV);
1235 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
1243 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1247 PERL_ARGS_ASSERT_CX_DUMP;
1250 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1251 if (CxTYPE(cx) != CXt_SUBST) {
1252 const char *gimme_text;
1253 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1254 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1255 PTR2UV(cx->blk_oldcop));
1256 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1257 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1258 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1259 PTR2UV(cx->blk_oldpm));
1260 switch (cx->blk_gimme) {
1262 gimme_text = "VOID";
1265 gimme_text = "SCALAR";
1268 gimme_text = "LIST";
1271 gimme_text = "UNKNOWN";
1274 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1276 switch (CxTYPE(cx)) {
1281 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1282 PTR2UV(cx->blk_format.cv));
1283 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1284 PTR2UV(cx->blk_format.gv));
1285 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1286 PTR2UV(cx->blk_format.dfoutgv));
1287 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1288 (int)CxHASARGS(cx));
1289 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1290 PTR2UV(cx->blk_format.retop));
1293 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1294 PTR2UV(cx->blk_sub.cv));
1295 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1296 (long)cx->blk_sub.olddepth);
1297 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1298 (int)CxHASARGS(cx));
1299 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1300 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1301 PTR2UV(cx->blk_sub.retop));
1304 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1305 (long)CxOLD_IN_EVAL(cx));
1306 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1307 PL_op_name[CxOLD_OP_TYPE(cx)],
1308 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1309 if (cx->blk_eval.old_namesv)
1310 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1311 SvPVX_const(cx->blk_eval.old_namesv));
1312 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1313 PTR2UV(cx->blk_eval.old_eval_root));
1314 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1315 PTR2UV(cx->blk_eval.retop));
1318 case CXt_LOOP_LAZYIV:
1319 case CXt_LOOP_LAZYSV:
1321 case CXt_LOOP_PLAIN:
1322 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1323 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1324 (long)cx->blk_loop.resetsp);
1325 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1326 PTR2UV(cx->blk_loop.my_op));
1327 /* XXX: not accurate for LAZYSV/IV */
1328 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1329 PTR2UV(cx->blk_loop.state_u.ary.ary));
1330 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1331 (long)cx->blk_loop.state_u.ary.ix);
1332 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1333 PTR2UV(CxITERVAR(cx)));
1337 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1338 (long)cx->sb_iters);
1339 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1340 (long)cx->sb_maxiters);
1341 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1342 (long)cx->sb_rflags);
1343 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1345 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1347 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1348 PTR2UV(cx->sb_dstr));
1349 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1350 PTR2UV(cx->sb_targ));
1351 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1353 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1355 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1356 PTR2UV(cx->sb_strend));
1357 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1358 PTR2UV(cx->sb_rxres));
1362 PERL_UNUSED_CONTEXT;
1363 PERL_UNUSED_ARG(cx);
1364 #endif /* DEBUGGING */
1369 * c-indentation-style: bsd
1371 * indent-tabs-mode: nil
1374 * ex: set ts=8 sts=4 sw=4 et: