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