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