This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Fix EBCDIC double translation
[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))) {
b492a59e
DM
844 PL_localizing = 2;
845 mg_set(ARG0_SV);
846 PL_localizing = 0;
847 }
4a9a56a7 848 SvREFCNT_dec_NN(ARG0_SV);
03dba561 849 SvREFCNT_dec(refsv);
2053acbf 850 break;
03dba561 851 }
8aacddc1 852 case SAVEt_GENERIC_PVREF: /* generic pv */
03dba561
DM
853 if (*ARG0_PVP != ARG1_PV) {
854 Safefree(*ARG0_PVP);
855 *ARG0_PVP = ARG1_PV;
f4dd75d9
GS
856 }
857 break;
05ec9bb3 858 case SAVEt_SHARED_PVREF: /* shared pv */
03dba561 859 if (*ARG1_PVP != ARG0_PV) {
5e54c26f 860#ifdef NETWARE
03dba561 861 PerlMem_free(*ARG1_PVP);
5e54c26f 862#else
03dba561 863 PerlMemShared_free(*ARG1_PVP);
5e54c26f 864#endif
03dba561 865 *ARG1_PVP = ARG0_PV;
05ec9bb3
NIS
866 }
867 break;
f83b46a0 868 case SAVEt_GVSV: /* scalar slot in GV */
03dba561 869 svp = &GvSV(ARG1_GV);
f83b46a0 870 goto restore_svp;
8aacddc1 871 case SAVEt_GENERIC_SVREF: /* generic sv */
03dba561 872 svp = ARG1_SVP;
f83b46a0 873 restore_svp:
03dba561
DM
874 {
875 SV * const sv = *svp;
876 *svp = ARG0_SV;
f4dd75d9 877 SvREFCNT_dec(sv);
03dba561 878 SvREFCNT_dec(ARG0_SV);
b9d12d37 879 break;
03dba561 880 }
db9306af 881 case SAVEt_GVSLOT: /* any slot in GV */
03dba561
DM
882 {
883 HV *const hv = GvSTASH(ARG2_GV);
884 svp = ARG1_SVP;
db9306af 885 if (hv && HvENAME(hv) && (
03dba561
DM
886 (ARG0_SV && SvTYPE(ARG0_SV) == SVt_PVCV)
887 || (*svp && SvTYPE(*svp) == SVt_PVCV)
db9306af
FC
888 ))
889 {
03dba561
DM
890 if ((char *)svp < (char *)GvGP(ARG2_GV)
891 || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
a3d47e0d 892 || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */
db9306af
FC
893 PL_sub_generation++;
894 else mro_method_changed_in(hv);
895 }
896 goto restore_svp;
03dba561 897 }
8aacddc1 898 case SAVEt_AV: /* array reference */
03dba561
DM
899 SvREFCNT_dec(GvAV(ARG1_GV));
900 GvAV(ARG1_GV) = ARG0_AV;
5d9574c1 901 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
b492a59e
DM
902 PL_localizing = 2;
903 mg_set(ARG0_SV);
904 PL_localizing = 0;
905 }
4a9a56a7 906 SvREFCNT_dec_NN(ARG1_GV);
8aacddc1
NIS
907 break;
908 case SAVEt_HV: /* hash reference */
03dba561
DM
909 SvREFCNT_dec(GvHV(ARG1_GV));
910 GvHV(ARG1_GV) = ARG0_HV;
5d9574c1 911 if (UNLIKELY(SvSMAGICAL(ARG0_SV))) {
b492a59e
DM
912 PL_localizing = 2;
913 mg_set(ARG0_SV);
914 PL_localizing = 0;
915 }
4a9a56a7 916 SvREFCNT_dec_NN(ARG1_GV);
8aacddc1 917 break;
994d373a 918 case SAVEt_INT_SMALL:
03dba561 919 *(int*)ARG0_PTR = (int)(uv >> SAVE_TIGHT_SHIFT);
994d373a 920 break;
79072805 921 case SAVEt_INT: /* int reference */
03dba561 922 *(int*)ARG0_PTR = (int)ARG1_I32;
79072805 923 break;
e8eb279c
FC
924 case SAVEt_STRLEN: /* STRLEN/size_t ref */
925 *(STRLEN*)ARG0_PTR = (STRLEN)arg1.any_iv;
926 break;
9febdf04 927 case SAVEt_BOOL: /* bool reference */
03dba561 928 *(bool*)ARG0_PTR = cBOOL(uv >> 8);
9a9b5ec9
DM
929#ifdef NO_TAINT_SUPPORT
930 PERL_UNUSED_VAR(was);
931#else
5d9574c1 932 if (UNLIKELY(ARG0_PTR == &(TAINT_get))) {
b6f93e7a
KW
933 /* If we don't update <was>, to reflect what was saved on the
934 * stack for PL_tainted, then we will overwrite this attempt to
935 * restore it when we exit this routine. Note that this won't
936 * work if this value was saved in a wider-than necessary type,
937 * such as I32 */
03dba561 938 was = *(bool*)ARG0_PTR;
b6f93e7a 939 }
284167a5 940#endif
9febdf04 941 break;
89abef21 942 case SAVEt_I32_SMALL:
03dba561 943 *(I32*)ARG0_PTR = (I32)(uv >> SAVE_TIGHT_SHIFT);
89abef21 944 break;
79072805 945 case SAVEt_I32: /* I32 reference */
3235b7a3 946#ifdef PERL_DEBUG_READONLY_OPS
03dba561 947 if (*(I32*)ARG0_PTR != ARG1_I32)
3235b7a3 948#endif
03dba561 949 *(I32*)ARG0_PTR = ARG1_I32;
79072805
LW
950 break;
951 case SAVEt_SPTR: /* SV* reference */
03dba561 952 *(SV**)(ARG0_PTR)= ARG1_SV;
79072805 953 break;
146174a9 954 case SAVEt_VPTR: /* random* reference */
85e6fe83 955 case SAVEt_PPTR: /* char* reference */
03dba561 956 *ARG0_PVP = ARG1_PV;
85e6fe83 957 break;
79072805 958 case SAVEt_HPTR: /* HV* reference */
03dba561 959 *(HV**)ARG0_PTR = MUTABLE_HV(ARG1_PTR);
79072805
LW
960 break;
961 case SAVEt_APTR: /* AV* reference */
03dba561 962 *(AV**)ARG0_PTR = ARG1_AV;
79072805 963 break;
fb73857a 964 case SAVEt_GP: /* scalar reference */
03dba561
DM
965 {
966 HV *hv;
967 /* possibly taking a method out of circulation */
968 const bool had_method = !!GvCVu(ARG1_GV);
969 gp_free(ARG1_GV);
970 GvGP_set(ARG1_GV, (GP*)ARG0_PTR);
971 if ((hv=GvSTASH(ARG1_GV)) && HvENAME_get(hv)) {
972 if ( GvNAMELEN(ARG1_GV) == 3
973 && strnEQ(GvNAME(ARG1_GV), "ISA", 3)
974 )
975 mro_isa_changed_in(hv);
976 else if (had_method || GvCVu(ARG1_GV))
977 /* putting a method back into circulation ("local")*/
978 gv_method_changed(ARG1_GV);
3d460042 979 }
4a9a56a7 980 SvREFCNT_dec_NN(ARG1_GV);
8aacddc1 981 break;
03dba561 982 }
8990e307 983 case SAVEt_FREESV:
03dba561 984 SvREFCNT_dec(ARG0_SV);
8990e307 985 break;
0f94cb1f
FC
986 case SAVEt_FREEPADNAME:
987 PadnameREFCNT_dec((PADNAME *)ARG0_PTR);
988 break;
3987a177 989 case SAVEt_FREECOPHH:
03dba561 990 cophh_free((COPHH *)ARG0_PTR);
3987a177 991 break;
26d9b02f 992 case SAVEt_MORTALIZESV:
03dba561 993 sv_2mortal(ARG0_SV);
26d9b02f 994 break;
8990e307 995 case SAVEt_FREEOP:
5e5ba94b 996 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
03dba561 997 op_free((OP*)ARG0_PTR);
8990e307
LW
998 break;
999 case SAVEt_FREEPV:
03dba561 1000 Safefree(ARG0_PTR);
8990e307 1001 break;
4e09461c 1002
4e09461c
DM
1003 case SAVEt_CLEARPADRANGE:
1004 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1005 svp = &PL_curpad[uv >>
1006 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1007 goto clearsv;
8990e307 1008 case SAVEt_CLEARSV:
4e09461c
DM
1009 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1010 i = 1;
1011 clearsv:
1012 for (; i; i--, svp--) {
528ad060
DM
1013 sv = *svp;
1014
1015 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1016 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
1017 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1018 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1019 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1020 ));
1021
1022 /* Can clear pad variable in place? */
9af15990 1023 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
a07f0bef 1024
a07f0bef
DM
1025 /* these flags are the union of all the relevant flags
1026 * in the individual conditions within */
1027 if (UNLIKELY(SvFLAGS(sv) & (
a623f893 1028 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
a07f0bef 1029 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
7532eaae 1030 | SVf_OOK
a07f0bef
DM
1031 | SVf_THINKFIRST)))
1032 {
7500fc82
DM
1033 /* if a my variable that was made readonly is
1034 * going out of scope, we want to remove the
1035 * readonlyness so that it can go out of scope
1036 * quietly
1037 */
57c404c9 1038 if (SvREADONLY(sv))
7500fc82
DM
1039 SvREADONLY_off(sv);
1040
7532eaae
DM
1041 if (SvOOK(sv)) { /* OOK or HvAUX */
1042 if (SvTYPE(sv) == SVt_PVHV)
1043 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1044 else
1045 sv_backoff(sv);
1046 }
1047
7500fc82 1048 if (SvMAGICAL(sv)) {
7532eaae
DM
1049 /* note that backrefs (either in HvAUX or magic)
1050 * must be removed before other magic */
7500fc82
DM
1051 sv_unmagic(sv, PERL_MAGIC_backref);
1052 if (SvTYPE(sv) != SVt_PVCV)
1053 mg_free(sv);
1054 }
1055 if (SvTHINKFIRST(sv))
1056 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1057 |SV_COW_DROP_PV);
528ad060 1058
a07f0bef 1059 }
528ad060
DM
1060 switch (SvTYPE(sv)) {
1061 case SVt_NULL:
1062 break;
1063 case SVt_PVAV:
1064 av_clear(MUTABLE_AV(sv));
1065 break;
1066 case SVt_PVHV:
1067 hv_clear(MUTABLE_HV(sv));
1068 break;
1069 case SVt_PVCV:
1070 {
db5cc3ee 1071 HEK *hek =
db5cc3ee 1072 CvNAMED(sv)
9c98a81f
FC
1073 ? CvNAME_HEK((CV *)sv)
1074 : GvNAME_HEK(CvGV(sv));
528ad060 1075 assert(hek);
6110d17a 1076 (void)share_hek_hek(hek);
528ad060
DM
1077 cv_undef((CV *)sv);
1078 CvNAME_HEK_set(sv, hek);
f3feca7a 1079 CvLEXICAL_on(sv);
528ad060
DM
1080 break;
1081 }
1082 default:
c79d0076
NC
1083 /* This looks odd, but these two macros are for use in
1084 expressions and finish with a trailing comma, so
1085 adding a ; after them would be wrong. */
1086 assert_not_ROK(sv)
1087 assert_not_glob(sv)
5c85b638 1088 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
528ad060
DM
1089 break;
1090 }
82e85a9c 1091 SvPADTMP_off(sv);
528ad060
DM
1092 SvPADSTALE_on(sv); /* mark as no longer live */
1093 }
1094 else { /* Someone has a claim on this, so abandon it. */
528ad060
DM
1095 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
1096 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
1097 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
1098 case SVt_PVCV:
1099 {
9c98a81f
FC
1100 HEK * const hek = CvNAMED(sv)
1101 ? CvNAME_HEK((CV *)sv)
1102 : GvNAME_HEK(CvGV(sv));
1103
528ad060
DM
1104 /* Create a stub */
1105 *svp = newSV_type(SVt_PVCV);
1106
1107 /* Share name */
528ad060 1108 CvNAME_HEK_set(*svp,
9c98a81f 1109 share_hek_hek(hek));
f3feca7a 1110 CvLEXICAL_on(*svp);
528ad060
DM
1111 break;
1112 }
1113 default: *svp = newSV(0); break;
1114 }
4a9a56a7 1115 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
528ad060
DM
1116 /* preserve pad nature, but also mark as not live
1117 * for any closure capturing */
145bf8ee 1118 SvFLAGS(*svp) |= SVs_PADSTALE;
528ad060 1119 }
4e09461c 1120 }
8990e307
LW
1121 break;
1122 case SAVEt_DELETE:
03dba561
DM
1123 (void)hv_delete(ARG0_HV, ARG2_PV, ARG1_I32, G_DISCARD);
1124 SvREFCNT_dec(ARG0_HV);
1125 Safefree(arg2.any_ptr);
8990e307 1126 break;
c68ec7a9 1127 case SAVEt_ADELETE:
c70927a6 1128 (void)av_delete(ARG0_AV, arg1.any_iv, G_DISCARD);
03dba561 1129 SvREFCNT_dec(ARG0_AV);
c68ec7a9 1130 break;
146174a9 1131 case SAVEt_DESTRUCTOR_X:
03dba561 1132 (*arg1.any_dxptr)(aTHX_ ARG0_PTR);
a0d0e21e
LW
1133 break;
1134 case SAVEt_REGCONTEXT:
e0fa7e2b 1135 /* regexp must have croaked */
455ece5e 1136 case SAVEt_ALLOC:
1be36ce0 1137 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
a0d0e21e 1138 break;
55497cff 1139 case SAVEt_STACK_POS: /* Position on Perl stack */
03dba561 1140 PL_stack_sp = PL_stack_base + arg0.any_i32;
55497cff 1141 break;
161b7d16 1142 case SAVEt_AELEM: /* array element */
c70927a6 1143 svp = av_fetch(ARG2_AV, arg1.any_iv, 1);
5d9574c1 1144 if (UNLIKELY(!AvREAL(ARG2_AV) && AvREIFY(ARG2_AV))) /* undo reify guard */
03dba561 1145 SvREFCNT_dec(ARG0_SV);
5d9574c1 1146 if (LIKELY(svp)) {
03dba561 1147 SV * const sv = *svp;
5d9574c1
DM
1148 if (LIKELY(sv && sv != &PL_sv_undef)) {
1149 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_AV, PERL_MAGIC_tied)))
b37c2d43 1150 SvREFCNT_inc_void_NN(sv);
03dba561 1151 refsv = ARG2_SV;
4e4c362e
GS
1152 goto restore_sv;
1153 }
1154 }
03dba561
DM
1155 SvREFCNT_dec(ARG2_AV);
1156 SvREFCNT_dec(ARG0_SV);
4e4c362e 1157 break;
161b7d16 1158 case SAVEt_HELEM: /* hash element */
03dba561
DM
1159 {
1160 HE * const he = hv_fetch_ent(ARG2_HV, ARG1_SV, 1, 0);
1161 SvREFCNT_dec(ARG1_SV);
5d9574c1 1162 if (LIKELY(he)) {
03dba561 1163 const SV * const oval = HeVAL(he);
5d9574c1 1164 if (LIKELY(oval && oval != &PL_sv_undef)) {
03dba561 1165 svp = &HeVAL(he);
5d9574c1 1166 if (UNLIKELY(SvTIED_mg((const SV *)ARG2_HV, PERL_MAGIC_tied)))
03dba561
DM
1167 SvREFCNT_inc_void(*svp);
1168 refsv = ARG2_SV; /* what to refcnt_dec */
4e4c362e
GS
1169 goto restore_sv;
1170 }
1171 }
03dba561
DM
1172 SvREFCNT_dec(ARG2_HV);
1173 SvREFCNT_dec(ARG0_SV);
4e4c362e 1174 break;
03dba561 1175 }
462e5cf6 1176 case SAVEt_OP:
03dba561 1177 PL_op = (OP*)ARG0_PTR;
462e5cf6 1178 break;
25eaa213 1179 case SAVEt_HINTS:
3607ca02
FC
1180 if ((PL_hints & HINT_LOCALIZE_HH)) {
1181 while (GvHV(PL_hintgv)) {
2653c1e3 1182 HV *hv = GvHV(PL_hintgv);
045ac317 1183 GvHV(PL_hintgv) = NULL;
2653c1e3 1184 SvREFCNT_dec(MUTABLE_SV(hv));
3607ca02 1185 }
045ac317 1186 }
20439bc7 1187 cophh_free(CopHINTHASH_get(&PL_compiling));
03dba561
DM
1188 CopHINTHASH_set(&PL_compiling, (COPHH*)ARG0_PTR);
1189 *(I32*)&PL_hints = ARG1_I32;
dfa41748 1190 if (PL_hints & HINT_LOCALIZE_HH) {
ad64d0ec 1191 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
85fbaab2 1192 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
2653c1e3
DM
1193 }
1194 if (!GvHV(PL_hintgv)) {
a3fb8386
FC
1195 /* Need to add a new one manually, else rv2hv can
1196 add one via GvHVn and it won't have the magic set. */
5b9c0671
NC
1197 HV *const hv = newHV();
1198 hv_magic(hv, NULL, PERL_MAGIC_hints);
1199 GvHV(PL_hintgv) = hv;
dfa41748 1200 }
5b9c0671 1201 assert(GvHV(PL_hintgv));
b3ac6de7 1202 break;
cb50131a 1203 case SAVEt_COMPPAD:
03dba561 1204 PL_comppad = (PAD*)ARG0_PTR;
5d9574c1 1205 if (LIKELY(PL_comppad))
cb50131a
CB
1206 PL_curpad = AvARRAY(PL_comppad);
1207 else
4608196e 1208 PL_curpad = NULL;
cb50131a 1209 break;
09edbca0 1210 case SAVEt_PADSV_AND_MORTALIZE:
c3564e5c 1211 {
09edbca0 1212 SV **svp;
03dba561
DM
1213 assert (ARG1_PTR);
1214 svp = AvARRAY((PAD*)ARG1_PTR) + (PADOFFSET)arg0.any_uv;
09edbca0
NC
1215 /* This mortalizing used to be done by POPLOOP() via itersave.
1216 But as we have all the information here, we can do it here,
1217 save even having to have itersave in the struct. */
1218 sv_2mortal(*svp);
03dba561 1219 *svp = ARG2_SV;
c3564e5c
GS
1220 }
1221 break;
8b7059b1
DM
1222 case SAVEt_SAVESWITCHSTACK:
1223 {
1224 dSP;
03dba561
DM
1225 SWITCHSTACK(ARG0_AV, ARG1_AV);
1226 PL_curstackinfo->si_stack = ARG1_AV;
8b7059b1
DM
1227 }
1228 break;
14f338dc 1229 case SAVEt_SET_SVFLAGS:
03dba561
DM
1230 SvFLAGS(ARG2_SV) &= ~((U32)ARG1_I32);
1231 SvFLAGS(ARG2_SV) |= (U32)ARG0_I32;
14f338dc 1232 break;
95e06916 1233
95e06916
NC
1234 /* These are only saved in mathoms.c */
1235 case SAVEt_NSTAB:
03dba561 1236 (void)sv_clear(ARG0_SV);
95e06916 1237 break;
2053acbf 1238 case SAVEt_LONG: /* long reference */
03dba561 1239 *(long*)ARG0_PTR = arg1.any_long;
2053acbf 1240 break;
95e06916 1241 case SAVEt_IV: /* IV reference */
03dba561 1242 *(IV*)ARG0_PTR = arg1.any_iv;
95e06916
NC
1243 break;
1244
2053acbf 1245 case SAVEt_I16: /* I16 reference */
03dba561 1246 *(I16*)ARG0_PTR = (I16)(uv >> 8);
2053acbf
NC
1247 break;
1248 case SAVEt_I8: /* I8 reference */
03dba561 1249 *(I8*)ARG0_PTR = (I8)(uv >> 8);
2053acbf 1250 break;
2053acbf 1251 case SAVEt_DESTRUCTOR:
03dba561 1252 (*arg1.any_dptr)(ARG0_PTR);
2053acbf 1253 break;
68da3b2f 1254 case SAVEt_COMPILE_WARNINGS:
68da3b2f
NC
1255 if (!specialWARN(PL_compiling.cop_warnings))
1256 PerlMemShared_free(PL_compiling.cop_warnings);
72dc9ed5 1257
03dba561 1258 PL_compiling.cop_warnings = (STRLEN*)ARG0_PTR;
72dc9ed5 1259 break;
7c197c94 1260 case SAVEt_PARSER:
03dba561 1261 parser_free((yy_parser *) ARG0_PTR);
7c197c94 1262 break;
20d5dc23
FC
1263 case SAVEt_READONLY_OFF:
1264 SvREADONLY_off(ARG0_SV);
1265 break;
79072805 1266 default:
5637ef5b 1267 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
79072805
LW
1268 }
1269 }
302c0c93 1270
284167a5 1271 TAINT_set(was);
79072805 1272}
8990e307 1273
8990e307 1274void
864dbfa3 1275Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
8990e307 1276{
7918f24d
NC
1277 PERL_ARGS_ASSERT_CX_DUMP;
1278
35ff7856 1279#ifdef DEBUGGING
22c35a8c 1280 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
6b35e009 1281 if (CxTYPE(cx) != CXt_SUBST) {
e8d9e9d0 1282 const char *gimme_text;
760ac839 1283 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
146174a9
CB
1284 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1285 PTR2UV(cx->blk_oldcop));
760ac839
LW
1286 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1287 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
146174a9
CB
1288 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1289 PTR2UV(cx->blk_oldpm));
e8d9e9d0
VP
1290 switch (cx->blk_gimme) {
1291 case G_VOID:
1292 gimme_text = "VOID";
1293 break;
1294 case G_SCALAR:
1295 gimme_text = "SCALAR";
1296 break;
1297 case G_ARRAY:
1298 gimme_text = "LIST";
1299 break;
1300 default:
1301 gimme_text = "UNKNOWN";
1302 break;
1303 }
1304 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
8990e307 1305 }
6b35e009 1306 switch (CxTYPE(cx)) {
8990e307
LW
1307 case CXt_NULL:
1308 case CXt_BLOCK:
1309 break;
146174a9 1310 case CXt_FORMAT:
f9c764c5
NC
1311 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1312 PTR2UV(cx->blk_format.cv));
1313 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1314 PTR2UV(cx->blk_format.gv));
1315 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1316 PTR2UV(cx->blk_format.dfoutgv));
1317 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
bafb2adc 1318 (int)CxHASARGS(cx));
f9c764c5
NC
1319 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1320 PTR2UV(cx->blk_format.retop));
146174a9 1321 break;
8990e307 1322 case CXt_SUB:
146174a9
CB
1323 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1324 PTR2UV(cx->blk_sub.cv));
760ac839 1325 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
8990e307 1326 (long)cx->blk_sub.olddepth);
760ac839 1327 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
bafb2adc
NC
1328 (int)CxHASARGS(cx));
1329 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
f39bc417
DM
1330 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1331 PTR2UV(cx->blk_sub.retop));
8990e307
LW
1332 break;
1333 case CXt_EVAL:
760ac839 1334 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
85a64632 1335 (long)CxOLD_IN_EVAL(cx));
760ac839 1336 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
85a64632
NC
1337 PL_op_name[CxOLD_OP_TYPE(cx)],
1338 PL_op_desc[CxOLD_OP_TYPE(cx)]);
0f79a09d
GS
1339 if (cx->blk_eval.old_namesv)
1340 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
aa07b2f6 1341 SvPVX_const(cx->blk_eval.old_namesv));
146174a9
CB
1342 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1343 PTR2UV(cx->blk_eval.old_eval_root));
f39bc417
DM
1344 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1345 PTR2UV(cx->blk_eval.retop));
8990e307
LW
1346 break;
1347
c6fdafd0 1348 case CXt_LOOP_LAZYIV:
d01136d6 1349 case CXt_LOOP_LAZYSV:
3b719c58
NC
1350 case CXt_LOOP_FOR:
1351 case CXt_LOOP_PLAIN:
0cbdab38 1352 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
760ac839 1353 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
8990e307 1354 (long)cx->blk_loop.resetsp);
022eaa24
NC
1355 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1356 PTR2UV(cx->blk_loop.my_op));
d01136d6 1357 /* XXX: not accurate for LAZYSV/IV */
146174a9 1358 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
d01136d6
BS
1359 PTR2UV(cx->blk_loop.state_u.ary.ary));
1360 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1361 (long)cx->blk_loop.state_u.ary.ix);
146174a9
CB
1362 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1363 PTR2UV(CxITERVAR(cx)));
8990e307
LW
1364 break;
1365
1366 case CXt_SUBST:
760ac839 1367 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
8990e307 1368 (long)cx->sb_iters);
760ac839 1369 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
8990e307 1370 (long)cx->sb_maxiters);
35ef4773
GS
1371 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1372 (long)cx->sb_rflags);
760ac839 1373 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
c5bed6a7 1374 (long)CxONCE(cx));
760ac839 1375 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
8990e307 1376 cx->sb_orig);
146174a9
CB
1377 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1378 PTR2UV(cx->sb_dstr));
1379 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1380 PTR2UV(cx->sb_targ));
1381 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1382 PTR2UV(cx->sb_s));
1383 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1384 PTR2UV(cx->sb_m));
1385 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1386 PTR2UV(cx->sb_strend));
1387 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1388 PTR2UV(cx->sb_rxres));
8990e307
LW
1389 break;
1390 }
65e66c80 1391#else
96a5add6 1392 PERL_UNUSED_CONTEXT;
65e66c80 1393 PERL_UNUSED_ARG(cx);
17c3b450 1394#endif /* DEBUGGING */
35ff7856 1395}
241d1a3b
NC
1396
1397/*
14d04a33 1398 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1399 */