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