This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate cx->blk_loop.resetsp
[perl5.git] / scope.c
CommitLineData
a0d0e21e 1/* scope.c
79072805 2 *
1129b882
NC
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
79072805
LW
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 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
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"]
79072805
LW
16 */
17
ddfa107c 18/* This file contains functions to manipulate several of Perl's stacks;
166f8a29
DM
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
79072805 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_SCOPE_C
79072805
LW
27#include "perl.h"
28
a0d0e21e 29SV**
fc16c392 30Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
a0d0e21e 31{
402d079e
DM
32 SSize_t extra;
33 SSize_t current = (p - PL_stack_base);
34
7918f24d
NC
35 PERL_ARGS_ASSERT_STACK_GROW;
36
402d079e 37 if (UNLIKELY(n < 0))
6768377c
DM
38 Perl_croak(aTHX_
39 "panic: stack_grow() negative count (%"IVdf")", (IV)n);
40
3280af22 41 PL_stack_sp = sp;
402d079e
DM
42 extra =
43#ifdef STRESS_REALLOC
44 1;
2ce36478 45#else
402d079e 46 128;
2ce36478 47#endif
402d079e
DM
48 /* If the total might wrap, panic instead. This is really testing
49 * that (current + n + extra < SSize_t_MAX), but done in a way that
50 * can't wrap */
51 if (UNLIKELY( current > SSize_t_MAX - extra
52 || current + extra > SSize_t_MAX - n
53 ))
54 /* diag_listed_as: Out of memory during %s extend */
55 Perl_croak(aTHX_ "Out of memory during stack extend");
56
57 av_extend(PL_curstack, current + n + extra);
3280af22 58 return PL_stack_sp;
a0d0e21e
LW
59}
60
2ce36478
SM
61#ifndef STRESS_REALLOC
62#define GROW(old) ((old) * 3 / 2)
63#else
64#define GROW(old) ((old) + 1)
65#endif
66
e336de0d 67PERL_SI *
864dbfa3 68Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
e336de0d
GS
69{
70 PERL_SI *si;
a02a5408 71 Newx(si, 1, PERL_SI);
e336de0d
GS
72 si->si_stack = newAV();
73 AvREAL_off(si->si_stack);
74 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
3280af22 75 AvALLOC(si->si_stack)[0] = &PL_sv_undef;
e336de0d
GS
76 AvFILLp(si->si_stack) = 0;
77 si->si_prev = 0;
78 si->si_next = 0;
79 si->si_cxmax = cxitems - 1;
80 si->si_cxix = -1;
e788e7d3 81 si->si_type = PERLSI_UNDEF;
a02a5408 82 Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
9965345d
JH
83 /* Without any kind of initialising PUSHSUBST()
84 * in pp_subst() will read uninitialised heap. */
7e337ee0 85 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
e336de0d
GS
86 return si;
87}
88
79072805 89I32
864dbfa3 90Perl_cxinc(pTHX)
79072805 91{
a3b680e6 92 const IV old_max = cxstack_max;
2ce36478 93 cxstack_max = GROW(cxstack_max);
401a9b14 94 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);
9965345d
JH
95 /* Without any kind of initialising deep enough recursion
96 * will end up reading uninitialised PERL_CONTEXTs. */
109bf713 97 PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
79072805
LW
98 return cxstack_ix + 1;
99}
100
79072805 101void
864dbfa3 102Perl_push_scope(pTHX)
79072805 103{
5d9574c1 104 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) {
3280af22
NIS
105 PL_scopestack_max = GROW(PL_scopestack_max);
106 Renew(PL_scopestack, PL_scopestack_max, I32);
d343c3ef
GG
107#ifdef DEBUGGING
108 Renew(PL_scopestack_name, PL_scopestack_max, const char*);
520bb150 109#endif
79072805 110 }
d343c3ef
GG
111#ifdef DEBUGGING
112 PL_scopestack_name[PL_scopestack_ix] = "unknown";
113#endif
3280af22 114 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
79072805
LW
115
116}
117
118void
864dbfa3 119Perl_pop_scope(pTHX)
79072805 120{
35a4481c 121 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
8990e307 122 LEAVE_SCOPE(oldsave);
79072805
LW
123}
124
ba5248fc 125I32 *
864dbfa3 126Perl_markstack_grow(pTHX)
a0d0e21e 127{
35a4481c
AL
128 const I32 oldmax = PL_markstack_max - PL_markstack;
129 const I32 newmax = GROW(oldmax);
a0d0e21e 130
3280af22 131 Renew(PL_markstack, newmax, I32);
3280af22 132 PL_markstack_max = PL_markstack + newmax;
ba5248fc 133 PL_markstack_ptr = PL_markstack + oldmax;
30773234
DM
134 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
135 "MARK grow %p %"IVdf" by %"IVdf"\n",
136 PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax)));
ba5248fc 137 return PL_markstack_ptr;
a0d0e21e
LW
138}
139
140void
864dbfa3 141Perl_savestack_grow(pTHX)
79072805 142{
8aacddc1 143 PL_savestack_max = GROW(PL_savestack_max) + 4;
3280af22 144 Renew(PL_savestack, PL_savestack_max, ANY);
79072805
LW
145}
146
4b3c1a47
AE
147void
148Perl_savestack_grow_cnt(pTHX_ I32 need)
149{
150 PL_savestack_max = PL_savestack_ix + need;
151 Renew(PL_savestack, PL_savestack_max, ANY);
152}
153
2ce36478
SM
154#undef GROW
155
a953aca5
DD
156/* The original function was called Perl_tmps_grow and was removed from public
157 API, Perl_tmps_grow_p is the replacement and it used in public macros but
158 isn't public itself.
159
160 Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by,
161 where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max
162 Upon return, PL_tmps_stack[ix] will be a valid address. For machine code
163 optimization and register usage reasons, the proposed ix passed into
164 tmps_grow is returned to the caller which the caller can then use to write
165 an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in
166 pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of
167 tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller
168 must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is
169 appropriate. The assignment to PL_temps_ix can happen before or after
170 tmps_grow call since tmps_grow doesn't look at PL_tmps_ix.
171 */
172
173SSize_t
174Perl_tmps_grow_p(pTHX_ SSize_t ix)
677b06e3 175{
a953aca5 176 SSize_t extend_to = ix;
677b06e3 177#ifndef STRESS_REALLOC
a953aca5
DD
178 if (ix - PL_tmps_max < 128)
179 extend_to += (PL_tmps_max < 512) ? 128 : 512;
677b06e3 180#endif
a953aca5 181 PL_tmps_max = extend_to + 1;
677b06e3 182 Renew(PL_tmps_stack, PL_tmps_max, SV*);
a953aca5 183 return ix;
677b06e3
GS
184}
185
186
187void
864dbfa3 188Perl_free_tmps(pTHX)
79072805
LW
189{
190 /* XXX should tmps_floor live in cxstack? */
e8eb279c 191 const SSize_t myfloor = PL_tmps_floor;
3280af22 192 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
22ade07d 193 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
72581b5b
VP
194#ifdef PERL_POISON
195 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
22ade07d 196#endif
5d9574c1 197 if (LIKELY(sv && sv != &PL_sv_undef)) {
463ee0b2 198 SvTEMP_off(sv);
4a9a56a7 199 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
463ee0b2 200 }
79072805
LW
201 }
202}
203
76e3520e 204STATIC SV *
af7df257 205S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
79072805 206{
75d34a09 207 SV * osv;
eb578fdb 208 SV *sv;
79072805 209
7918f24d
NC
210 PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
211
75d34a09 212 osv = *sptr;
3c84a230
DM
213 if (flags & SAVEf_KEEPOLDELEM)
214 sv = osv;
215 else {
216 sv = (*sptr = newSV(0));
217 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv))
218 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
79072805 219 }
75d34a09 220
79072805
LW
221 return sv;
222}
223
dfcd3de5
NC
224void
225Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
e22024d3 226{
a3444cc5
DM
227 dSS_ADD;
228 SS_ADD_PTR(ptr1);
229 SS_ADD_PTR(ptr2);
230 SS_ADD_UV(type);
231 SS_ADD_END(3);
e22024d3
NC
232}
233
7a4c00b4 234SV *
864dbfa3 235Perl_save_scalar(pTHX_ GV *gv)
7a4c00b4 236{
13c59d41 237 SV ** const sptr = &GvSVn(gv);
7918f24d
NC
238
239 PERL_ARGS_ASSERT_SAVE_SCALAR;
240
13c59d41 241 if (UNLIKELY(SvGMAGICAL(*sptr))) {
b492a59e 242 PL_localizing = 1;
13c59d41 243 (void)mg_get(*sptr);
b492a59e
DM
244 PL_localizing = 0;
245 }
13c59d41
MH
246 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
247 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
7a4c00b4
PP
248}
249
f4dd75d9 250/* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
b9d12d37
GS
251 * restore a global SV to its prior contents, freeing new value. */
252void
864dbfa3 253Perl_save_generic_svref(pTHX_ SV **sptr)
b9d12d37 254{
7918f24d
NC
255 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
256
e22024d3 257 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
b9d12d37
GS
258}
259
f4dd75d9
GS
260/* Like save_pptr(), but also Safefree()s the new value if it is different
261 * from the old one. Can be used to restore a global char* to its prior
262 * contents, freeing new value. */
263void
264Perl_save_generic_pvref(pTHX_ char **str)
265{
7918f24d
NC
266 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
267
e22024d3 268 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
f4dd75d9
GS
269}
270
05ec9bb3
NIS
271/* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
272 * Can be used to restore a shared global char* to its prior
273 * contents, freeing new value. */
274void
275Perl_save_shared_pvref(pTHX_ char **str)
276{
7918f24d
NC
277 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
278
e22024d3 279 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
05ec9bb3
NIS
280}
281
14f338dc
DM
282/* set the SvFLAGS specified by mask to the values in val */
283
284void
285Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
286{
a3444cc5 287 dSS_ADD;
7918f24d
NC
288
289 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
290
a3444cc5
DM
291 SS_ADD_PTR(sv);
292 SS_ADD_INT(mask);
293 SS_ADD_INT(val);
294 SS_ADD_UV(SAVEt_SET_SVFLAGS);
295 SS_ADD_END(4);
14f338dc
DM
296}
297
364bbfa4
TC
298/*
299=for apidoc save_gp
300
301Saves the current GP of gv on the save stack to be restored on scope exit.
302
303If empty is true, replace the GP with a new GP.
304
305If empty is false, mark gv with GVf_INTRO so the next reference
306assigned is localized, which is how C< local *foo = $someref; > works.
307
308=cut
309*/
310
79072805 311void
864dbfa3 312Perl_save_gp(pTHX_ GV *gv, I32 empty)
79072805 313{
7918f24d
NC
314 PERL_ARGS_ASSERT_SAVE_GP;
315
10507e11 316 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
79072805 317
5f05dabc 318 if (empty) {
12816592 319 GP *gp = Perl_newGP(aTHX_ gv);
959f7ad7 320 HV * const stash = GvSTASH(gv);
3d460042
FC
321 bool isa_changed = 0;
322
323 if (stash && HvENAME(stash)) {
324 if (GvNAMELEN(gv) == 3 && strnEQ(GvNAME(gv), "ISA", 3))
325 isa_changed = TRUE;
326 else if (GvCVu(gv))
327 /* taking a method out of circulation ("local")*/
328 mro_method_changed_in(stash);
329 }
146174a9
CB
330 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
331 gp->gp_io = newIO();
332 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
333 }
c43ae56f 334 GvGP_set(gv,gp);
3d460042 335 if (isa_changed) mro_isa_changed_in(stash);
5f05dabc
PP
336 }
337 else {
44a8e56a 338 gp_ref(GvGP(gv));
5f05dabc
PP
339 GvINTRO_on(gv);
340 }
79072805 341}
79072805 342
79072805 343AV *
864dbfa3 344Perl_save_ary(pTHX_ GV *gv)
79072805 345{
901017d6 346 AV * const oav = GvAVn(gv);
67a38de0 347 AV *av;
fb73857a 348
7918f24d
NC
349 PERL_ARGS_ASSERT_SAVE_ARY;
350
5d9574c1 351 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav)))
67a38de0 352 av_reify(oav);
01433346 353 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
79072805 354
4608196e 355 GvAV(gv) = NULL;
fb73857a 356 av = GvAVn(gv);
5d9574c1 357 if (UNLIKELY(SvMAGIC(oav)))
9711599e 358 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
fb73857a 359 return av;
79072805
LW
360}
361
362HV *
864dbfa3 363Perl_save_hash(pTHX_ GV *gv)
79072805 364{
fb73857a
PP
365 HV *ohv, *hv;
366
7918f24d
NC
367 PERL_ARGS_ASSERT_SAVE_HASH;
368
01433346
FC
369 save_pushptrptr(
370 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
371 );
79072805 372
4608196e 373 GvHV(gv) = NULL;
fb73857a 374 hv = GvHVn(gv);
5d9574c1 375 if (UNLIKELY(SvMAGIC(ohv)))
9711599e 376 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
fb73857a 377 return hv;
79072805
LW
378}
379
380void
5aaab254 381Perl_save_item(pTHX_ SV *item)
79072805 382{
eb578fdb 383 SV * const sv = newSVsv(item);
79072805 384
7918f24d
NC
385 PERL_ARGS_ASSERT_SAVE_ITEM;
386
e22024d3
NC
387 save_pushptrptr(item, /* remember the pointer */
388 sv, /* remember the value */
389 SAVEt_ITEM);
79072805
LW
390}
391
392void
1409bc06 393Perl_save_bool(pTHX_ bool *boolp)
79072805 394{
a3444cc5 395 dSS_ADD;
7918f24d 396
1409bc06 397 PERL_ARGS_ASSERT_SAVE_BOOL;
7918f24d 398
a3444cc5
DM
399 SS_ADD_PTR(boolp);
400 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
401 SS_ADD_END(2);
1409bc06
NC
402}
403
7623d426
NC
404void
405Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
1409bc06 406{
a3444cc5
DM
407 dSS_ADD;
408
409 SS_ADD_INT(i);
410 SS_ADD_PTR(ptr);
411 SS_ADD_UV(type);
412 SS_ADD_END(3);
79072805
LW
413}
414
415void
1409bc06 416Perl_save_int(pTHX_ int *intp)
9febdf04 417{
d172696c 418 const int i = *intp;
9b139d09 419 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
d172696c
DM
420 int size = 2;
421 dSS_ADD;
7918f24d 422
1409bc06 423 PERL_ARGS_ASSERT_SAVE_INT;
7918f24d 424
5d9574c1 425 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) {
d172696c
DM
426 SS_ADD_INT(i);
427 type = SAVEt_INT;
428 size++;
429 }
430 SS_ADD_PTR(intp);
431 SS_ADD_UV(type);
432 SS_ADD_END(size);
9febdf04
RH
433}
434
435void
58188858
RGS
436Perl_save_I8(pTHX_ I8 *bytep)
437{
a3444cc5 438 dSS_ADD;
7918f24d
NC
439
440 PERL_ARGS_ASSERT_SAVE_I8;
441
a3444cc5
DM
442 SS_ADD_PTR(bytep);
443 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
444 SS_ADD_END(2);
58188858
RGS
445}
446
447void
87a84751
JH
448Perl_save_I16(pTHX_ I16 *intp)
449{
a3444cc5 450 dSS_ADD;
7918f24d
NC
451
452 PERL_ARGS_ASSERT_SAVE_I16;
453
a3444cc5
DM
454 SS_ADD_PTR(intp);
455 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
456 SS_ADD_END(2);
87a84751
JH
457}
458
459void
864dbfa3 460Perl_save_I32(pTHX_ I32 *intp)
79072805 461{
d172696c 462 const I32 i = *intp;
9b139d09 463 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
d172696c
DM
464 int size = 2;
465 dSS_ADD;
7918f24d
NC
466
467 PERL_ARGS_ASSERT_SAVE_I32;
468
5d9574c1 469 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
d172696c
DM
470 SS_ADD_INT(i);
471 type = SAVEt_I32;
472 size++;
473 }
474 SS_ADD_PTR(intp);
475 SS_ADD_UV(type);
476 SS_ADD_END(size);
79072805
LW
477}
478
e8eb279c
FC
479void
480Perl_save_strlen(pTHX_ STRLEN *ptr)
481{
e8eb279c
FC
482 dSS_ADD;
483
484 PERL_ARGS_ASSERT_SAVE_STRLEN;
485
486 SS_ADD_IV(*ptr);
487 SS_ADD_PTR(ptr);
488 SS_ADD_UV(SAVEt_STRLEN);
489 SS_ADD_END(3);
490}
491
85e6fe83
LW
492/* Cannot use save_sptr() to store a char* since the SV** cast will
493 * force word-alignment and we'll miss the pointer.
494 */
495void
864dbfa3 496Perl_save_pptr(pTHX_ char **pptr)
85e6fe83 497{
7918f24d
NC
498 PERL_ARGS_ASSERT_SAVE_PPTR;
499
e22024d3 500 save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
85e6fe83
LW
501}
502
79072805 503void
146174a9
CB
504Perl_save_vptr(pTHX_ void *ptr)
505{
7918f24d
NC
506 PERL_ARGS_ASSERT_SAVE_VPTR;
507
e22024d3 508 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
146174a9
CB
509}
510
511void
864dbfa3 512Perl_save_sptr(pTHX_ SV **sptr)
79072805 513{
7918f24d
NC
514 PERL_ARGS_ASSERT_SAVE_SPTR;
515
e22024d3 516 save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
79072805
LW
517}
518
c3564e5c 519void
09edbca0 520Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
c3564e5c 521{
a3444cc5
DM
522 dSS_ADD;
523
f3548bdc 524 ASSERT_CURPAD_ACTIVE("save_padsv");
a3444cc5
DM
525 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
526 SS_ADD_PTR(PL_comppad);
03dba561 527 SS_ADD_UV((UV)off);
a3444cc5
DM
528 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
529 SS_ADD_END(4);
c3564e5c
GS
530}
531
79072805 532void
864dbfa3 533Perl_save_hptr(pTHX_ HV **hptr)
79072805 534{
7918f24d
NC
535 PERL_ARGS_ASSERT_SAVE_HPTR;
536
e22024d3 537 save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
79072805
LW
538}
539
540void
864dbfa3 541Perl_save_aptr(pTHX_ AV **aptr)
79072805 542{
7918f24d
NC
543 PERL_ARGS_ASSERT_SAVE_APTR;
544
e22024d3 545 save_pushptrptr(*aptr, aptr, SAVEt_APTR);
79072805
LW
546}
547
548void
2fd8beea 549Perl_save_pushptr(pTHX_ void *const ptr, const int type)
8990e307 550{
a3444cc5
DM
551 dSS_ADD;
552 SS_ADD_PTR(ptr);
553 SS_ADD_UV(type);
554 SS_ADD_END(2);
8990e307
LW
555}
556
557void
864dbfa3 558Perl_save_clearsv(pTHX_ SV **svp)
8990e307 559{
cdcdfc56
NC
560 const UV offset = svp - PL_curpad;
561 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
7918f24d
NC
562
563 PERL_ARGS_ASSERT_SAVE_CLEARSV;
564
f3548bdc 565 ASSERT_CURPAD_ACTIVE("save_clearsv");
623e28c6 566 SvPADSTALE_off(*svp); /* mark lexical as active */
5d9574c1 567 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) {
cdcdfc56
NC
568 Perl_croak(aTHX_ "panic: pad offset %"UVuf" out of range (%p-%p)",
569 offset, svp, PL_curpad);
a3444cc5 570 }
cdcdfc56 571
a3444cc5
DM
572 {
573 dSS_ADD;
574 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
575 SS_ADD_END(1);
576 }
8990e307
LW
577}
578
579void
864dbfa3 580Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
8990e307 581{
7918f24d
NC
582 PERL_ARGS_ASSERT_SAVE_DELETE;
583
85a721ca 584 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
8990e307
LW
585}
586
587void
af097752
VP
588Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
589{
590 STRLEN len;
591 I32 klen;
592 const char *key;
593
594 PERL_ARGS_ASSERT_SAVE_HDELETE;
595
596 key = SvPV_const(keysv, len);
597 klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
598 SvREFCNT_inc_simple_void_NN(hv);
599 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
600}
601
602void
c70927a6 603Perl_save_adelete(pTHX_ AV *av, SSize_t key)
c68ec7a9 604{
c70927a6 605 dSS_ADD;
c68ec7a9
VP
606
607 PERL_ARGS_ASSERT_SAVE_ADELETE;
608
609 SvREFCNT_inc_void(av);
c70927a6
FC
610 SS_ADD_UV(key);
611 SS_ADD_PTR(av);
612 SS_ADD_IV(SAVEt_ADELETE);
613 SS_ADD_END(3);
c68ec7a9
VP
614}
615
616void
12ab1f58
JH
617Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
618{
a3444cc5 619 dSS_ADD;
7918f24d
NC
620 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
621
a3444cc5
DM
622 SS_ADD_DPTR(f);
623 SS_ADD_PTR(p);
624 SS_ADD_UV(SAVEt_DESTRUCTOR);
625 SS_ADD_END(3);
12ab1f58
JH
626}
627
628void
146174a9
CB
629Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
630{
a3444cc5
DM
631 dSS_ADD;
632
633 SS_ADD_DXPTR(f);
634 SS_ADD_PTR(p);
635 SS_ADD_UV(SAVEt_DESTRUCTOR_X);
636 SS_ADD_END(3);
146174a9
CB
637}
638
639void
da8315f8
NC
640Perl_save_hints(pTHX)
641{
20439bc7 642 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
da8315f8 643 if (PL_hints & HINT_LOCALIZE_HH) {
52c7aca6
FC
644 HV *oldhh = GvHV(PL_hintgv);
645 save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
646 GvHV(PL_hintgv) = NULL; /* in case copying dies */
647 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
be84297e 648 } else {
20439bc7 649 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
da8315f8 650 }
be84297e
NC
651}
652
653static void
654S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
655 const int type)
656{
a3444cc5
DM
657 dSS_ADD;
658 SS_ADD_PTR(ptr1);
659 SS_ADD_INT(i);
660 SS_ADD_PTR(ptr2);
661 SS_ADD_UV(type);
662 SS_ADD_END(4);
da8315f8
NC
663}
664
665void
c70927a6
FC
666Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr,
667 const U32 flags)
4e4c362e 668{
20b7effb 669 dSS_ADD;
bfc4de9f 670 SV *sv;
7918f24d 671
91d1c79f 672 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
7918f24d 673
0cbee0a4 674 SvGETMAGIC(*sptr);
c70927a6
FC
675 SS_ADD_PTR(SvREFCNT_inc_simple(av));
676 SS_ADD_IV(idx);
677 SS_ADD_PTR(SvREFCNT_inc(*sptr));
678 SS_ADD_UV(SAVEt_AELEM);
679 SS_ADD_END(4);
1cdc9186
FC
680 /* The array needs to hold a reference count on its new element, so it
681 must be AvREAL. */
5d9574c1 682 if (UNLIKELY(!AvREAL(av) && AvREIFY(av)))
1cdc9186 683 av_reify(av);
91d1c79f 684 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
75d34a09
VP
685 if (flags & SAVEf_KEEPOLDELEM)
686 return;
bfc4de9f
DM
687 sv = *sptr;
688 /* If we're localizing a tied array element, this new sv
689 * won't actually be stored in the array - so it won't get
690 * reaped when the localize ends. Ensure it gets reaped by
691 * mortifying it instead. DAPM */
5d9574c1 692 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied)))
bfc4de9f 693 sv_2mortal(sv);
4e4c362e
GS
694}
695
696void
af7df257 697Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
4e4c362e 698{
bfc4de9f 699 SV *sv;
7918f24d 700
af7df257 701 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
7918f24d 702
0cbee0a4 703 SvGETMAGIC(*sptr);
a3444cc5
DM
704 {
705 dSS_ADD;
706 SS_ADD_PTR(SvREFCNT_inc_simple(hv));
707 SS_ADD_PTR(newSVsv(key));
708 SS_ADD_PTR(SvREFCNT_inc(*sptr));
709 SS_ADD_UV(SAVEt_HELEM);
710 SS_ADD_END(4);
711 }
af7df257 712 save_scalar_at(sptr, flags);
75d34a09
VP
713 if (flags & SAVEf_KEEPOLDELEM)
714 return;
bfc4de9f
DM
715 sv = *sptr;
716 /* If we're localizing a tied hash element, this new sv
717 * won't actually be stored in the hash - so it won't get
718 * reaped when the localize ends. Ensure it gets reaped by
719 * mortifying it instead. DAPM */
5d9574c1 720 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)))
bfc4de9f 721 sv_2mortal(sv);
4e4c362e
GS
722}
723
2053acbf
NC
724SV*
725Perl_save_svref(pTHX_ SV **sptr)
726{
7918f24d
NC
727 PERL_ARGS_ASSERT_SAVE_SVREF;
728
2053acbf 729 SvGETMAGIC(*sptr);
e22024d3 730 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
af7df257 731 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
2053acbf
NC
732}
733
455ece5e 734I32
864dbfa3 735Perl_save_alloc(pTHX_ I32 size, I32 pad)
455ece5e 736{
eb578fdb
KW
737 const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
738 - (char*)PL_savestack);
1be36ce0
NC
739 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
740 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
455ece5e 741
5d9574c1 742 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems))
93a641ae
DM
743 Perl_croak(aTHX_
744 "panic: save_alloc elems %"UVuf" out of range (%"IVdf"-%"IVdf")",
745 elems, (IV)size, (IV)pad);
1be36ce0
NC
746
747 SSGROW(elems + 1);
455ece5e
AD
748
749 PL_savestack_ix += elems;
1be36ce0 750 SSPUSHUV(SAVEt_ALLOC | elems_shifted);
455ece5e
AD
751 return start;
752}
753
03dba561
DM
754
755
756#define ARG0_SV MUTABLE_SV(arg0.any_ptr)
757#define ARG0_AV MUTABLE_AV(arg0.any_ptr)
758#define ARG0_HV MUTABLE_HV(arg0.any_ptr)
759#define ARG0_PTR arg0.any_ptr
760#define ARG0_PV (char*)(arg0.any_ptr)
761#define ARG0_PVP (char**)(arg0.any_ptr)
762#define ARG0_I32 (arg0.any_i32)
763
764#define ARG1_SV MUTABLE_SV(arg1.any_ptr)
765#define ARG1_AV MUTABLE_AV(arg1.any_ptr)
766#define ARG1_GV MUTABLE_GV(arg1.any_ptr)
767#define ARG1_SVP (SV**)(arg1.any_ptr)
768#define ARG1_PVP (char**)(arg1.any_ptr)
769#define ARG1_PTR arg1.any_ptr
770#define ARG1_PV (char*)(arg1.any_ptr)
771#define ARG1_I32 (arg1.any_i32)
772
773#define ARG2_SV MUTABLE_SV(arg2.any_ptr)
774#define ARG2_AV MUTABLE_AV(arg2.any_ptr)
775#define ARG2_HV MUTABLE_HV(arg2.any_ptr)
776#define ARG2_GV MUTABLE_GV(arg2.any_ptr)
777#define ARG2_PV (char*)(arg2.any_ptr)
778
462e5cf6 779void
864dbfa3 780Perl_leave_scope(pTHX_ I32 base)
79072805 781{
302c0c93 782 /* Localise the effects of the TAINT_NOT inside the loop. */
284167a5 783 bool was = TAINT_get;
79072805 784
51418c6a
JH
785 I32 i;
786 SV *sv;
787
03dba561
DM
788 ANY arg0, arg1, arg2;
789
790 /* these initialisations are logically unnecessary, but they shut up
791 * spurious 'may be used uninitialized' compiler warnings */
792 arg0.any_ptr = NULL;
793 arg1.any_ptr = NULL;
794 arg2.any_ptr = NULL;
795
5d9574c1 796 if (UNLIKELY(base < -1))
5637ef5b 797 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
1c98cc53
DM
798 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
799 (long)PL_savestack_ix, (long)base));
3280af22 800 while (PL_savestack_ix > base) {
03dba561
DM
801 UV uv;
802 U8 type;
803
804 SV *refsv;
805 SV **svp;
806
c6ae7647
NC
807 TAINT_NOT;
808
03dba561
DM
809 {
810 I32 ix = PL_savestack_ix - 1;
811 ANY *p = &PL_savestack[ix];
812 uv = p->any_uv;
813 type = (U8)uv & SAVE_MASK;
814 if (type > SAVEt_ARG0_MAX) {
815 ANY *p0 = p;
816 arg0 = *--p;
817 if (type > SAVEt_ARG1_MAX) {
818 arg1 = *--p;
819 if (type > SAVEt_ARG2_MAX) {
820 arg2 = *--p;
821 }
822 }
823 ix -= (p0 - p);
824 }
825 PL_savestack_ix = ix;
826 }
827
c6bf6a65 828 switch (type) {
79072805 829 case SAVEt_ITEM: /* normal string */
03dba561 830 sv_replace(ARG1_SV, ARG0_SV);
5d9574c1 831 if (UNLIKELY(SvSMAGICAL(ARG1_SV))) {
b492a59e
DM
832 PL_localizing = 2;
833 mg_set(ARG1_SV);
834 PL_localizing = 0;
835 }
79072805 836 break;
03dba561
DM
837
838 /* This would be a mathom, but Perl_save_svref() calls a static
839 function, S_save_scalar_at(), so has to stay in this file. */
840 case SAVEt_SVREF: /* scalar reference */
841 svp = ARG1_SVP;
842 refsv = NULL; /* what to refcnt_dec */
843 goto restore_sv;
844
8aacddc1 845 case SAVEt_SV: /* scalar reference */
03dba561
DM
846 svp = &GvSV(ARG1_GV);
847 refsv = ARG1_SV; /* what to refcnt_dec */
2053acbf 848 restore_sv:
03dba561
DM
849 {
850 SV * const sv = *svp;
851 *svp = ARG0_SV;
2053acbf 852 SvREFCNT_dec(sv);
5d9574c1 853 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
2baebb98
DM
854 /* mg_set could die, skipping the freeing of ARG0_SV and
855 * refsv; Ensure that they're always freed in that case */
856 dSS_ADD;
857 SS_ADD_PTR(ARG0_SV);
858 SS_ADD_UV(SAVEt_FREESV);
859 SS_ADD_PTR(refsv);
860 SS_ADD_UV(SAVEt_FREESV);
861 SS_ADD_END(4);
b492a59e
DM
862 PL_localizing = 2;
863 mg_set(ARG0_SV);
864 PL_localizing = 0;
2baebb98 865 break;
b492a59e 866 }
4a9a56a7 867 SvREFCNT_dec_NN(ARG0_SV);
03dba561 868 SvREFCNT_dec(refsv);
2053acbf 869 break;
03dba561 870 }
8aacddc1 871 case SAVEt_GENERIC_PVREF: /* generic pv */
03dba561
DM
872 if (*ARG0_PVP != ARG1_PV) {
873 Safefree(*ARG0_PVP);
874 *ARG0_PVP = ARG1_PV;
f4dd75d9
GS
875 }
876 break;
05ec9bb3 877 case SAVEt_SHARED_PVREF: /* shared pv */
03dba561 878 if (*ARG1_PVP != ARG0_PV) {
5e54c26f 879#ifdef NETWARE
03dba561 880 PerlMem_free(*ARG1_PVP);
5e54c26f 881#else
03dba561 882 PerlMemShared_free(*ARG1_PVP);
5e54c26f 883#endif
03dba561 884 *ARG1_PVP = ARG0_PV;
05ec9bb3
NIS
885 }
886 break;
f83b46a0 887 case SAVEt_GVSV: /* scalar slot in GV */
03dba561 888 svp = &GvSV(ARG1_GV);
f83b46a0 889 goto restore_svp;
8aacddc1 890 case SAVEt_GENERIC_SVREF: /* generic sv */
03dba561 891 svp = ARG1_SVP;
f83b46a0 892 restore_svp:
03dba561
DM
893 {
894 SV * const sv = *svp;
895 *svp = ARG0_SV;
f4dd75d9 896 SvREFCNT_dec(sv);
03dba561 897 SvREFCNT_dec(ARG0_SV);
b9d12d37 898 break;
03dba561 899 }
db9306af 900 case SAVEt_GVSLOT: /* any slot in GV */
03dba561
DM
901 {
902 HV *const hv = GvSTASH(ARG2_GV);
903 svp = ARG1_SVP;
db9306af 904 if (hv && HvENAME(hv) && (
03dba561
DM
905 (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
906 || (*svp && SvTYPE(*svp) == SVt_PVCV)
db9306af
FC
907 ))
908 {
03dba561
DM
909 if ((char *)svp < (char *)GvGP(ARG2_GV)
910 || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
a3d47e0d 911 || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */
db9306af
FC
912 PL_sub_generation++;
913 else mro_method_changed_in(hv);
914 }
915 goto restore_svp;
03dba561 916 }
8aacddc1 917 case SAVEt_AV: /* array reference */
03dba561
DM
918 SvREFCNT_dec(GvAV(ARG1_GV));
919 GvAV(ARG1_GV) = ARG0_AV;
2baebb98 920 avhv_common:
5d9574c1 921 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
2baebb98
DM
922 /* mg_set might die, so make sure ARG1 isn't leaked */
923 dSS_ADD;
924 SS_ADD_PTR(ARG1_SV);
925 SS_ADD_UV(SAVEt_FREESV);
926 SS_ADD_END(2);
b492a59e
DM
927 PL_localizing = 2;
928 mg_set(ARG0_SV);
929 PL_localizing = 0;
2baebb98 930 break;
b492a59e 931 }
4a9a56a7 932 SvREFCNT_dec_NN(ARG1_GV);
8aacddc1
NIS
933 break;
934 case SAVEt_HV: /* hash reference */
03dba561
DM
935 SvREFCNT_dec(GvHV(ARG1_GV));
936 GvHV(ARG1_GV) = ARG0_HV;
2baebb98
DM
937 goto avhv_common;
938
994d373a 939 case SAVEt_INT_SMALL:
03dba561 940 *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
994d373a 941 break;
79072805 942 case SAVEt_INT: /* int reference */
03dba561 943 *(int*)ARG0_PTR = (int)ARG1_I32;
79072805 944 break;
e8eb279c
FC
945 case SAVEt_STRLEN: /* STRLEN/size_t ref */
946 *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv;
947 break;
9febdf04 948 case SAVEt_BOOL: /* bool reference */
03dba561 949 *(bool*)ARG0_PTR = cBOOL(uv >> 8);
9a9b5ec9
DM
950#ifdef NO_TAINT_SUPPORT
951 PERL_UNUSED_VAR(was);
952#else
5d9574c1 953 if (UNLIKELY(ARG0_PTR == &(TAINT_get))) {
b6f93e7a
KW
954 /* If we don't update <was>, to reflect what was saved on the
955 * stack for PL_tainted, then we will overwrite this attempt to
956 * restore it when we exit this routine. Note that this won't
957 * work if this value was saved in a wider-than necessary type,
958 * such as I32 */
03dba561 959 was = *(bool*)ARG0_PTR;
b6f93e7a 960 }
284167a5 961#endif
9febdf04 962 break;
89abef21 963 case SAVEt_I32_SMALL:
03dba561 964 *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
89abef21 965 break;
79072805 966 case SAVEt_I32: /* I32 reference */
3235b7a3 967#ifdef PERL_DEBUG_READONLY_OPS
03dba561 968 if (*(I32*)ARG0_PTR != ARG1_I32)
3235b7a3 969#endif
03dba561 970 *(I32*)ARG0_PTR = ARG1_I32;
79072805
LW
971 break;
972 case SAVEt_SPTR: /* SV* reference */
03dba561 973 *(SV**)(ARG0_PTR)= ARG1_SV;
79072805 974 break;
146174a9 975 case SAVEt_VPTR: /* random* reference */
85e6fe83 976 case SAVEt_PPTR: /* char* reference */
03dba561 977 *ARG0_PVP = ARG1_PV;
85e6fe83 978 break;
79072805 979 case SAVEt_HPTR: /* HV* reference */
03dba561 980 *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
79072805
LW
981 break;
982 case SAVEt_APTR: /* AV* reference */
03dba561 983 *(AV**)ARG0_PTR = ARG1_AV;
79072805 984 break;
fb73857a 985 case SAVEt_GP: /* scalar reference */
03dba561
DM
986 {
987 HV *hv;
988 /* possibly taking a method out of circulation */
989 const bool had_method = !!GvCVu(ARG1_GV);
990 gp_free(ARG1_GV);
991 GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
992 if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
993 if ( GvNAMELEN(ARG1_GV) == 3
994 && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
995 )
996 mro_isa_changed_in(hv);
997 else if (had_method || GvCVu(ARG1_GV))
998 /* putting a method back into circulation ("local")*/
999 gv_method_changed(ARG1_GV);
3d460042 1000 }
4a9a56a7 1001 SvREFCNT_dec_NN(ARG1_GV);
8aacddc1 1002 break;
03dba561 1003 }
8990e307 1004 case SAVEt_FREESV:
03dba561 1005 SvREFCNT_dec(ARG0_SV);
8990e307 1006 break;
0f94cb1f
FC
1007 case SAVEt_FREEPADNAME:
1008 PadnameREFCNT_dec((PADNAME *)ARG0_PTR);
1009 break;
3987a177 1010 case SAVEt_FREECOPHH:
03dba561 1011 cophh_free((COPHH *)ARG0_PTR);
3987a177 1012 break;
26d9b02f 1013 case SAVEt_MORTALIZESV:
03dba561 1014 sv_2mortal(ARG0_SV);
26d9b02f 1015 break;
8990e307 1016 case SAVEt_FREEOP:
5e5ba94b 1017 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
03dba561 1018 op_free((OP*)ARG0_PTR);
8990e307
LW
1019 break;
1020 case SAVEt_FREEPV:
03dba561 1021 Safefree(ARG0_PTR);
8990e307 1022 break;
4e09461c 1023
4e09461c
DM
1024 case SAVEt_CLEARPADRANGE:
1025 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1026 svp = &PL_curpad[uv >>
1027 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1028 goto clearsv;
8990e307 1029 case SAVEt_CLEARSV:
4e09461c
DM
1030 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1031 i = 1;
1032 clearsv:
1033 for (; i; i--, svp--) {
528ad060
DM
1034 sv = *svp;
1035
1036 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1037 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
1038 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1039 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1040 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1041 ));
1042
1043 /* Can clear pad variable in place? */
9af15990 1044 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
a07f0bef 1045
a07f0bef
DM
1046 /* these flags are the union of all the relevant flags
1047 * in the individual conditions within */
1048 if (UNLIKELY(SvFLAGS(sv) & (
a623f893 1049 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
a07f0bef 1050 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
7532eaae 1051 | SVf_OOK
a07f0bef
DM
1052 | SVf_THINKFIRST)))
1053 {
7500fc82
DM
1054 /* if a my variable that was made readonly is
1055 * going out of scope, we want to remove the
1056 * readonlyness so that it can go out of scope
1057 * quietly
1058 */
57c404c9 1059 if (SvREADONLY(sv))
7500fc82
DM
1060 SvREADONLY_off(sv);
1061
7532eaae
DM
1062 if (SvOOK(sv)) { /* OOK or HvAUX */
1063 if (SvTYPE(sv) == SVt_PVHV)
1064 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1065 else
1066 sv_backoff(sv);
1067 }
1068
7500fc82 1069 if (SvMAGICAL(sv)) {
7532eaae
DM
1070 /* note that backrefs (either in HvAUX or magic)
1071 * must be removed before other magic */
7500fc82
DM
1072 sv_unmagic(sv, PERL_MAGIC_backref);
1073 if (SvTYPE(sv) != SVt_PVCV)
1074 mg_free(sv);
1075 }
1076 if (SvTHINKFIRST(sv))
1077 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1078 |SV_COW_DROP_PV);
528ad060 1079
a07f0bef 1080 }
528ad060
DM
1081 switch (SvTYPE(sv)) {
1082 case SVt_NULL:
1083 break;
1084 case SVt_PVAV:
1085 av_clear(MUTABLE_AV(sv));
1086 break;
1087 case SVt_PVHV:
1088 hv_clear(MUTABLE_HV(sv));
1089 break;
1090 case SVt_PVCV:
1091 {
db5cc3ee 1092 HEK *hek =
db5cc3ee 1093 CvNAMED(sv)
9c98a81f
FC
1094 ? CvNAME_HEK((CV *)sv)
1095 : GvNAME_HEK(CvGV(sv));
528ad060 1096 assert(hek);
6110d17a 1097 (void)share_hek_hek(hek);
528ad060
DM
1098 cv_undef((CV *)sv);
1099 CvNAME_HEK_set(sv, hek);
f3feca7a 1100 CvLEXICAL_on(sv);
528ad060
DM
1101 break;
1102 }
1103 default:
c79d0076
NC
1104 /* This looks odd, but these two macros are for use in
1105 expressions and finish with a trailing comma, so
1106 adding a ; after them would be wrong. */
1107 assert_not_ROK(sv)
1108 assert_not_glob(sv)
5c85b638 1109 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
528ad060
DM
1110 break;
1111 }
82e85a9c 1112 SvPADTMP_off(sv);
528ad060
DM
1113 SvPADSTALE_on(sv); /* mark as no longer live */
1114 }
1115 else { /* Someone has a claim on this, so abandon it. */
528ad060
DM
1116 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
1117 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
1118 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
1119 case SVt_PVCV:
1120 {
9c98a81f
FC
1121 HEK * const hek = CvNAMED(sv)
1122 ? CvNAME_HEK((CV *)sv)
1123 : GvNAME_HEK(CvGV(sv));
1124
528ad060
DM
1125 /* Create a stub */
1126 *svp = newSV_type(SVt_PVCV);
1127
1128 /* Share name */
528ad060 1129 CvNAME_HEK_set(*svp,
9c98a81f 1130 share_hek_hek(hek));
f3feca7a 1131 CvLEXICAL_on(*svp);
528ad060
DM
1132 break;
1133 }
1134 default: *svp = newSV(0); break;
1135 }
4a9a56a7 1136 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
528ad060
DM
1137 /* preserve pad nature, but also mark as not live
1138 * for any closure capturing */
145bf8ee 1139 SvFLAGS(*svp) |= SVs_PADSTALE;
528ad060 1140 }
4e09461c 1141 }
8990e307
LW
1142 break;
1143 case SAVEt_DELETE:
03dba561
DM
1144 (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
1145 SvREFCNT_dec(ARG0_HV);
1146 Safefree(arg2.any_ptr);
8990e307 1147 break;
c68ec7a9 1148 case SAVEt_ADELETE:
c70927a6 1149 (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD);
03dba561 1150 SvREFCNT_dec(ARG0_AV);
c68ec7a9 1151 break;
146174a9 1152 case SAVEt_DESTRUCTOR_X:
03dba561 1153 (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
a0d0e21e
LW
1154 break;
1155 case SAVEt_REGCONTEXT:
e0fa7e2b 1156 /* regexp must have croaked */
455ece5e 1157 case SAVEt_ALLOC:
1be36ce0 1158 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
a0d0e21e 1159 break;
55497cff 1160 case SAVEt_STACK_POS: /* Position on Perl stack */
03dba561 1161 PL_stack_sp = PL_stack_base + arg0.any_i32;
55497cff 1162 break;
161b7d16 1163 case SAVEt_AELEM: /* array element */
c70927a6 1164 svp = av_fetch(ARG2_AV, arg1.any_iv, 1);
5d9574c1 1165 if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */
03dba561 1166 SvREFCNT_dec(ARG0_SV);
5d9574c1 1167 if (LIKELY(svp)) {
03dba561 1168 SV * const sv = *svp;
5d9574c1
DM
1169 if (LIKELY(sv && sv != &PL_sv_undef)) {
1170 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied)))
b37c2d43 1171 SvREFCNT_inc_void_NN(sv);
03dba561 1172 refsv = ARG2_SV;
4e4c362e
GS
1173 goto restore_sv;
1174 }
1175 }
03dba561
DM
1176 SvREFCNT_dec(ARG2_AV);
1177 SvREFCNT_dec(ARG0_SV);
4e4c362e 1178 break;
161b7d16 1179 case SAVEt_HELEM: /* hash element */
03dba561
DM
1180 {
1181 HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
1182 SvREFCNT_dec(ARG1_SV);
5d9574c1 1183 if (LIKELY(he)) {
03dba561 1184 const SV * const oval = HeVAL(he);
5d9574c1 1185 if (LIKELY(oval && oval != &PL_sv_undef)) {
03dba561 1186 svp = &HeVAL(he);
5d9574c1 1187 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied)))
03dba561
DM
1188 SvREFCNT_inc_void(*svp);
1189 refsv = ARG2_SV; /* what to refcnt_dec */
4e4c362e
GS
1190 goto restore_sv;
1191 }
1192 }
03dba561
DM
1193 SvREFCNT_dec(ARG2_HV);
1194 SvREFCNT_dec(ARG0_SV);
4e4c362e 1195 break;
03dba561 1196 }
462e5cf6 1197 case SAVEt_OP:
03dba561 1198 PL_op = (OP*)ARG0_PTR;
462e5cf6 1199 break;
25eaa213 1200 case SAVEt_HINTS:
3607ca02
FC
1201 if ((PL_hints & HINT_LOCALIZE_HH)) {
1202 while (GvHV(PL_hintgv)) {
2653c1e3 1203 HV *hv = GvHV(PL_hintgv);
045ac317 1204 GvHV(PL_hintgv) = NULL;
2653c1e3 1205 SvREFCNT_dec(MUTABLE_SV(hv));
3607ca02 1206 }
045ac317 1207 }
20439bc7 1208 cophh_free(CopHINTHASH_get(&PL_compiling));
03dba561
DM
1209 CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
1210 *(I32*)&PL_hints = ARG1_I32;
dfa41748 1211 if (PL_hints & HINT_LOCALIZE_HH) {
ad64d0ec 1212 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
85fbaab2 1213 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
2653c1e3
DM
1214 }
1215 if (!GvHV(PL_hintgv)) {
a3fb8386
FC
1216 /* Need to add a new one manually, else rv2hv can
1217 add one via GvHVn and it won't have the magic set. */
5b9c0671
NC
1218 HV *const hv = newHV();
1219 hv_magic(hv, NULL, PERL_MAGIC_hints);
1220 GvHV(PL_hintgv) = hv;
dfa41748 1221 }
5b9c0671 1222 assert(GvHV(PL_hintgv));
b3ac6de7 1223 break;
cb50131a 1224 case SAVEt_COMPPAD:
03dba561 1225 PL_comppad = (PAD*)ARG0_PTR;
5d9574c1 1226 if (LIKELY(PL_comppad))
cb50131a
CB
1227 PL_curpad = AvARRAY(PL_comppad);
1228 else
4608196e 1229 PL_curpad = NULL;
cb50131a 1230 break;
09edbca0 1231 case SAVEt_PADSV_AND_MORTALIZE:
c3564e5c 1232 {
09edbca0 1233 SV **svp;
03dba561
DM
1234 assert (ARG1_PTR);
1235 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
09edbca0
NC
1236 /* This mortalizing used to be done by POPLOOP() via itersave.
1237 But as we have all the information here, we can do it here,
1238 save even having to have itersave in the struct. */
1239 sv_2mortal(*svp);
03dba561 1240 *svp = ARG2_SV;
c3564e5c
GS
1241 }
1242 break;
8b7059b1
DM
1243 case SAVEt_SAVESWITCHSTACK:
1244 {
1245 dSP;
03dba561
DM
1246 SWITCHSTACK(ARG0_AV, ARG1_AV);
1247 PL_curstackinfo->si_stack = ARG1_AV;
8b7059b1
DM
1248 }
1249 break;
14f338dc 1250 case SAVEt_SET_SVFLAGS:
03dba561
DM
1251 SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
1252 SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
14f338dc 1253 break;
95e06916 1254
95e06916
NC
1255 /* These are only saved in mathoms.c */
1256 case SAVEt_NSTAB:
03dba561 1257 (void)sv_clear(ARG0_SV);
95e06916 1258 break;
2053acbf 1259 case SAVEt_LONG: /* long reference */
03dba561 1260 *(long*)ARG0_PTR = arg1.any_long;
2053acbf 1261 break;
95e06916 1262 case SAVEt_IV: /* IV reference */
03dba561 1263 *(IV*)ARG0_PTR = arg1.any_iv;
95e06916
NC
1264 break;
1265
2053acbf 1266 case SAVEt_I16: /* I16 reference */
03dba561 1267 *(I16*)ARG0_PTR = (I16)(uv >> 8);
2053acbf
NC
1268 break;
1269 case SAVEt_I8: /* I8 reference */
03dba561 1270 *(I8*)ARG0_PTR = (I8)(uv >> 8);
2053acbf 1271 break;
2053acbf 1272 case SAVEt_DESTRUCTOR:
03dba561 1273 (*arg1.any_dptr)(ARG0_PTR);
2053acbf 1274 break;
68da3b2f 1275 case SAVEt_COMPILE_WARNINGS:
68da3b2f
NC
1276 if (!specialWARN(PL_compiling.cop_warnings))
1277 PerlMemShared_free(PL_compiling.cop_warnings);
72dc9ed5 1278
03dba561 1279 PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
72dc9ed5 1280 break;
7c197c94 1281 case SAVEt_PARSER:
03dba561 1282 parser_free((yy_parser *) ARG0_PTR);
7c197c94 1283 break;
20d5dc23
FC
1284 case SAVEt_READONLY_OFF:
1285 SvREADONLY_off(ARG0_SV);
1286 break;
79072805 1287 default:
5637ef5b 1288 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
79072805
LW
1289 }
1290 }
302c0c93 1291
284167a5 1292 TAINT_set(was);
79072805 1293}
8990e307 1294
8990e307 1295void
864dbfa3 1296Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
8990e307 1297{
7918f24d
NC
1298 PERL_ARGS_ASSERT_CX_DUMP;
1299
35ff7856 1300#ifdef DEBUGGING
22c35a8c 1301 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
6b35e009 1302 if (CxTYPE(cx) != CXt_SUBST) {
e8d9e9d0 1303 const char *gimme_text;
760ac839 1304 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
146174a9
CB
1305 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1306 PTR2UV(cx->blk_oldcop));
760ac839
LW
1307 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1308 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
146174a9
CB
1309 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1310 PTR2UV(cx->blk_oldpm));
e8d9e9d0
VP
1311 switch (cx->blk_gimme) {
1312 case G_VOID:
1313 gimme_text = "VOID";
1314 break;
1315 case G_SCALAR:
1316 gimme_text = "SCALAR";
1317 break;
1318 case G_ARRAY:
1319 gimme_text = "LIST";
1320 break;
1321 default:
1322 gimme_text = "UNKNOWN";
1323 break;
1324 }
1325 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
8990e307 1326 }
6b35e009 1327 switch (CxTYPE(cx)) {
8990e307
LW
1328 case CXt_NULL:
1329 case CXt_BLOCK:
1330 break;
146174a9 1331 case CXt_FORMAT:
f9c764c5
NC
1332 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1333 PTR2UV(cx->blk_format.cv));
1334 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1335 PTR2UV(cx->blk_format.gv));
1336 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1337 PTR2UV(cx->blk_format.dfoutgv));
1338 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
bafb2adc 1339 (int)CxHASARGS(cx));
f9c764c5
NC
1340 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1341 PTR2UV(cx->blk_format.retop));
146174a9 1342 break;
8990e307 1343 case CXt_SUB:
146174a9
CB
1344 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1345 PTR2UV(cx->blk_sub.cv));
760ac839 1346 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
8990e307 1347 (long)cx->blk_sub.olddepth);
760ac839 1348 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
bafb2adc
NC
1349 (int)CxHASARGS(cx));
1350 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
f39bc417
DM
1351 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1352 PTR2UV(cx->blk_sub.retop));
8990e307
LW
1353 break;
1354 case CXt_EVAL:
760ac839 1355 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
85a64632 1356 (long)CxOLD_IN_EVAL(cx));
760ac839 1357 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
85a64632
NC
1358 PL_op_name[CxOLD_OP_TYPE(cx)],
1359 PL_op_desc[CxOLD_OP_TYPE(cx)]);
0f79a09d
GS
1360 if (cx->blk_eval.old_namesv)
1361 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
aa07b2f6 1362 SvPVX_const(cx->blk_eval.old_namesv));
146174a9
CB
1363 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1364 PTR2UV(cx->blk_eval.old_eval_root));
f39bc417
DM
1365 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1366 PTR2UV(cx->blk_eval.retop));
8990e307
LW
1367 break;
1368
93661e56 1369 case CXt_LOOP_PLAIN:
c6fdafd0 1370 case CXt_LOOP_LAZYIV:
d01136d6 1371 case CXt_LOOP_LAZYSV:
93661e56
DM
1372 case CXt_LOOP_LIST:
1373 case CXt_LOOP_ARY:
0cbdab38 1374 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
022eaa24
NC
1375 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1376 PTR2UV(cx->blk_loop.my_op));
d01136d6 1377 /* XXX: not accurate for LAZYSV/IV */
146174a9 1378 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
d01136d6
BS
1379 PTR2UV(cx->blk_loop.state_u.ary.ary));
1380 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1381 (long)cx->blk_loop.state_u.ary.ix);
146174a9
CB
1382 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1383 PTR2UV(CxITERVAR(cx)));
8990e307
LW
1384 break;
1385
1386 case CXt_SUBST:
760ac839 1387 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
8990e307 1388 (long)cx->sb_iters);
760ac839 1389 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
8990e307 1390 (long)cx->sb_maxiters);
35ef4773
GS
1391 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1392 (long)cx->sb_rflags);
760ac839 1393 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
c5bed6a7 1394 (long)CxONCE(cx));
760ac839 1395 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
8990e307 1396 cx->sb_orig);
146174a9
CB
1397 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1398 PTR2UV(cx->sb_dstr));
1399 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1400 PTR2UV(cx->sb_targ));
1401 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1402 PTR2UV(cx->sb_s));
1403 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1404 PTR2UV(cx->sb_m));
1405 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1406 PTR2UV(cx->sb_strend));
1407 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1408 PTR2UV(cx->sb_rxres));
8990e307
LW
1409 break;
1410 }
65e66c80 1411#else
96a5add6 1412 PERL_UNUSED_CONTEXT;
65e66c80 1413 PERL_UNUSED_ARG(cx);
17c3b450 1414#endif /* DEBUGGING */
35ff7856 1415}
241d1a3b
NC
1416
1417/*
14d04a33 1418 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1419 */