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