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