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