Convert all the scope save functions of the form
[p5sagit/p5-mst-13.2.git] / scope.c
1 /*    scope.c
2  *
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
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  *
9  */
10
11 /*
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"]
16  */
17
18 /* This file contains functions to manipulate several of Perl's stacks;
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
25 #include "EXTERN.h"
26 #define PERL_IN_SCOPE_C
27 #include "perl.h"
28
29 SV**
30 Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
31 {
32     dVAR;
33
34     PERL_ARGS_ASSERT_STACK_GROW;
35
36     PL_stack_sp = sp;
37 #ifndef STRESS_REALLOC
38     av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
39 #else
40     av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
41 #endif
42     return PL_stack_sp;
43 }
44
45 #ifndef STRESS_REALLOC
46 #define GROW(old) ((old) * 3 / 2)
47 #else
48 #define GROW(old) ((old) + 1)
49 #endif
50
51 PERL_SI *
52 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
53 {
54     dVAR;
55     PERL_SI *si;
56     Newx(si, 1, PERL_SI);
57     si->si_stack = newAV();
58     AvREAL_off(si->si_stack);
59     av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
60     AvALLOC(si->si_stack)[0] = &PL_sv_undef;
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;
66     si->si_type = PERLSI_UNDEF;
67     Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
68     /* Without any kind of initialising PUSHSUBST()
69      * in pp_subst() will read uninitialised heap. */
70     PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
71     return si;
72 }
73
74 I32
75 Perl_cxinc(pTHX)
76 {
77     dVAR;
78     const IV old_max = cxstack_max;
79     cxstack_max = GROW(cxstack_max);
80     Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);      /* XXX should fix CXINC macro */
81     /* Without any kind of initialising deep enough recursion
82      * will end up reading uninitialised PERL_CONTEXTs. */
83     PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
84     return cxstack_ix + 1;
85 }
86
87 void
88 Perl_push_scope(pTHX)
89 {
90     dVAR;
91     if (PL_scopestack_ix == PL_scopestack_max) {
92         PL_scopestack_max = GROW(PL_scopestack_max);
93         Renew(PL_scopestack, PL_scopestack_max, I32);
94     }
95     PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
96
97 }
98
99 void
100 Perl_pop_scope(pTHX)
101 {
102     dVAR;
103     const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
104     LEAVE_SCOPE(oldsave);
105 }
106
107 void
108 Perl_markstack_grow(pTHX)
109 {
110     dVAR;
111     const I32 oldmax = PL_markstack_max - PL_markstack;
112     const I32 newmax = GROW(oldmax);
113
114     Renew(PL_markstack, newmax, I32);
115     PL_markstack_ptr = PL_markstack + oldmax;
116     PL_markstack_max = PL_markstack + newmax;
117 }
118
119 void
120 Perl_savestack_grow(pTHX)
121 {
122     dVAR;
123     PL_savestack_max = GROW(PL_savestack_max) + 4;
124     Renew(PL_savestack, PL_savestack_max, ANY);
125 }
126
127 void
128 Perl_savestack_grow_cnt(pTHX_ I32 need)
129 {
130     dVAR;
131     PL_savestack_max = PL_savestack_ix + need;
132     Renew(PL_savestack, PL_savestack_max, ANY);
133 }
134
135 #undef GROW
136
137 void
138 Perl_tmps_grow(pTHX_ I32 n)
139 {
140     dVAR;
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
150 void
151 Perl_free_tmps(pTHX)
152 {
153     dVAR;
154     /* XXX should tmps_floor live in cxstack? */
155     const I32 myfloor = PL_tmps_floor;
156     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
157         SV* const sv = PL_tmps_stack[PL_tmps_ix];
158         PL_tmps_stack[PL_tmps_ix--] = NULL;
159         if (sv && sv != &PL_sv_undef) {
160             SvTEMP_off(sv);
161             SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
162         }
163     }
164 }
165
166 STATIC SV *
167 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
168 {
169     dVAR;
170     SV * const osv = *sptr;
171     register SV * const sv = *sptr = newSV(0);
172
173     PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
174
175     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
176         if (SvGMAGICAL(osv)) {
177             const bool oldtainted = PL_tainted;
178             SvFLAGS(osv) |= (SvFLAGS(osv) &
179                (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
180             PL_tainted = oldtainted;
181         }
182         mg_localize(osv, sv, (flags & SAVEf_SETMAGIC) != 0);
183     }
184     return sv;
185 }
186
187 SV *
188 Perl_save_scalar(pTHX_ GV *gv)
189 {
190     dVAR;
191     SV ** const sptr = &GvSVn(gv);
192
193     PERL_ARGS_ASSERT_SAVE_SCALAR;
194
195     PL_localizing = 1;
196     SvGETMAGIC(*sptr);
197     PL_localizing = 0;
198     SSCHECK(3);
199     SSPUSHPTR(SvREFCNT_inc_simple(gv));
200     SSPUSHPTR(SvREFCNT_inc(*sptr));
201     SSPUSHINT(SAVEt_SV);
202     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
203 }
204
205 /* Like save_sptr(), but also SvREFCNT_dec()s the new value.  Can be used to
206  * restore a global SV to its prior contents, freeing new value. */
207 void
208 Perl_save_generic_svref(pTHX_ SV **sptr)
209 {
210     dVAR;
211
212     PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
213
214     SSCHECK(3);
215     SSPUSHPTR(sptr);
216     SSPUSHPTR(SvREFCNT_inc(*sptr));
217     SSPUSHINT(SAVEt_GENERIC_SVREF);
218 }
219
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. */
223 void
224 Perl_save_generic_pvref(pTHX_ char **str)
225 {
226     dVAR;
227
228     PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
229
230     SSCHECK(3);
231     SSPUSHPTR(*str);
232     SSPUSHPTR(str);
233     SSPUSHINT(SAVEt_GENERIC_PVREF);
234 }
235
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. */
239 void
240 Perl_save_shared_pvref(pTHX_ char **str)
241 {
242     dVAR;
243
244     PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
245
246     SSCHECK(3);
247     SSPUSHPTR(str);
248     SSPUSHPTR(*str);
249     SSPUSHINT(SAVEt_SHARED_PVREF);
250 }
251
252 /* set the SvFLAGS specified by mask to the values in val */
253
254 void
255 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
256 {
257     dVAR;
258
259     PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
260
261     SSCHECK(4);
262     SSPUSHPTR(sv);
263     SSPUSHINT(mask);
264     SSPUSHINT(val);
265     SSPUSHINT(SAVEt_SET_SVFLAGS);
266 }
267
268 void
269 Perl_save_gp(pTHX_ GV *gv, I32 empty)
270 {
271     dVAR;
272
273     PERL_ARGS_ASSERT_SAVE_GP;
274
275     SSGROW(3);
276     SSPUSHPTR(SvREFCNT_inc(gv));
277     SSPUSHPTR(GvGP(gv));
278     SSPUSHINT(SAVEt_GP);
279
280     if (empty) {
281         GP *gp = Perl_newGP(aTHX_ gv);
282
283         if (GvCVu(gv))
284             mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
285         if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
286             gp->gp_io = newIO();
287             IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
288         }
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
297         GvGP(gv) = gp;
298     }
299     else {
300         gp_ref(GvGP(gv));
301         GvINTRO_on(gv);
302     }
303 }
304
305 AV *
306 Perl_save_ary(pTHX_ GV *gv)
307 {
308     dVAR;
309     AV * const oav = GvAVn(gv);
310     AV *av;
311
312     PERL_ARGS_ASSERT_SAVE_ARY;
313
314     if (!AvREAL(oav) && AvREIFY(oav))
315         av_reify(oav);
316     SSCHECK(3);
317     SSPUSHPTR(gv);
318     SSPUSHPTR(oav);
319     SSPUSHINT(SAVEt_AV);
320
321     GvAV(gv) = NULL;
322     av = GvAVn(gv);
323     if (SvMAGIC(oav))
324         mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
325     return av;
326 }
327
328 HV *
329 Perl_save_hash(pTHX_ GV *gv)
330 {
331     dVAR;
332     HV *ohv, *hv;
333
334     PERL_ARGS_ASSERT_SAVE_HASH;
335
336     SSCHECK(3);
337     SSPUSHPTR(gv);
338     SSPUSHPTR(ohv = GvHVn(gv));
339     SSPUSHINT(SAVEt_HV);
340
341     GvHV(gv) = NULL;
342     hv = GvHVn(gv);
343     if (SvMAGIC(ohv))
344         mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
345     return hv;
346 }
347
348 void
349 Perl_save_item(pTHX_ register SV *item)
350 {
351     dVAR;
352     register SV * const sv = newSVsv(item);
353
354     PERL_ARGS_ASSERT_SAVE_ITEM;
355
356     SSCHECK(3);
357     SSPUSHPTR(item);            /* remember the pointer */
358     SSPUSHPTR(sv);              /* remember the value */
359     SSPUSHINT(SAVEt_ITEM);
360 }
361
362 void
363 Perl_save_int(pTHX_ int *intp)
364 {
365     dVAR;
366
367     PERL_ARGS_ASSERT_SAVE_INT;
368
369     SSCHECK(3);
370     SSPUSHINT(*intp);
371     SSPUSHPTR(intp);
372     SSPUSHINT(SAVEt_INT);
373 }
374
375 void
376 Perl_save_bool(pTHX_ bool *boolp)
377 {
378     dVAR;
379
380     PERL_ARGS_ASSERT_SAVE_BOOL;
381
382     SSCHECK(3);
383     SSPUSHBOOL(*boolp);
384     SSPUSHPTR(boolp);
385     SSPUSHINT(SAVEt_BOOL);
386 }
387
388 void
389 Perl_save_I8(pTHX_ I8 *bytep)
390 {
391     dVAR;
392
393     PERL_ARGS_ASSERT_SAVE_I8;
394
395     SSCHECK(3);
396     SSPUSHINT(*bytep);
397     SSPUSHPTR(bytep);
398     SSPUSHINT(SAVEt_I8);
399 }
400
401 void
402 Perl_save_I16(pTHX_ I16 *intp)
403 {
404     dVAR;
405
406     PERL_ARGS_ASSERT_SAVE_I16;
407
408     SSCHECK(3);
409     SSPUSHINT(*intp);
410     SSPUSHPTR(intp);
411     SSPUSHINT(SAVEt_I16);
412 }
413
414 void
415 Perl_save_I32(pTHX_ I32 *intp)
416 {
417     dVAR;
418
419     PERL_ARGS_ASSERT_SAVE_I32;
420
421     SSCHECK(3);
422     SSPUSHINT(*intp);
423     SSPUSHPTR(intp);
424     SSPUSHINT(SAVEt_I32);
425 }
426
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  */
430 void
431 Perl_save_pptr(pTHX_ char **pptr)
432 {
433     dVAR;
434
435     PERL_ARGS_ASSERT_SAVE_PPTR;
436
437     SSCHECK(3);
438     SSPUSHPTR(*pptr);
439     SSPUSHPTR(pptr);
440     SSPUSHINT(SAVEt_PPTR);
441 }
442
443 void
444 Perl_save_vptr(pTHX_ void *ptr)
445 {
446     dVAR;
447
448     PERL_ARGS_ASSERT_SAVE_VPTR;
449
450     SSCHECK(3);
451     SSPUSHPTR(*(char**)ptr);
452     SSPUSHPTR(ptr);
453     SSPUSHINT(SAVEt_VPTR);
454 }
455
456 void
457 Perl_save_sptr(pTHX_ SV **sptr)
458 {
459     dVAR;
460
461     PERL_ARGS_ASSERT_SAVE_SPTR;
462
463     SSCHECK(3);
464     SSPUSHPTR(*sptr);
465     SSPUSHPTR(sptr);
466     SSPUSHINT(SAVEt_SPTR);
467 }
468
469 void
470 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
471 {
472     dVAR;
473     SSCHECK(4);
474     ASSERT_CURPAD_ACTIVE("save_padsv");
475     SSPUSHPTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
476     SSPUSHPTR(PL_comppad);
477     SSPUSHLONG((long)off);
478     SSPUSHINT(SAVEt_PADSV_AND_MORTALIZE);
479 }
480
481 void
482 Perl_save_hptr(pTHX_ HV **hptr)
483 {
484     dVAR;
485
486     PERL_ARGS_ASSERT_SAVE_HPTR;
487
488     SSCHECK(3);
489     SSPUSHPTR(*hptr);
490     SSPUSHPTR(hptr);
491     SSPUSHINT(SAVEt_HPTR);
492 }
493
494 void
495 Perl_save_aptr(pTHX_ AV **aptr)
496 {
497     dVAR;
498
499     PERL_ARGS_ASSERT_SAVE_APTR;
500
501     SSCHECK(3);
502     SSPUSHPTR(*aptr);
503     SSPUSHPTR(aptr);
504     SSPUSHINT(SAVEt_APTR);
505 }
506
507 void
508 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
509 {
510     dVAR;
511     SSCHECK(2);
512     SSPUSHPTR(ptr);
513     SSPUSHINT(type);
514 }
515
516 void
517 Perl_save_clearsv(pTHX_ SV **svp)
518 {
519     dVAR;
520
521     PERL_ARGS_ASSERT_SAVE_CLEARSV;
522
523     ASSERT_CURPAD_ACTIVE("save_clearsv");
524     SSCHECK(2);
525     SSPUSHLONG((long)(svp-PL_curpad));
526     SSPUSHINT(SAVEt_CLEARSV);
527     SvPADSTALE_off(*svp); /* mark lexical as active */
528 }
529
530 void
531 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
532 {
533     dVAR;
534
535     PERL_ARGS_ASSERT_SAVE_DELETE;
536
537     SSCHECK(4);
538     SSPUSHINT(klen);
539     SSPUSHPTR(key);
540     SSPUSHPTR(SvREFCNT_inc_simple(hv));
541     SSPUSHINT(SAVEt_DELETE);
542 }
543
544 void
545 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
546 {
547     dVAR;
548
549     PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
550
551     SSCHECK(3);
552     SSPUSHDPTR(f);
553     SSPUSHPTR(p);
554     SSPUSHINT(SAVEt_DESTRUCTOR);
555 }
556
557 void
558 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
559 {
560     dVAR;
561     SSCHECK(3);
562     SSPUSHDXPTR(f);
563     SSPUSHPTR(p);
564     SSPUSHINT(SAVEt_DESTRUCTOR_X);
565 }
566
567 void
568 Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
569 {
570     dVAR;
571     SV *sv;
572
573     PERL_ARGS_ASSERT_SAVE_AELEM;
574
575     SvGETMAGIC(*sptr);
576     SSCHECK(4);
577     SSPUSHPTR(SvREFCNT_inc_simple(av));
578     SSPUSHINT(idx);
579     SSPUSHPTR(SvREFCNT_inc(*sptr));
580     SSPUSHINT(SAVEt_AELEM);
581     /* if it gets reified later, the restore will have the wrong refcnt */
582     if (!AvREAL(av) && AvREIFY(av))
583         SvREFCNT_inc_void(*sptr);
584     save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
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);
592 }
593
594 void
595 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
596 {
597     dVAR;
598     SV *sv;
599
600     PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
601
602     SvGETMAGIC(*sptr);
603     SSCHECK(4);
604     SSPUSHPTR(SvREFCNT_inc_simple(hv));
605     SSPUSHPTR(newSVsv(key));
606     SSPUSHPTR(SvREFCNT_inc(*sptr));
607     SSPUSHINT(SAVEt_HELEM);
608     save_scalar_at(sptr, flags);
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);
616 }
617
618 SV*
619 Perl_save_svref(pTHX_ SV **sptr)
620 {
621     dVAR;
622
623     PERL_ARGS_ASSERT_SAVE_SVREF;
624
625     SvGETMAGIC(*sptr);
626     SSCHECK(3);
627     SSPUSHPTR(sptr);
628     SSPUSHPTR(SvREFCNT_inc(*sptr));
629     SSPUSHINT(SAVEt_SVREF);
630     return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
631 }
632
633 I32
634 Perl_save_alloc(pTHX_ I32 size, I32 pad)
635 {
636     dVAR;
637     register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
638                                 - (char*)PL_savestack);
639     register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
640
641     SSGROW(elems + 2);
642
643     PL_savestack_ix += elems;
644     SSPUSHINT(elems);
645     SSPUSHINT(SAVEt_ALLOC);
646     return start;
647 }
648
649 void
650 Perl_leave_scope(pTHX_ I32 base)
651 {
652     dVAR;
653     register SV *sv;
654     register SV *value;
655     register GV *gv;
656     register AV *av;
657     register HV *hv;
658     void* ptr;
659     register char* str;
660     I32 i;
661
662     if (base < -1)
663         Perl_croak(aTHX_ "panic: corrupt saved stack index");
664     while (PL_savestack_ix > base) {
665         TAINT_NOT;
666
667         switch (SSPOPINT) {
668         case SAVEt_ITEM:                        /* normal string */
669             value = MUTABLE_SV(SSPOPPTR);
670             sv = MUTABLE_SV(SSPOPPTR);
671             sv_replace(sv,value);
672             PL_localizing = 2;
673             SvSETMAGIC(sv);
674             PL_localizing = 0;
675             break;
676         case SAVEt_SV:                          /* scalar reference */
677             value = MUTABLE_SV(SSPOPPTR);
678             gv = MUTABLE_GV(SSPOPPTR);
679             ptr = &GvSV(gv);
680             av = MUTABLE_AV(gv); /* what to refcnt_dec */
681         restore_sv:
682             sv = *(SV**)ptr;
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;
692         case SAVEt_GENERIC_PVREF:               /* generic pv */
693             ptr = SSPOPPTR;
694             str = (char*)SSPOPPTR;
695             if (*(char**)ptr != str) {
696                 Safefree(*(char**)ptr);
697                 *(char**)ptr = str;
698             }
699             break;
700         case SAVEt_SHARED_PVREF:                /* shared pv */
701             str = (char*)SSPOPPTR;
702             ptr = SSPOPPTR;
703             if (*(char**)ptr != str) {
704 #ifdef NETWARE
705                 PerlMem_free(*(char**)ptr);
706 #else
707                 PerlMemShared_free(*(char**)ptr);
708 #endif
709                 *(char**)ptr = str;
710             }
711             break;
712         case SAVEt_GENERIC_SVREF:               /* generic sv */
713             value = MUTABLE_SV(SSPOPPTR);
714             ptr = SSPOPPTR;
715             sv = *(SV**)ptr;
716             *(SV**)ptr = value;
717             SvREFCNT_dec(sv);
718             SvREFCNT_dec(value);
719             break;
720         case SAVEt_AV:                          /* array reference */
721             av = MUTABLE_AV(SSPOPPTR);
722             gv = MUTABLE_GV(SSPOPPTR);
723             if (GvAV(gv)) {
724                 SvREFCNT_dec(GvAV(gv));
725             }
726             GvAV(gv) = av;
727             if (SvMAGICAL(av)) {
728                 PL_localizing = 2;
729                 SvSETMAGIC(MUTABLE_SV(av));
730                 PL_localizing = 0;
731             }
732             break;
733         case SAVEt_HV:                          /* hash reference */
734             hv = MUTABLE_HV(SSPOPPTR);
735             gv = MUTABLE_GV(SSPOPPTR);
736             if (GvHV(gv)) {
737                 SvREFCNT_dec(GvHV(gv));
738             }
739             GvHV(gv) = hv;
740             if (SvMAGICAL(hv)) {
741                 PL_localizing = 2;
742                 SvSETMAGIC(MUTABLE_SV(hv));
743                 PL_localizing = 0;
744             }
745             break;
746         case SAVEt_INT:                         /* int reference */
747             ptr = SSPOPPTR;
748             *(int*)ptr = (int)SSPOPINT;
749             break;
750         case SAVEt_BOOL:                        /* bool reference */
751             ptr = SSPOPPTR;
752             *(bool*)ptr = (bool)SSPOPBOOL;
753             break;
754         case SAVEt_I32:                         /* I32 reference */
755             ptr = SSPOPPTR;
756 #ifdef PERL_DEBUG_READONLY_OPS
757             {
758                 const I32 val = SSPOPINT;
759                 if (*(I32*)ptr != val)
760                     *(I32*)ptr = val;
761             }
762 #else
763             *(I32*)ptr = (I32)SSPOPINT;
764 #endif
765             break;
766         case SAVEt_SPTR:                        /* SV* reference */
767             ptr = SSPOPPTR;
768             *(SV**)ptr = MUTABLE_SV(SSPOPPTR);
769             break;
770         case SAVEt_VPTR:                        /* random* reference */
771         case SAVEt_PPTR:                        /* char* reference */
772             ptr = SSPOPPTR;
773             *(char**)ptr = (char*)SSPOPPTR;
774             break;
775         case SAVEt_HPTR:                        /* HV* reference */
776             ptr = SSPOPPTR;
777             *(HV**)ptr = MUTABLE_HV(SSPOPPTR);
778             break;
779         case SAVEt_APTR:                        /* AV* reference */
780             ptr = SSPOPPTR;
781             *(AV**)ptr = MUTABLE_AV(SSPOPPTR);
782             break;
783         case SAVEt_GP:                          /* scalar reference */
784             ptr = SSPOPPTR;
785             gv = MUTABLE_GV(SSPOPPTR);
786             gp_free(gv);
787             GvGP(gv) = (GP*)ptr;
788             /* putting a method back into circulation ("local")*/
789             if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
790                 mro_method_changed_in(hv);
791             SvREFCNT_dec(gv);
792             break;
793         case SAVEt_FREESV:
794             ptr = SSPOPPTR;
795             SvREFCNT_dec(MUTABLE_SV(ptr));
796             break;
797         case SAVEt_MORTALIZESV:
798             ptr = SSPOPPTR;
799             sv_2mortal(MUTABLE_SV(ptr));
800             break;
801         case SAVEt_FREEOP:
802             ptr = SSPOPPTR;
803             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
804             op_free((OP*)ptr);
805             break;
806         case SAVEt_FREEPV:
807             ptr = SSPOPPTR;
808             Safefree(ptr);
809             break;
810         case SAVEt_CLEARSV:
811             ptr = (void*)&PL_curpad[SSPOPLONG];
812             sv = *(SV**)ptr;
813
814             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
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),
818                 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
819             ));
820
821             /* Can clear pad variable in place? */
822             if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
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
827                  */
828                 if (SvPADMY(sv) && !SvFAKE(sv))
829                     SvREADONLY_off(sv);
830
831                 if (SvTHINKFIRST(sv))
832                     sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
833                 if (SvMAGICAL(sv))
834                     mg_free(sv);
835
836                 switch (SvTYPE(sv)) {
837                 case SVt_NULL:
838                     break;
839                 case SVt_PVAV:
840                     av_clear(MUTABLE_AV(sv));
841                     break;
842                 case SVt_PVHV:
843                     hv_clear(MUTABLE_HV(sv));
844                     break;
845                 case SVt_PVCV:
846                     Perl_croak(aTHX_ "panic: leave_scope pad code");
847                 default:
848                     SvOK_off(sv);
849                     break;
850                 }
851                 SvPADSTALE_on(sv); /* mark as no longer live */
852             }
853             else {      /* Someone has a claim on this, so abandon it. */
854                 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
855                 switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
856                 case SVt_PVAV:  *(SV**)ptr = MUTABLE_SV(newAV());       break;
857                 case SVt_PVHV:  *(SV**)ptr = MUTABLE_SV(newHV());       break;
858                 default:        *(SV**)ptr = newSV(0);          break;
859                 }
860                 SvREFCNT_dec(sv);       /* Cast current value to the winds. */
861                 /* preserve pad nature, but also mark as not live
862                  * for any closure capturing */
863                 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
864             }
865             break;
866         case SAVEt_DELETE:
867             ptr = SSPOPPTR;
868             hv = MUTABLE_HV(ptr);
869             ptr = SSPOPPTR;
870             (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
871             SvREFCNT_dec(hv);
872             Safefree(ptr);
873             break;
874         case SAVEt_DESTRUCTOR_X:
875             ptr = SSPOPPTR;
876             (*SSPOPDXPTR)(aTHX_ ptr);
877             break;
878         case SAVEt_REGCONTEXT:
879         case SAVEt_ALLOC:
880             i = SSPOPINT;
881             PL_savestack_ix -= i;       /* regexp must have croaked */
882             break;
883         case SAVEt_STACK_POS:           /* Position on Perl stack */
884             i = SSPOPINT;
885             PL_stack_sp = PL_stack_base + i;
886             break;
887         case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
888             i = SSPOPINT;
889             cxstack[i].blk_oldsp = SSPOPINT;
890             break;
891         case SAVEt_AELEM:               /* array element */
892             value = MUTABLE_SV(SSPOPPTR);
893             i = SSPOPINT;
894             av = MUTABLE_AV(SSPOPPTR);
895             ptr = av_fetch(av,i,1);
896             if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
897                 SvREFCNT_dec(value);
898             if (ptr) {
899                 sv = *(SV**)ptr;
900                 if (sv && sv != &PL_sv_undef) {
901                     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
902                         SvREFCNT_inc_void_NN(sv);
903                     goto restore_sv;
904                 }
905             }
906             SvREFCNT_dec(av);
907             SvREFCNT_dec(value);
908             break;
909         case SAVEt_HELEM:               /* hash element */
910             value = MUTABLE_SV(SSPOPPTR);
911             sv = MUTABLE_SV(SSPOPPTR);
912             hv = MUTABLE_HV(SSPOPPTR);
913             ptr = hv_fetch_ent(hv, sv, 1, 0);
914             if (ptr) {
915                 const SV * const oval = HeVAL((HE*)ptr);
916                 if (oval && oval != &PL_sv_undef) {
917                     ptr = &HeVAL((HE*)ptr);
918                     if (SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
919                         SvREFCNT_inc_void(*(SV**)ptr);
920                     SvREFCNT_dec(sv);
921                     av = MUTABLE_AV(hv); /* what to refcnt_dec */
922                     goto restore_sv;
923                 }
924             }
925             SvREFCNT_dec(hv);
926             SvREFCNT_dec(sv);
927             SvREFCNT_dec(value);
928             break;
929         case SAVEt_OP:
930             PL_op = (OP*)SSPOPPTR;
931             break;
932         case SAVEt_HINTS:
933             if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
934                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
935                 GvHV(PL_hintgv) = NULL;
936             }
937             *(I32*)&PL_hints = (I32)SSPOPINT;
938             Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
939             PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR;
940             if (PL_hints & HINT_LOCALIZE_HH) {
941                 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
942                 GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
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;
963             }
964             assert(GvHV(PL_hintgv));
965             break;
966         case SAVEt_COMPPAD:
967             PL_comppad = (PAD*)SSPOPPTR;
968             if (PL_comppad)
969                 PL_curpad = AvARRAY(PL_comppad);
970             else
971                 PL_curpad = NULL;
972             break;
973         case SAVEt_PADSV_AND_MORTALIZE:
974             {
975                 const PADOFFSET off = (PADOFFSET)SSPOPLONG;
976                 SV **svp;
977                 ptr = SSPOPPTR;
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);
984                 *svp = MUTABLE_SV(SSPOPPTR);
985             }
986             break;
987         case SAVEt_SAVESWITCHSTACK:
988             {
989                 dSP;
990                 AV *const t = MUTABLE_AV(SSPOPPTR);
991                 AV *const f = MUTABLE_AV(SSPOPPTR);
992                 SWITCHSTACK(t,f);
993                 PL_curstackinfo->si_stack = f;
994             }
995             break;
996         case SAVEt_SET_SVFLAGS:
997             {
998                 const U32 val  = (U32)SSPOPINT;
999                 const U32 mask = (U32)SSPOPINT;
1000                 sv = MUTABLE_SV(SSPOPPTR);
1001                 SvFLAGS(sv) &= ~mask;
1002                 SvFLAGS(sv) |= val;
1003             }
1004             break;
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.  */
1008         case SAVEt_SVREF:                       /* scalar reference */
1009             value = MUTABLE_SV(SSPOPPTR);
1010             ptr = SSPOPPTR;
1011             av = NULL; /* what to refcnt_dec */
1012             goto restore_sv;
1013
1014             /* These are only saved in mathoms.c */
1015         case SAVEt_NSTAB:
1016             gv = MUTABLE_GV(SSPOPPTR);
1017             (void)sv_clear(MUTABLE_SV(gv));
1018             break;
1019         case SAVEt_LONG:                        /* long reference */
1020             ptr = SSPOPPTR;
1021             *(long*)ptr = (long)SSPOPLONG;
1022             break;
1023         case SAVEt_IV:                          /* IV reference */
1024             ptr = SSPOPPTR;
1025             *(IV*)ptr = (IV)SSPOPIV;
1026             break;
1027
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;
1036         case SAVEt_DESTRUCTOR:
1037             ptr = SSPOPPTR;
1038             (*SSPOPDPTR)(ptr);
1039             break;
1040         case SAVEt_COP_ARYBASE:
1041             ptr = SSPOPPTR;
1042             i = SSPOPINT;
1043             CopARYBASE_set((COP *)ptr, i);
1044             break;
1045         case SAVEt_COMPILE_WARNINGS:
1046             ptr = SSPOPPTR;
1047
1048             if (!specialWARN(PL_compiling.cop_warnings))
1049                 PerlMemShared_free(PL_compiling.cop_warnings);
1050
1051             PL_compiling.cop_warnings = (STRLEN*)ptr;
1052             break;
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
1061                 if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
1062                     Safefree(PL_reg_start_tmp);
1063                 }
1064                 if (PL_reg_poscache != state->re_state_reg_poscache) {
1065                     Safefree(PL_reg_poscache);
1066                 }
1067                 Copy(state, &PL_reg_state, 1, struct re_save_state);
1068             }
1069             break;
1070         case SAVEt_PARSER:
1071             ptr = SSPOPPTR;
1072             parser_free((yy_parser *) ptr);
1073             break;
1074         default:
1075             Perl_croak(aTHX_ "panic: leave_scope inconsistency");
1076         }
1077     }
1078 }
1079
1080 void
1081 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1082 {
1083     dVAR;
1084
1085     PERL_ARGS_ASSERT_CX_DUMP;
1086
1087 #ifdef DEBUGGING
1088     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1089     if (CxTYPE(cx) != CXt_SUBST) {
1090         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1091         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1092                       PTR2UV(cx->blk_oldcop));
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);
1095         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1096                       PTR2UV(cx->blk_oldpm));
1097         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
1098     }
1099     switch (CxTYPE(cx)) {
1100     case CXt_NULL:
1101     case CXt_BLOCK:
1102         break;
1103     case CXt_FORMAT:
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",
1111                       (int)CxHASARGS(cx));
1112         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1113                 PTR2UV(cx->blk_format.retop));
1114         break;
1115     case CXt_SUB:
1116         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1117                 PTR2UV(cx->blk_sub.cv));
1118         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1119                 (long)cx->blk_sub.olddepth);
1120         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1121                 (int)CxHASARGS(cx));
1122         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1123         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1124                 PTR2UV(cx->blk_sub.retop));
1125         break;
1126     case CXt_EVAL:
1127         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1128                 (long)CxOLD_IN_EVAL(cx));
1129         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1130                 PL_op_name[CxOLD_OP_TYPE(cx)],
1131                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1132         if (cx->blk_eval.old_namesv)
1133             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1134                           SvPVX_const(cx->blk_eval.old_namesv));
1135         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1136                 PTR2UV(cx->blk_eval.old_eval_root));
1137         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1138                 PTR2UV(cx->blk_eval.retop));
1139         break;
1140
1141     case CXt_LOOP_LAZYIV:
1142     case CXt_LOOP_LAZYSV:
1143     case CXt_LOOP_FOR:
1144     case CXt_LOOP_PLAIN:
1145         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1146         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1147                 (long)cx->blk_loop.resetsp);
1148         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1149                 PTR2UV(cx->blk_loop.my_op));
1150         PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
1151                 PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
1152         /* XXX: not accurate for LAZYSV/IV */
1153         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
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);
1157         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1158                 PTR2UV(CxITERVAR(cx)));
1159         break;
1160
1161     case CXt_SUBST:
1162         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1163                 (long)cx->sb_iters);
1164         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1165                 (long)cx->sb_maxiters);
1166         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1167                 (long)cx->sb_rflags);
1168         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1169                 (long)CxONCE(cx));
1170         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1171                 cx->sb_orig);
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));
1184         break;
1185     }
1186 #else
1187     PERL_UNUSED_CONTEXT;
1188     PERL_UNUSED_ARG(cx);
1189 #endif  /* DEBUGGING */
1190 }
1191
1192 /*
1193  * Local variables:
1194  * c-indentation-style: bsd
1195  * c-basic-offset: 4
1196  * indent-tabs-mode: t
1197  * End:
1198  *
1199  * ex: set ts=8 sts=4 sw=4 noet:
1200  */