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