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