This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert all the scope save functions of the form
[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);
c09156bb 80 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
9965345d
JH
81 /* Without any kind of initialising deep enough recursion
82 * will end up reading uninitialised PERL_CONTEXTs. */
7e337ee0 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);
79072805 94 }
3280af22 95 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
79072805
LW
96
97}
98
99void
864dbfa3 100Perl_pop_scope(pTHX)
79072805 101{
97aff369 102 dVAR;
35a4481c 103 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
8990e307 104 LEAVE_SCOPE(oldsave);
79072805
LW
105}
106
107void
864dbfa3 108Perl_markstack_grow(pTHX)
a0d0e21e 109{
97aff369 110 dVAR;
35a4481c
AL
111 const I32 oldmax = PL_markstack_max - PL_markstack;
112 const I32 newmax = GROW(oldmax);
a0d0e21e 113
3280af22
NIS
114 Renew(PL_markstack, newmax, I32);
115 PL_markstack_ptr = PL_markstack + oldmax;
116 PL_markstack_max = PL_markstack + newmax;
a0d0e21e
LW
117}
118
119void
864dbfa3 120Perl_savestack_grow(pTHX)
79072805 121{
97aff369 122 dVAR;
8aacddc1 123 PL_savestack_max = GROW(PL_savestack_max) + 4;
3280af22 124 Renew(PL_savestack, PL_savestack_max, ANY);
79072805
LW
125}
126
4b3c1a47
AE
127void
128Perl_savestack_grow_cnt(pTHX_ I32 need)
129{
97aff369 130 dVAR;
4b3c1a47
AE
131 PL_savestack_max = PL_savestack_ix + need;
132 Renew(PL_savestack, PL_savestack_max, ANY);
133}
134
2ce36478
SM
135#undef GROW
136
79072805 137void
864dbfa3 138Perl_tmps_grow(pTHX_ I32 n)
677b06e3 139{
97aff369 140 dVAR;
677b06e3
GS
141#ifndef STRESS_REALLOC
142 if (n < 128)
143 n = (PL_tmps_max < 512) ? 128 : 512;
144#endif
145 PL_tmps_max = PL_tmps_ix + n + 1;
146 Renew(PL_tmps_stack, PL_tmps_max, SV*);
147}
148
149
150void
864dbfa3 151Perl_free_tmps(pTHX)
79072805 152{
97aff369 153 dVAR;
79072805 154 /* XXX should tmps_floor live in cxstack? */
35a4481c 155 const I32 myfloor = PL_tmps_floor;
3280af22 156 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
901017d6 157 SV* const sv = PL_tmps_stack[PL_tmps_ix];
a0714e2c 158 PL_tmps_stack[PL_tmps_ix--] = NULL;
8aacddc1 159 if (sv && sv != &PL_sv_undef) {
463ee0b2 160 SvTEMP_off(sv);
8990e307 161 SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
463ee0b2 162 }
79072805
LW
163 }
164}
165
76e3520e 166STATIC SV *
af7df257 167S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
79072805 168{
97aff369 169 dVAR;
901017d6 170 SV * const osv = *sptr;
561b68a9 171 register SV * const sv = *sptr = newSV(0);
79072805 172
7918f24d
NC
173 PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
174
a0d0e21e 175 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
a0d0e21e 176 if (SvGMAGICAL(osv)) {
35a4481c 177 const bool oldtainted = PL_tainted;
a0d0e21e 178 SvFLAGS(osv) |= (SvFLAGS(osv) &
c268c2a6 179 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3280af22 180 PL_tainted = oldtainted;
a0d0e21e 181 }
af7df257 182 mg_localize(osv, sv, (flags & SAVEf_SETMAGIC) != 0);
79072805
LW
183 }
184 return sv;
185}
186
7a4c00b4 187SV *
864dbfa3 188Perl_save_scalar(pTHX_ GV *gv)
7a4c00b4 189{
97aff369 190 dVAR;
fb4fc1fa 191 SV ** const sptr = &GvSVn(gv);
7918f24d
NC
192
193 PERL_ARGS_ASSERT_SAVE_SCALAR;
194
27cc343c 195 PL_localizing = 1;
0cbee0a4 196 SvGETMAGIC(*sptr);
27cc343c 197 PL_localizing = 0;
7a4c00b4 198 SSCHECK(3);
b37c2d43 199 SSPUSHPTR(SvREFCNT_inc_simple(gv));
4e4c362e 200 SSPUSHPTR(SvREFCNT_inc(*sptr));
7a4c00b4 201 SSPUSHINT(SAVEt_SV);
af7df257 202 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
7a4c00b4
PP
203}
204
f4dd75d9 205/* Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
b9d12d37
GS
206 * restore a global SV to its prior contents, freeing new value. */
207void
864dbfa3 208Perl_save_generic_svref(pTHX_ SV **sptr)
b9d12d37 209{
97aff369 210 dVAR;
7918f24d
NC
211
212 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
213
b9d12d37
GS
214 SSCHECK(3);
215 SSPUSHPTR(sptr);
216 SSPUSHPTR(SvREFCNT_inc(*sptr));
217 SSPUSHINT(SAVEt_GENERIC_SVREF);
218}
219
f4dd75d9
GS
220/* Like save_pptr(), but also Safefree()s the new value if it is different
221 * from the old one. Can be used to restore a global char* to its prior
222 * contents, freeing new value. */
223void
224Perl_save_generic_pvref(pTHX_ char **str)
225{
97aff369 226 dVAR;
7918f24d
NC
227
228 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
229
f4dd75d9 230 SSCHECK(3);
f4dd75d9 231 SSPUSHPTR(*str);
b03d03b0 232 SSPUSHPTR(str);
f4dd75d9
GS
233 SSPUSHINT(SAVEt_GENERIC_PVREF);
234}
235
05ec9bb3
NIS
236/* Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
237 * Can be used to restore a shared global char* to its prior
238 * contents, freeing new value. */
239void
240Perl_save_shared_pvref(pTHX_ char **str)
241{
97aff369 242 dVAR;
7918f24d
NC
243
244 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
245
05ec9bb3
NIS
246 SSCHECK(3);
247 SSPUSHPTR(str);
248 SSPUSHPTR(*str);
249 SSPUSHINT(SAVEt_SHARED_PVREF);
250}
251
14f338dc
DM
252/* set the SvFLAGS specified by mask to the values in val */
253
254void
255Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
256{
97aff369 257 dVAR;
7918f24d
NC
258
259 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
260
14f338dc
DM
261 SSCHECK(4);
262 SSPUSHPTR(sv);
263 SSPUSHINT(mask);
264 SSPUSHINT(val);
265 SSPUSHINT(SAVEt_SET_SVFLAGS);
266}
267
79072805 268void
864dbfa3 269Perl_save_gp(pTHX_ GV *gv, I32 empty)
79072805 270{
97aff369 271 dVAR;
7918f24d
NC
272
273 PERL_ARGS_ASSERT_SAVE_GP;
274
576df6af 275 SSGROW(3);
4633a7c4 276 SSPUSHPTR(SvREFCNT_inc(gv));
5f05dabc 277 SSPUSHPTR(GvGP(gv));
79072805
LW
278 SSPUSHINT(SAVEt_GP);
279
5f05dabc 280 if (empty) {
12816592 281 GP *gp = Perl_newGP(aTHX_ gv);
146174a9 282
fae75791 283 if (GvCVu(gv))
e1a479c5 284 mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
146174a9
CB
285 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
286 gp->gp_io = newIO();
287 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
288 }
72651472
NC
289#ifdef PERL_DONT_CREATE_GVSV
290 if (gv == PL_errgv) {
291 /* We could scatter this logic everywhere by changing the
292 definition of ERRSV from GvSV() to GvSVn(), but it seems more
293 efficient to do this check once here. */
294 gp->gp_sv = newSV(0);
295 }
296#endif
12816592 297 GvGP(gv) = gp;
5f05dabc
PP
298 }
299 else {
44a8e56a 300 gp_ref(GvGP(gv));
5f05dabc
PP
301 GvINTRO_on(gv);
302 }
79072805 303}
79072805 304
79072805 305AV *
864dbfa3 306Perl_save_ary(pTHX_ GV *gv)
79072805 307{
97aff369 308 dVAR;
901017d6 309 AV * const oav = GvAVn(gv);
67a38de0 310 AV *av;
fb73857a 311
7918f24d
NC
312 PERL_ARGS_ASSERT_SAVE_ARY;
313
67a38de0
NIS
314 if (!AvREAL(oav) && AvREIFY(oav))
315 av_reify(oav);
79072805
LW
316 SSCHECK(3);
317 SSPUSHPTR(gv);
67a38de0 318 SSPUSHPTR(oav);
79072805
LW
319 SSPUSHINT(SAVEt_AV);
320
4608196e 321 GvAV(gv) = NULL;
fb73857a 322 av = GvAVn(gv);
0cbee0a4 323 if (SvMAGIC(oav))
9711599e 324 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
fb73857a 325 return av;
79072805
LW
326}
327
328HV *
864dbfa3 329Perl_save_hash(pTHX_ GV *gv)
79072805 330{
97aff369 331 dVAR;
fb73857a
PP
332 HV *ohv, *hv;
333
7918f24d
NC
334 PERL_ARGS_ASSERT_SAVE_HASH;
335
79072805
LW
336 SSCHECK(3);
337 SSPUSHPTR(gv);
fb73857a 338 SSPUSHPTR(ohv = GvHVn(gv));
79072805
LW
339 SSPUSHINT(SAVEt_HV);
340
4608196e 341 GvHV(gv) = NULL;
fb73857a 342 hv = GvHVn(gv);
0cbee0a4 343 if (SvMAGIC(ohv))
9711599e 344 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
fb73857a 345 return hv;
79072805
LW
346}
347
348void
864dbfa3 349Perl_save_item(pTHX_ register SV *item)
79072805 350{
97aff369 351 dVAR;
901017d6 352 register SV * const sv = newSVsv(item);
79072805 353
7918f24d
NC
354 PERL_ARGS_ASSERT_SAVE_ITEM;
355
79072805
LW
356 SSCHECK(3);
357 SSPUSHPTR(item); /* remember the pointer */
79072805
LW
358 SSPUSHPTR(sv); /* remember the value */
359 SSPUSHINT(SAVEt_ITEM);
360}
361
362void
864dbfa3 363Perl_save_int(pTHX_ int *intp)
79072805 364{
97aff369 365 dVAR;
7918f24d
NC
366
367 PERL_ARGS_ASSERT_SAVE_INT;
368
79072805
LW
369 SSCHECK(3);
370 SSPUSHINT(*intp);
371 SSPUSHPTR(intp);
372 SSPUSHINT(SAVEt_INT);
373}
374
375void
9febdf04
RH
376Perl_save_bool(pTHX_ bool *boolp)
377{
97aff369 378 dVAR;
7918f24d
NC
379
380 PERL_ARGS_ASSERT_SAVE_BOOL;
381
9febdf04
RH
382 SSCHECK(3);
383 SSPUSHBOOL(*boolp);
384 SSPUSHPTR(boolp);
385 SSPUSHINT(SAVEt_BOOL);
386}
387
388void
58188858
RGS
389Perl_save_I8(pTHX_ I8 *bytep)
390{
391 dVAR;
7918f24d
NC
392
393 PERL_ARGS_ASSERT_SAVE_I8;
394
58188858
RGS
395 SSCHECK(3);
396 SSPUSHINT(*bytep);
397 SSPUSHPTR(bytep);
398 SSPUSHINT(SAVEt_I8);
399}
400
401void
87a84751
JH
402Perl_save_I16(pTHX_ I16 *intp)
403{
404 dVAR;
7918f24d
NC
405
406 PERL_ARGS_ASSERT_SAVE_I16;
407
87a84751
JH
408 SSCHECK(3);
409 SSPUSHINT(*intp);
410 SSPUSHPTR(intp);
411 SSPUSHINT(SAVEt_I16);
412}
413
414void
864dbfa3 415Perl_save_I32(pTHX_ I32 *intp)
79072805 416{
97aff369 417 dVAR;
7918f24d
NC
418
419 PERL_ARGS_ASSERT_SAVE_I32;
420
79072805
LW
421 SSCHECK(3);
422 SSPUSHINT(*intp);
423 SSPUSHPTR(intp);
424 SSPUSHINT(SAVEt_I32);
425}
426
85e6fe83
LW
427/* Cannot use save_sptr() to store a char* since the SV** cast will
428 * force word-alignment and we'll miss the pointer.
429 */
430void
864dbfa3 431Perl_save_pptr(pTHX_ char **pptr)
85e6fe83 432{
97aff369 433 dVAR;
7918f24d
NC
434
435 PERL_ARGS_ASSERT_SAVE_PPTR;
436
85e6fe83
LW
437 SSCHECK(3);
438 SSPUSHPTR(*pptr);
439 SSPUSHPTR(pptr);
440 SSPUSHINT(SAVEt_PPTR);
441}
442
79072805 443void
146174a9
CB
444Perl_save_vptr(pTHX_ void *ptr)
445{
97aff369 446 dVAR;
7918f24d
NC
447
448 PERL_ARGS_ASSERT_SAVE_VPTR;
449
146174a9
CB
450 SSCHECK(3);
451 SSPUSHPTR(*(char**)ptr);
452 SSPUSHPTR(ptr);
453 SSPUSHINT(SAVEt_VPTR);
454}
455
456void
864dbfa3 457Perl_save_sptr(pTHX_ SV **sptr)
79072805 458{
97aff369 459 dVAR;
7918f24d
NC
460
461 PERL_ARGS_ASSERT_SAVE_SPTR;
462
79072805
LW
463 SSCHECK(3);
464 SSPUSHPTR(*sptr);
465 SSPUSHPTR(sptr);
466 SSPUSHINT(SAVEt_SPTR);
467}
468
c3564e5c 469void
09edbca0 470Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
c3564e5c 471{
97aff369 472 dVAR;
c3564e5c 473 SSCHECK(4);
f3548bdc 474 ASSERT_CURPAD_ACTIVE("save_padsv");
09edbca0 475 SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
f3548bdc 476 SSPUSHPTR(PL_comppad);
c3564e5c 477 SSPUSHLONG((long)off);
09edbca0 478 SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE);
c3564e5c
GS
479}
480
79072805 481void
864dbfa3 482Perl_save_hptr(pTHX_ HV **hptr)
79072805 483{
97aff369 484 dVAR;
7918f24d
NC
485
486 PERL_ARGS_ASSERT_SAVE_HPTR;
487
79072805 488 SSCHECK(3);
85e6fe83 489 SSPUSHPTR(*hptr);
79072805
LW
490 SSPUSHPTR(hptr);
491 SSPUSHINT(SAVEt_HPTR);
492}
493
494void
864dbfa3 495Perl_save_aptr(pTHX_ AV **aptr)
79072805 496{
97aff369 497 dVAR;
7918f24d
NC
498
499 PERL_ARGS_ASSERT_SAVE_APTR;
500
79072805 501 SSCHECK(3);
85e6fe83 502 SSPUSHPTR(*aptr);
79072805
LW
503 SSPUSHPTR(aptr);
504 SSPUSHINT(SAVEt_APTR);
505}
506
507void
2fd8beea 508Perl_save_pushptr(pTHX_ void *const ptr, const int type)
8990e307 509{
97aff369 510 dVAR;
8990e307 511 SSCHECK(2);
2fd8beea
NC
512 SSPUSHPTR(ptr);
513 SSPUSHINT(type);
8990e307
LW
514}
515
516void
864dbfa3 517Perl_save_clearsv(pTHX_ SV **svp)
8990e307 518{
97aff369 519 dVAR;
7918f24d
NC
520
521 PERL_ARGS_ASSERT_SAVE_CLEARSV;
522
f3548bdc 523 ASSERT_CURPAD_ACTIVE("save_clearsv");
8990e307 524 SSCHECK(2);
3280af22 525 SSPUSHLONG((long)(svp-PL_curpad));
8990e307 526 SSPUSHINT(SAVEt_CLEARSV);
d9d18af6 527 SvPADSTALE_off(*svp); /* mark lexical as active */
8990e307
LW
528}
529
530void
864dbfa3 531Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
8990e307 532{
97aff369 533 dVAR;
7918f24d
NC
534
535 PERL_ARGS_ASSERT_SAVE_DELETE;
536
8990e307
LW
537 SSCHECK(4);
538 SSPUSHINT(klen);
539 SSPUSHPTR(key);
b37c2d43 540 SSPUSHPTR(SvREFCNT_inc_simple(hv));
8990e307
LW
541 SSPUSHINT(SAVEt_DELETE);
542}
543
544void
12ab1f58
JH
545Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
546{
547 dVAR;
7918f24d
NC
548
549 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
550
12ab1f58
JH
551 SSCHECK(3);
552 SSPUSHDPTR(f);
553 SSPUSHPTR(p);
554 SSPUSHINT(SAVEt_DESTRUCTOR);
555}
556
557void
146174a9
CB
558Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
559{
97aff369 560 dVAR;
146174a9
CB
561 SSCHECK(3);
562 SSPUSHDXPTR(f);
563 SSPUSHPTR(p);
564 SSPUSHINT(SAVEt_DESTRUCTOR_X);
565}
566
567void
59413342 568Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
4e4c362e 569{
97aff369 570 dVAR;
bfc4de9f 571 SV *sv;
7918f24d
NC
572
573 PERL_ARGS_ASSERT_SAVE_AELEM;
574
0cbee0a4 575 SvGETMAGIC(*sptr);
4e4c362e 576 SSCHECK(4);
b37c2d43 577 SSPUSHPTR(SvREFCNT_inc_simple(av));
4e4c362e
GS
578 SSPUSHINT(idx);
579 SSPUSHPTR(SvREFCNT_inc(*sptr));
580 SSPUSHINT(SAVEt_AELEM);
5dd42e15
DM
581 /* if it gets reified later, the restore will have the wrong refcnt */
582 if (!AvREAL(av) && AvREIFY(av))
b37c2d43 583 SvREFCNT_inc_void(*sptr);
af7df257 584 save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
bfc4de9f
DM
585 sv = *sptr;
586 /* If we're localizing a tied array element, this new sv
587 * won't actually be stored in the array - so it won't get
588 * reaped when the localize ends. Ensure it gets reaped by
589 * mortifying it instead. DAPM */
590 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
591 sv_2mortal(sv);
4e4c362e
GS
592}
593
594void
af7df257 595Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
4e4c362e 596{
97aff369 597 dVAR;
bfc4de9f 598 SV *sv;
7918f24d 599
af7df257 600 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
7918f24d 601
0cbee0a4 602 SvGETMAGIC(*sptr);
4e4c362e 603 SSCHECK(4);
b37c2d43 604 SSPUSHPTR(SvREFCNT_inc_simple(hv));
b2096149 605 SSPUSHPTR(newSVsv(key));
4e4c362e
GS
606 SSPUSHPTR(SvREFCNT_inc(*sptr));
607 SSPUSHINT(SAVEt_HELEM);
af7df257 608 save_scalar_at(sptr, flags);
bfc4de9f
DM
609 sv = *sptr;
610 /* If we're localizing a tied hash element, this new sv
611 * won't actually be stored in the hash - so it won't get
612 * reaped when the localize ends. Ensure it gets reaped by
613 * mortifying it instead. DAPM */
614 if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
615 sv_2mortal(sv);
4e4c362e
GS
616}
617
2053acbf
NC
618SV*
619Perl_save_svref(pTHX_ SV **sptr)
620{
621 dVAR;
7918f24d
NC
622
623 PERL_ARGS_ASSERT_SAVE_SVREF;
624
2053acbf
NC
625 SvGETMAGIC(*sptr);
626 SSCHECK(3);
627 SSPUSHPTR(sptr);
628 SSPUSHPTR(SvREFCNT_inc(*sptr));
629 SSPUSHINT(SAVEt_SVREF);
af7df257 630 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
2053acbf
NC
631}
632
455ece5e 633I32
864dbfa3 634Perl_save_alloc(pTHX_ I32 size, I32 pad)
455ece5e 635{
97aff369 636 dVAR;
35a4481c 637 register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
8aacddc1 638 - (char*)PL_savestack);
35a4481c 639 register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
455ece5e 640
1bb4c835 641 SSGROW(elems + 2);
455ece5e
AD
642
643 PL_savestack_ix += elems;
644 SSPUSHINT(elems);
645 SSPUSHINT(SAVEt_ALLOC);
646 return start;
647}
648
462e5cf6 649void
864dbfa3 650Perl_leave_scope(pTHX_ I32 base)
79072805 651{
97aff369 652 dVAR;
79072805
LW
653 register SV *sv;
654 register SV *value;
655 register GV *gv;
656 register AV *av;
657 register HV *hv;
20454177 658 void* ptr;
f4dd75d9 659 register char* str;
161b7d16 660 I32 i;
79072805
LW
661
662 if (base < -1)
cea2e8a9 663 Perl_croak(aTHX_ "panic: corrupt saved stack index");
3280af22 664 while (PL_savestack_ix > base) {
c6ae7647
NC
665 TAINT_NOT;
666
79072805
LW
667 switch (SSPOPINT) {
668 case SAVEt_ITEM: /* normal string */
ad64d0ec
NC
669 value = MUTABLE_SV(SSPOPPTR);
670 sv = MUTABLE_SV(SSPOPPTR);
79072805 671 sv_replace(sv,value);
3280af22 672 PL_localizing = 2;
79072805 673 SvSETMAGIC(sv);
3280af22 674 PL_localizing = 0;
79072805 675 break;
8aacddc1 676 case SAVEt_SV: /* scalar reference */
ad64d0ec 677 value = MUTABLE_SV(SSPOPPTR);
159b6efe 678 gv = MUTABLE_GV(SSPOPPTR);
7a4c00b4 679 ptr = &GvSV(gv);
502c6561 680 av = MUTABLE_AV(gv); /* what to refcnt_dec */
2053acbf
NC
681 restore_sv:
682 sv = *(SV**)ptr;
2053acbf
NC
683 *(SV**)ptr = value;
684 SvREFCNT_dec(sv);
685 PL_localizing = 2;
686 SvSETMAGIC(value);
687 PL_localizing = 0;
688 SvREFCNT_dec(value);
689 if (av) /* actually an av, hv or gv */
690 SvREFCNT_dec(av);
691 break;
8aacddc1 692 case SAVEt_GENERIC_PVREF: /* generic pv */
f4dd75d9 693 ptr = SSPOPPTR;
b03d03b0 694 str = (char*)SSPOPPTR;
f4dd75d9
GS
695 if (*(char**)ptr != str) {
696 Safefree(*(char**)ptr);
697 *(char**)ptr = str;
698 }
699 break;
05ec9bb3
NIS
700 case SAVEt_SHARED_PVREF: /* shared pv */
701 str = (char*)SSPOPPTR;
702 ptr = SSPOPPTR;
703 if (*(char**)ptr != str) {
5e54c26f 704#ifdef NETWARE
9ecbcc42 705 PerlMem_free(*(char**)ptr);
5e54c26f 706#else
05ec9bb3 707 PerlMemShared_free(*(char**)ptr);
5e54c26f 708#endif
05ec9bb3
NIS
709 *(char**)ptr = str;
710 }
711 break;
8aacddc1 712 case SAVEt_GENERIC_SVREF: /* generic sv */
ad64d0ec 713 value = MUTABLE_SV(SSPOPPTR);
b9d12d37 714 ptr = SSPOPPTR;
f4dd75d9
GS
715 sv = *(SV**)ptr;
716 *(SV**)ptr = value;
717 SvREFCNT_dec(sv);
b9d12d37
GS
718 SvREFCNT_dec(value);
719 break;
8aacddc1 720 case SAVEt_AV: /* array reference */
502c6561 721 av = MUTABLE_AV(SSPOPPTR);
159b6efe 722 gv = MUTABLE_GV(SSPOPPTR);
fb73857a 723 if (GvAV(gv)) {
c4a7531d 724 SvREFCNT_dec(GvAV(gv));
fb73857a 725 }
8aacddc1 726 GvAV(gv) = av;
fb73857a 727 if (SvMAGICAL(av)) {
3280af22 728 PL_localizing = 2;
ad64d0ec 729 SvSETMAGIC(MUTABLE_SV(av));
3280af22 730 PL_localizing = 0;
fb73857a 731 }
8aacddc1
NIS
732 break;
733 case SAVEt_HV: /* hash reference */
85fbaab2 734 hv = MUTABLE_HV(SSPOPPTR);
159b6efe 735 gv = MUTABLE_GV(SSPOPPTR);
fb73857a 736 if (GvHV(gv)) {
c4a7531d 737 SvREFCNT_dec(GvHV(gv));
fb73857a 738 }
8aacddc1 739 GvHV(gv) = hv;
fb73857a 740 if (SvMAGICAL(hv)) {
3280af22 741 PL_localizing = 2;
ad64d0ec 742 SvSETMAGIC(MUTABLE_SV(hv));
3280af22 743 PL_localizing = 0;
fb73857a 744 }
8aacddc1 745 break;
79072805
LW
746 case SAVEt_INT: /* int reference */
747 ptr = SSPOPPTR;
748 *(int*)ptr = (int)SSPOPINT;
749 break;
9febdf04
RH
750 case SAVEt_BOOL: /* bool reference */
751 ptr = SSPOPPTR;
752 *(bool*)ptr = (bool)SSPOPBOOL;
753 break;
79072805
LW
754 case SAVEt_I32: /* I32 reference */
755 ptr = SSPOPPTR;
3235b7a3
NC
756#ifdef PERL_DEBUG_READONLY_OPS
757 {
758 const I32 val = SSPOPINT;
759 if (*(I32*)ptr != val)
760 *(I32*)ptr = val;
761 }
762#else
79072805 763 *(I32*)ptr = (I32)SSPOPINT;
3235b7a3 764#endif
79072805
LW
765 break;
766 case SAVEt_SPTR: /* SV* reference */
767 ptr = SSPOPPTR;
ad64d0ec 768 *(SV**)ptr = MUTABLE_SV(SSPOPPTR);
79072805 769 break;
146174a9 770 case SAVEt_VPTR: /* random* reference */
85e6fe83
LW
771 case SAVEt_PPTR: /* char* reference */
772 ptr = SSPOPPTR;
773 *(char**)ptr = (char*)SSPOPPTR;
774 break;
79072805
LW
775 case SAVEt_HPTR: /* HV* reference */
776 ptr = SSPOPPTR;
85fbaab2 777 *(HV**)ptr = MUTABLE_HV(SSPOPPTR);
79072805
LW
778 break;
779 case SAVEt_APTR: /* AV* reference */
780 ptr = SSPOPPTR;
502c6561 781 *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
79072805 782 break;
fb73857a 783 case SAVEt_GP: /* scalar reference */
79072805 784 ptr = SSPOPPTR;
159b6efe 785 gv = MUTABLE_GV(SSPOPPTR);
8aacddc1
NIS
786 gp_free(gv);
787 GvGP(gv) = (GP*)ptr;
dd69841b
BB
788 /* putting a method back into circulation ("local")*/
789 if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
790 mro_method_changed_in(hv);
4633a7c4 791 SvREFCNT_dec(gv);
8aacddc1 792 break;
8990e307
LW
793 case SAVEt_FREESV:
794 ptr = SSPOPPTR;
ad64d0ec 795 SvREFCNT_dec(MUTABLE_SV(ptr));
8990e307 796 break;
26d9b02f
JH
797 case SAVEt_MORTALIZESV:
798 ptr = SSPOPPTR;
ad64d0ec 799 sv_2mortal(MUTABLE_SV(ptr));
26d9b02f 800 break;
8990e307
LW
801 case SAVEt_FREEOP:
802 ptr = SSPOPPTR;
f3548bdc 803 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
8990e307
LW
804 op_free((OP*)ptr);
805 break;
806 case SAVEt_FREEPV:
807 ptr = SSPOPPTR;
1df70142 808 Safefree(ptr);
8990e307
LW
809 break;
810 case SAVEt_CLEARSV:
3280af22 811 ptr = (void*)&PL_curpad[SSPOPLONG];
8990e307 812 sv = *(SV**)ptr;
dd2155a4
DM
813
814 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
f3548bdc
DM
815 "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
816 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
817 (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
dd2155a4
DM
818 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
819 ));
820
bc44cdaf
GS
821 /* Can clear pad variable in place? */
822 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
8aacddc1
NIS
823 /*
824 * if a my variable that was made readonly is going out of
825 * scope, we want to remove the readonlyness so that it can
826 * go out of scope quietly
8aacddc1 827 */
a26e96df 828 if (SvPADMY(sv) && !SvFAKE(sv))
8aacddc1
NIS
829 SvREADONLY_off(sv);
830
6fc92669 831 if (SvTHINKFIRST(sv))
840a7b70 832 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
a0d0e21e
LW
833 if (SvMAGICAL(sv))
834 mg_free(sv);
8990e307
LW
835
836 switch (SvTYPE(sv)) {
837 case SVt_NULL:
838 break;
839 case SVt_PVAV:
502c6561 840 av_clear(MUTABLE_AV(sv));
8990e307
LW
841 break;
842 case SVt_PVHV:
85fbaab2 843 hv_clear(MUTABLE_HV(sv));
8990e307
LW
844 break;
845 case SVt_PVCV:
cea2e8a9 846 Perl_croak(aTHX_ "panic: leave_scope pad code");
8990e307 847 default:
0c34ef67 848 SvOK_off(sv);
8990e307
LW
849 break;
850 }
d9d18af6 851 SvPADSTALE_on(sv); /* mark as no longer live */
8990e307
LW
852 }
853 else { /* Someone has a claim on this, so abandon it. */
35a4481c 854 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
8990e307 855 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
ad64d0ec
NC
856 case SVt_PVAV: *(SV**)ptr = MUTABLE_SV(newAV()); break;
857 case SVt_PVHV: *(SV**)ptr = MUTABLE_SV(newHV()); break;
561b68a9 858 default: *(SV**)ptr = newSV(0); break;
8990e307 859 }
53868620 860 SvREFCNT_dec(sv); /* Cast current value to the winds. */
d9d18af6
DM
861 /* preserve pad nature, but also mark as not live
862 * for any closure capturing */
2740392c 863 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
8990e307
LW
864 }
865 break;
866 case SAVEt_DELETE:
867 ptr = SSPOPPTR;
85fbaab2 868 hv = MUTABLE_HV(ptr);
8990e307 869 ptr = SSPOPPTR;
7d654f43 870 (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
4e4c362e 871 SvREFCNT_dec(hv);
8aacddc1 872 Safefree(ptr);
8990e307 873 break;
146174a9
CB
874 case SAVEt_DESTRUCTOR_X:
875 ptr = SSPOPPTR;
acfe0abc 876 (*SSPOPDXPTR)(aTHX_ ptr);
a0d0e21e
LW
877 break;
878 case SAVEt_REGCONTEXT:
455ece5e 879 case SAVEt_ALLOC:
161b7d16 880 i = SSPOPINT;
3280af22 881 PL_savestack_ix -= i; /* regexp must have croaked */
a0d0e21e 882 break;
55497cff 883 case SAVEt_STACK_POS: /* Position on Perl stack */
161b7d16 884 i = SSPOPINT;
3280af22 885 PL_stack_sp = PL_stack_base + i;
55497cff 886 break;
ea8d6ae1
DB
887 case SAVEt_STACK_CXPOS: /* blk_oldsp on context stack */
888 i = SSPOPINT;
889 cxstack[i].blk_oldsp = SSPOPINT;
890 break;
161b7d16 891 case SAVEt_AELEM: /* array element */
ad64d0ec 892 value = MUTABLE_SV(SSPOPPTR);
161b7d16 893 i = SSPOPINT;
502c6561 894 av = MUTABLE_AV(SSPOPPTR);
658aef79 895 ptr = av_fetch(av,i,1);
5dd42e15
DM
896 if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
897 SvREFCNT_dec(value);
4e4c362e
GS
898 if (ptr) {
899 sv = *(SV**)ptr;
3280af22 900 if (sv && sv != &PL_sv_undef) {
ad64d0ec 901 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
b37c2d43 902 SvREFCNT_inc_void_NN(sv);
4e4c362e
GS
903 goto restore_sv;
904 }
905 }
906 SvREFCNT_dec(av);
907 SvREFCNT_dec(value);
908 break;
161b7d16 909 case SAVEt_HELEM: /* hash element */
ad64d0ec
NC
910 value = MUTABLE_SV(SSPOPPTR);
911 sv = MUTABLE_SV(SSPOPPTR);
85fbaab2 912 hv = MUTABLE_HV(SSPOPPTR);
161b7d16 913 ptr = hv_fetch_ent(hv, sv, 1, 0);
4e4c362e 914 if (ptr) {
35a4481c 915 const SV * const oval = HeVAL((HE*)ptr);
3280af22 916 if (oval && oval != &PL_sv_undef) {
4e4c362e 917 ptr = &HeVAL((HE*)ptr);
ad64d0ec 918 if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
b37c2d43 919 SvREFCNT_inc_void(*(SV**)ptr);
4e4c362e 920 SvREFCNT_dec(sv);
502c6561 921 av = MUTABLE_AV(hv); /* what to refcnt_dec */
4e4c362e
GS
922 goto restore_sv;
923 }
924 }
925 SvREFCNT_dec(hv);
926 SvREFCNT_dec(sv);
927 SvREFCNT_dec(value);
928 break;
462e5cf6 929 case SAVEt_OP:
533c011a 930 PL_op = (OP*)SSPOPPTR;
462e5cf6 931 break;
25eaa213 932 case SAVEt_HINTS:
045ac317 933 if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
ad64d0ec 934 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
045ac317
RGS
935 GvHV(PL_hintgv) = NULL;
936 }
3280af22 937 *(I32*)&PL_hints = (I32)SSPOPINT;
c28fe1ec
NC
938 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
939 PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR;
dfa41748 940 if (PL_hints & HINT_LOCALIZE_HH) {
ad64d0ec 941 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
85fbaab2 942 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
5b9c0671
NC
943 assert(GvHV(PL_hintgv));
944 } else if (!GvHV(PL_hintgv)) {
945 /* Need to add a new one manually, else gv_fetchpv() can
946 add one in this code:
947
948 if (SvTYPE(gv) == SVt_PVGV) {
949 if (add) {
950 GvMULTI_on(gv);
951 gv_init_sv(gv, sv_type);
952 if (*name=='!' && sv_type == SVt_PVHV && len==1)
953 require_errno(gv);
954 }
955 return gv;
956 }
957
958 and it won't have the magic set. */
959
960 HV *const hv = newHV();
961 hv_magic(hv, NULL, PERL_MAGIC_hints);
962 GvHV(PL_hintgv) = hv;
dfa41748 963 }
5b9c0671 964 assert(GvHV(PL_hintgv));
b3ac6de7 965 break;
cb50131a 966 case SAVEt_COMPPAD:
f3548bdc 967 PL_comppad = (PAD*)SSPOPPTR;
58ed4fbe 968 if (PL_comppad)
cb50131a
CB
969 PL_curpad = AvARRAY(PL_comppad);
970 else
4608196e 971 PL_curpad = NULL;
cb50131a 972 break;
09edbca0 973 case SAVEt_PADSV_AND_MORTALIZE:
c3564e5c 974 {
35a4481c 975 const PADOFFSET off = (PADOFFSET)SSPOPLONG;
09edbca0 976 SV **svp;
c3564e5c 977 ptr = SSPOPPTR;
09edbca0
NC
978 assert (ptr);
979 svp = AvARRAY((PAD*)ptr) + off;
980 /* This mortalizing used to be done by POPLOOP() via itersave.
981 But as we have all the information here, we can do it here,
982 save even having to have itersave in the struct. */
983 sv_2mortal(*svp);
ad64d0ec 984 *svp = MUTABLE_SV(SSPOPPTR);
c3564e5c
GS
985 }
986 break;
8b7059b1
DM
987 case SAVEt_SAVESWITCHSTACK:
988 {
989 dSP;
502c6561
NC
990 AV *const t = MUTABLE_AV(SSPOPPTR);
991 AV *const f = MUTABLE_AV(SSPOPPTR);
8b7059b1
DM
992 SWITCHSTACK(t,f);
993 PL_curstackinfo->si_stack = f;
994 }
995 break;
14f338dc
DM
996 case SAVEt_SET_SVFLAGS:
997 {
35a4481c
AL
998 const U32 val = (U32)SSPOPINT;
999 const U32 mask = (U32)SSPOPINT;
ad64d0ec 1000 sv = MUTABLE_SV(SSPOPPTR);
14f338dc
DM
1001 SvFLAGS(sv) &= ~mask;
1002 SvFLAGS(sv) |= val;
1003 }
1004 break;
95e06916
NC
1005
1006 /* This would be a mathom, but Perl_save_svref() calls a static
1007 function, S_save_scalar_at(), so has to stay in this file. */
2053acbf 1008 case SAVEt_SVREF: /* scalar reference */
ad64d0ec 1009 value = MUTABLE_SV(SSPOPPTR);
2053acbf
NC
1010 ptr = SSPOPPTR;
1011 av = NULL; /* what to refcnt_dec */
1012 goto restore_sv;
95e06916
NC
1013
1014 /* These are only saved in mathoms.c */
1015 case SAVEt_NSTAB:
159b6efe 1016 gv = MUTABLE_GV(SSPOPPTR);
ad64d0ec 1017 (void)sv_clear(MUTABLE_SV(gv));
95e06916 1018 break;
2053acbf
NC
1019 case SAVEt_LONG: /* long reference */
1020 ptr = SSPOPPTR;
1021 *(long*)ptr = (long)SSPOPLONG;
1022 break;
95e06916
NC
1023 case SAVEt_IV: /* IV reference */
1024 ptr = SSPOPPTR;
1025 *(IV*)ptr = (IV)SSPOPIV;
1026 break;
1027
2053acbf
NC
1028 case SAVEt_I16: /* I16 reference */
1029 ptr = SSPOPPTR;
1030 *(I16*)ptr = (I16)SSPOPINT;
1031 break;
1032 case SAVEt_I8: /* I8 reference */
1033 ptr = SSPOPPTR;
1034 *(I8*)ptr = (I8)SSPOPINT;
1035 break;
2053acbf
NC
1036 case SAVEt_DESTRUCTOR:
1037 ptr = SSPOPPTR;
1038 (*SSPOPDPTR)(ptr);
1039 break;
fc15ae8f
NC
1040 case SAVEt_COP_ARYBASE:
1041 ptr = SSPOPPTR;
1042 i = SSPOPINT;
1043 CopARYBASE_set((COP *)ptr, i);
1044 break;
68da3b2f
NC
1045 case SAVEt_COMPILE_WARNINGS:
1046 ptr = SSPOPPTR;
72dc9ed5 1047
68da3b2f
NC
1048 if (!specialWARN(PL_compiling.cop_warnings))
1049 PerlMemShared_free(PL_compiling.cop_warnings);
72dc9ed5 1050
10edeb5d 1051 PL_compiling.cop_warnings = (STRLEN*)ptr;
72dc9ed5 1052 break;
1ade1aa1
NC
1053 case SAVEt_RE_STATE:
1054 {
1055 const struct re_save_state *const state
1056 = (struct re_save_state *)
1057 (PL_savestack + PL_savestack_ix
1058 - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
1059 PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
1060
1ade1aa1
NC
1061 if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
1062 Safefree(PL_reg_start_tmp);
1ade1aa1 1063 }
1ade1aa1
NC
1064 if (PL_reg_poscache != state->re_state_reg_poscache) {
1065 Safefree(PL_reg_poscache);
1ade1aa1 1066 }
46ab3289 1067 Copy(state, &PL_reg_state, 1, struct re_save_state);
1ade1aa1
NC
1068 }
1069 break;
7c197c94
DM
1070 case SAVEt_PARSER:
1071 ptr = SSPOPPTR;
1072 parser_free((yy_parser *) ptr);
1073 break;
79072805 1074 default:
cea2e8a9 1075 Perl_croak(aTHX_ "panic: leave_scope inconsistency");
79072805
LW
1076 }
1077 }
1078}
8990e307 1079
8990e307 1080void
864dbfa3 1081Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
8990e307 1082{
97aff369 1083 dVAR;
7918f24d
NC
1084
1085 PERL_ARGS_ASSERT_CX_DUMP;
1086
35ff7856 1087#ifdef DEBUGGING
22c35a8c 1088 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
6b35e009 1089 if (CxTYPE(cx) != CXt_SUBST) {
760ac839 1090 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
146174a9
CB
1091 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1092 PTR2UV(cx->blk_oldcop));
760ac839
LW
1093 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1094 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
146174a9
CB
1095 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1096 PTR2UV(cx->blk_oldpm));
760ac839 1097 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
8990e307 1098 }
6b35e009 1099 switch (CxTYPE(cx)) {
8990e307
LW
1100 case CXt_NULL:
1101 case CXt_BLOCK:
1102 break;
146174a9 1103 case CXt_FORMAT:
f9c764c5
NC
1104 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1105 PTR2UV(cx->blk_format.cv));
1106 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1107 PTR2UV(cx->blk_format.gv));
1108 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1109 PTR2UV(cx->blk_format.dfoutgv));
1110 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
bafb2adc 1111 (int)CxHASARGS(cx));
f9c764c5
NC
1112 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1113 PTR2UV(cx->blk_format.retop));
146174a9 1114 break;
8990e307 1115 case CXt_SUB:
146174a9
CB
1116 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1117 PTR2UV(cx->blk_sub.cv));
760ac839 1118 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
8990e307 1119 (long)cx->blk_sub.olddepth);
760ac839 1120 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
bafb2adc
NC
1121 (int)CxHASARGS(cx));
1122 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
f39bc417
DM
1123 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1124 PTR2UV(cx->blk_sub.retop));
8990e307
LW
1125 break;
1126 case CXt_EVAL:
760ac839 1127 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
85a64632 1128 (long)CxOLD_IN_EVAL(cx));
760ac839 1129 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
85a64632
NC
1130 PL_op_name[CxOLD_OP_TYPE(cx)],
1131 PL_op_desc[CxOLD_OP_TYPE(cx)]);
0f79a09d
GS
1132 if (cx->blk_eval.old_namesv)
1133 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
aa07b2f6 1134 SvPVX_const(cx->blk_eval.old_namesv));
146174a9
CB
1135 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1136 PTR2UV(cx->blk_eval.old_eval_root));
f39bc417
DM
1137 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1138 PTR2UV(cx->blk_eval.retop));
8990e307
LW
1139 break;
1140
c6fdafd0 1141 case CXt_LOOP_LAZYIV:
d01136d6 1142 case CXt_LOOP_LAZYSV:
3b719c58
NC
1143 case CXt_LOOP_FOR:
1144 case CXt_LOOP_PLAIN:
0cbdab38 1145 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
760ac839 1146 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
8990e307 1147 (long)cx->blk_loop.resetsp);
022eaa24
NC
1148 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1149 PTR2UV(cx->blk_loop.my_op));
146174a9 1150 PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
022eaa24 1151 PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
d01136d6 1152 /* XXX: not accurate for LAZYSV/IV */
146174a9 1153 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
d01136d6
BS
1154 PTR2UV(cx->blk_loop.state_u.ary.ary));
1155 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1156 (long)cx->blk_loop.state_u.ary.ix);
146174a9
CB
1157 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1158 PTR2UV(CxITERVAR(cx)));
8990e307
LW
1159 break;
1160
1161 case CXt_SUBST:
760ac839 1162 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
8990e307 1163 (long)cx->sb_iters);
760ac839 1164 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
8990e307 1165 (long)cx->sb_maxiters);
35ef4773
GS
1166 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1167 (long)cx->sb_rflags);
760ac839 1168 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
c5bed6a7 1169 (long)CxONCE(cx));
760ac839 1170 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
8990e307 1171 cx->sb_orig);
146174a9
CB
1172 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1173 PTR2UV(cx->sb_dstr));
1174 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1175 PTR2UV(cx->sb_targ));
1176 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1177 PTR2UV(cx->sb_s));
1178 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1179 PTR2UV(cx->sb_m));
1180 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1181 PTR2UV(cx->sb_strend));
1182 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1183 PTR2UV(cx->sb_rxres));
8990e307
LW
1184 break;
1185 }
65e66c80 1186#else
96a5add6 1187 PERL_UNUSED_CONTEXT;
65e66c80 1188 PERL_UNUSED_ARG(cx);
17c3b450 1189#endif /* DEBUGGING */
35ff7856 1190}
241d1a3b
NC
1191
1192/*
1193 * Local variables:
1194 * c-indentation-style: bsd
1195 * c-basic-offset: 4
1196 * indent-tabs-mode: t
1197 * End:
1198 *
37442d52
RGS
1199 * ex: set ts=8 sts=4 sw=4 noet:
1200 */