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