[patch] Porting/expand-macros.pl gets 'indent'ing
[p5sagit/p5-mst-13.2.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             DEBUG_S(PerlIO_printf(Perl_debug_log,
719                                   "restore svref: %p %p:%s -> %p:%s\n",
720                                   (void*)ptr, (void*)sv, SvPEEK(sv),
721                                   (void*)value, SvPEEK(value)));
722             *(SV**)ptr = value;
723             SvREFCNT_dec(sv);
724             PL_localizing = 2;
725             SvSETMAGIC(value);
726             PL_localizing = 0;
727             SvREFCNT_dec(value);
728             if (av) /* actually an av, hv or gv */
729                 SvREFCNT_dec(av);
730             break;
731         case SAVEt_GENERIC_PVREF:               /* generic pv */
732             ptr = SSPOPPTR;
733             str = (char*)SSPOPPTR;
734             if (*(char**)ptr != str) {
735                 Safefree(*(char**)ptr);
736                 *(char**)ptr = str;
737             }
738             break;
739         case SAVEt_SHARED_PVREF:                /* shared pv */
740             str = (char*)SSPOPPTR;
741             ptr = SSPOPPTR;
742             if (*(char**)ptr != str) {
743 #ifdef NETWARE
744                 PerlMem_free(*(char**)ptr);
745 #else
746                 PerlMemShared_free(*(char**)ptr);
747 #endif
748                 *(char**)ptr = str;
749             }
750             break;
751         case SAVEt_GENERIC_SVREF:               /* generic sv */
752             value = (SV*)SSPOPPTR;
753             ptr = SSPOPPTR;
754             sv = *(SV**)ptr;
755             *(SV**)ptr = value;
756             SvREFCNT_dec(sv);
757             SvREFCNT_dec(value);
758             break;
759         case SAVEt_AV:                          /* array reference */
760             av = (AV*)SSPOPPTR;
761             gv = (GV*)SSPOPPTR;
762             if (GvAV(gv)) {
763                 SvREFCNT_dec(GvAV(gv));
764             }
765             GvAV(gv) = av;
766             if (SvMAGICAL(av)) {
767                 PL_localizing = 2;
768                 SvSETMAGIC((SV*)av);
769                 PL_localizing = 0;
770             }
771             break;
772         case SAVEt_HV:                          /* hash reference */
773             hv = (HV*)SSPOPPTR;
774             gv = (GV*)SSPOPPTR;
775             if (GvHV(gv)) {
776                 SvREFCNT_dec(GvHV(gv));
777             }
778             GvHV(gv) = hv;
779             if (SvMAGICAL(hv)) {
780                 PL_localizing = 2;
781                 SvSETMAGIC((SV*)hv);
782                 PL_localizing = 0;
783             }
784             break;
785         case SAVEt_INT:                         /* int reference */
786             ptr = SSPOPPTR;
787             *(int*)ptr = (int)SSPOPINT;
788             break;
789         case SAVEt_BOOL:                        /* bool reference */
790             ptr = SSPOPPTR;
791             *(bool*)ptr = (bool)SSPOPBOOL;
792             break;
793         case SAVEt_I32:                         /* I32 reference */
794             ptr = SSPOPPTR;
795 #ifdef PERL_DEBUG_READONLY_OPS
796             {
797                 const I32 val = SSPOPINT;
798                 if (*(I32*)ptr != val)
799                     *(I32*)ptr = val;
800             }
801 #else
802             *(I32*)ptr = (I32)SSPOPINT;
803 #endif
804             break;
805         case SAVEt_SPTR:                        /* SV* reference */
806             ptr = SSPOPPTR;
807             *(SV**)ptr = (SV*)SSPOPPTR;
808             break;
809         case SAVEt_VPTR:                        /* random* reference */
810         case SAVEt_PPTR:                        /* char* reference */
811             ptr = SSPOPPTR;
812             *(char**)ptr = (char*)SSPOPPTR;
813             break;
814         case SAVEt_HPTR:                        /* HV* reference */
815             ptr = SSPOPPTR;
816             *(HV**)ptr = (HV*)SSPOPPTR;
817             break;
818         case SAVEt_APTR:                        /* AV* reference */
819             ptr = SSPOPPTR;
820             *(AV**)ptr = (AV*)SSPOPPTR;
821             break;
822         case SAVEt_GP:                          /* scalar reference */
823             ptr = SSPOPPTR;
824             gv = (GV*)SSPOPPTR;
825             gp_free(gv);
826             GvGP(gv) = (GP*)ptr;
827             /* putting a method back into circulation ("local")*/
828             if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvNAME_get(hv))
829                 mro_method_changed_in(hv);
830             SvREFCNT_dec(gv);
831             break;
832         case SAVEt_FREESV:
833             ptr = SSPOPPTR;
834             SvREFCNT_dec((SV*)ptr);
835             break;
836         case SAVEt_MORTALIZESV:
837             ptr = SSPOPPTR;
838             sv_2mortal((SV*)ptr);
839             break;
840         case SAVEt_FREEOP:
841             ptr = SSPOPPTR;
842             ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
843             op_free((OP*)ptr);
844             break;
845         case SAVEt_FREEPV:
846             ptr = SSPOPPTR;
847             Safefree(ptr);
848             break;
849         case SAVEt_CLEARSV:
850             ptr = (void*)&PL_curpad[SSPOPLONG];
851             sv = *(SV**)ptr;
852
853             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
854              "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
855                 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
856                 (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
857                 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
858             ));
859
860             /* Can clear pad variable in place? */
861             if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
862                 /*
863                  * if a my variable that was made readonly is going out of
864                  * scope, we want to remove the readonlyness so that it can
865                  * go out of scope quietly
866                  */
867                 if (SvPADMY(sv) && !SvFAKE(sv))
868                     SvREADONLY_off(sv);
869
870                 if (SvTHINKFIRST(sv))
871                     sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
872                 if (SvMAGICAL(sv))
873                     mg_free(sv);
874
875                 switch (SvTYPE(sv)) {
876                 case SVt_NULL:
877                     break;
878                 case SVt_PVAV:
879                     av_clear((AV*)sv);
880                     break;
881                 case SVt_PVHV:
882                     hv_clear((HV*)sv);
883                     break;
884                 case SVt_PVCV:
885                     Perl_croak(aTHX_ "panic: leave_scope pad code");
886                 default:
887                     SvOK_off(sv);
888                     break;
889                 }
890                 SvPADSTALE_on(sv); /* mark as no longer live */
891             }
892             else {      /* Someone has a claim on this, so abandon it. */
893                 const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
894                 switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
895                 case SVt_PVAV:  *(SV**)ptr = (SV*)newAV();      break;
896                 case SVt_PVHV:  *(SV**)ptr = (SV*)newHV();      break;
897                 default:        *(SV**)ptr = newSV(0);          break;
898                 }
899                 SvREFCNT_dec(sv);       /* Cast current value to the winds. */
900                 /* preserve pad nature, but also mark as not live
901                  * for any closure capturing */
902                 SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
903             }
904             break;
905         case SAVEt_DELETE:
906             ptr = SSPOPPTR;
907             hv = (HV*)ptr;
908             ptr = SSPOPPTR;
909             (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
910             SvREFCNT_dec(hv);
911             Safefree(ptr);
912             break;
913         case SAVEt_DESTRUCTOR_X:
914             ptr = SSPOPPTR;
915             (*SSPOPDXPTR)(aTHX_ ptr);
916             break;
917         case SAVEt_REGCONTEXT:
918         case SAVEt_ALLOC:
919             i = SSPOPINT;
920             PL_savestack_ix -= i;       /* regexp must have croaked */
921             break;
922         case SAVEt_STACK_POS:           /* Position on Perl stack */
923             i = SSPOPINT;
924             PL_stack_sp = PL_stack_base + i;
925             break;
926         case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
927             i = SSPOPINT;
928             cxstack[i].blk_oldsp = SSPOPINT;
929             break;
930         case SAVEt_AELEM:               /* array element */
931             value = (SV*)SSPOPPTR;
932             i = SSPOPINT;
933             av = (AV*)SSPOPPTR;
934             ptr = av_fetch(av,i,1);
935             if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
936                 SvREFCNT_dec(value);
937             if (ptr) {
938                 sv = *(SV**)ptr;
939                 if (sv && sv != &PL_sv_undef) {
940                     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
941                         SvREFCNT_inc_void_NN(sv);
942                     goto restore_sv;
943                 }
944             }
945             SvREFCNT_dec(av);
946             SvREFCNT_dec(value);
947             break;
948         case SAVEt_HELEM:               /* hash element */
949             value = (SV*)SSPOPPTR;
950             sv = (SV*)SSPOPPTR;
951             hv = (HV*)SSPOPPTR;
952             ptr = hv_fetch_ent(hv, sv, 1, 0);
953             if (ptr) {
954                 const SV * const oval = HeVAL((HE*)ptr);
955                 if (oval && oval != &PL_sv_undef) {
956                     ptr = &HeVAL((HE*)ptr);
957                     if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
958                         SvREFCNT_inc_void(*(SV**)ptr);
959                     SvREFCNT_dec(sv);
960                     av = (AV*)hv; /* what to refcnt_dec */
961                     goto restore_sv;
962                 }
963             }
964             SvREFCNT_dec(hv);
965             SvREFCNT_dec(sv);
966             SvREFCNT_dec(value);
967             break;
968         case SAVEt_OP:
969             PL_op = (OP*)SSPOPPTR;
970             break;
971         case SAVEt_HINTS:
972             if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
973                 SvREFCNT_dec((SV*)GvHV(PL_hintgv));
974                 GvHV(PL_hintgv) = NULL;
975             }
976             *(I32*)&PL_hints = (I32)SSPOPINT;
977             Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
978             PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR;
979             if (PL_hints & HINT_LOCALIZE_HH) {
980                 SvREFCNT_dec((SV*)GvHV(PL_hintgv));
981                 GvHV(PL_hintgv) = (HV*)SSPOPPTR;
982                 assert(GvHV(PL_hintgv));
983             } else if (!GvHV(PL_hintgv)) {
984                 /* Need to add a new one manually, else gv_fetchpv() can
985                    add one in this code:
986                    
987                    if (SvTYPE(gv) == SVt_PVGV) {
988                        if (add) {
989                        GvMULTI_on(gv);
990                        gv_init_sv(gv, sv_type);
991                        if (*name=='!' && sv_type == SVt_PVHV && len==1)
992                            require_errno(gv);
993                        }
994                        return gv;
995                    }
996
997                    and it won't have the magic set.  */
998
999                 HV *const hv = newHV();
1000                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1001                 GvHV(PL_hintgv) = hv;
1002             }
1003             assert(GvHV(PL_hintgv));
1004             break;
1005         case SAVEt_COMPPAD:
1006             PL_comppad = (PAD*)SSPOPPTR;
1007             if (PL_comppad)
1008                 PL_curpad = AvARRAY(PL_comppad);
1009             else
1010                 PL_curpad = NULL;
1011             break;
1012         case SAVEt_PADSV_AND_MORTALIZE:
1013             {
1014                 const PADOFFSET off = (PADOFFSET)SSPOPLONG;
1015                 SV **svp;
1016                 ptr = SSPOPPTR;
1017                 assert (ptr);
1018                 svp = AvARRAY((PAD*)ptr) + off;
1019                 /* This mortalizing used to be done by POPLOOP() via itersave.
1020                    But as we have all the information here, we can do it here,
1021                    save even having to have itersave in the struct.  */
1022                 sv_2mortal(*svp);
1023                 *svp = (SV*)SSPOPPTR;
1024             }
1025             break;
1026         case SAVEt_SAVESWITCHSTACK:
1027             {
1028                 dSP;
1029                 AV* const t = (AV*)SSPOPPTR;
1030                 AV* const f = (AV*)SSPOPPTR;
1031                 SWITCHSTACK(t,f);
1032                 PL_curstackinfo->si_stack = f;
1033             }
1034             break;
1035         case SAVEt_SET_SVFLAGS:
1036             {
1037                 const U32 val  = (U32)SSPOPINT;
1038                 const U32 mask = (U32)SSPOPINT;
1039                 sv = (SV*)SSPOPPTR;
1040                 SvFLAGS(sv) &= ~mask;
1041                 SvFLAGS(sv) |= val;
1042             }
1043             break;
1044             /* These are only saved in mathoms.c */
1045         case SAVEt_SVREF:                       /* scalar reference */
1046             value = (SV*)SSPOPPTR;
1047             ptr = SSPOPPTR;
1048             av = NULL; /* what to refcnt_dec */
1049             goto restore_sv;
1050         case SAVEt_LONG:                        /* long reference */
1051             ptr = SSPOPPTR;
1052             *(long*)ptr = (long)SSPOPLONG;
1053             break;
1054         case SAVEt_I16:                         /* I16 reference */
1055             ptr = SSPOPPTR;
1056             *(I16*)ptr = (I16)SSPOPINT;
1057             break;
1058         case SAVEt_I8:                          /* I8 reference */
1059             ptr = SSPOPPTR;
1060             *(I8*)ptr = (I8)SSPOPINT;
1061             break;
1062         case SAVEt_IV:                          /* IV reference */
1063             ptr = SSPOPPTR;
1064             *(IV*)ptr = (IV)SSPOPIV;
1065             break;
1066         case SAVEt_NSTAB:
1067             gv = (GV*)SSPOPPTR;
1068             (void)sv_clear((SV*)gv);
1069             break;
1070         case SAVEt_DESTRUCTOR:
1071             ptr = SSPOPPTR;
1072             (*SSPOPDPTR)(ptr);
1073             break;
1074         case SAVEt_COP_ARYBASE:
1075             ptr = SSPOPPTR;
1076             i = SSPOPINT;
1077             CopARYBASE_set((COP *)ptr, i);
1078             break;
1079         case SAVEt_COMPILE_WARNINGS:
1080             ptr = SSPOPPTR;
1081
1082             if (!specialWARN(PL_compiling.cop_warnings))
1083                 PerlMemShared_free(PL_compiling.cop_warnings);
1084
1085             PL_compiling.cop_warnings = (STRLEN*)ptr;
1086             break;
1087         case SAVEt_RE_STATE:
1088             {
1089                 const struct re_save_state *const state
1090                     = (struct re_save_state *)
1091                     (PL_savestack + PL_savestack_ix
1092                      - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
1093                 PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
1094
1095                 if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
1096                     Safefree(PL_reg_start_tmp);
1097                 }
1098                 if (PL_reg_poscache != state->re_state_reg_poscache) {
1099                     Safefree(PL_reg_poscache);
1100                 }
1101                 Copy(state, &PL_reg_state, 1, struct re_save_state);
1102             }
1103             break;
1104         case SAVEt_PARSER:
1105             ptr = SSPOPPTR;
1106             parser_free((yy_parser *) ptr);
1107             break;
1108         default:
1109             Perl_croak(aTHX_ "panic: leave_scope inconsistency");
1110         }
1111     }
1112 }
1113
1114 void
1115 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1116 {
1117     dVAR;
1118
1119     PERL_ARGS_ASSERT_CX_DUMP;
1120
1121 #ifdef DEBUGGING
1122     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1123     if (CxTYPE(cx) != CXt_SUBST) {
1124         PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1125         PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
1126                       PTR2UV(cx->blk_oldcop));
1127         PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1128         PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1129         PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
1130                       PTR2UV(cx->blk_oldpm));
1131         PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
1132     }
1133     switch (CxTYPE(cx)) {
1134     case CXt_NULL:
1135     case CXt_BLOCK:
1136         break;
1137     case CXt_FORMAT:
1138         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%"UVxf"\n",
1139                 PTR2UV(cx->blk_format.cv));
1140         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%"UVxf"\n",
1141                 PTR2UV(cx->blk_format.gv));
1142         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%"UVxf"\n",
1143                 PTR2UV(cx->blk_format.dfoutgv));
1144         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1145                       (int)CxHASARGS(cx));
1146         PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%"UVxf"\n",
1147                 PTR2UV(cx->blk_format.retop));
1148         break;
1149     case CXt_SUB:
1150         PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
1151                 PTR2UV(cx->blk_sub.cv));
1152         PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1153                 (long)cx->blk_sub.olddepth);
1154         PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1155                 (int)CxHASARGS(cx));
1156         PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1157         PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%"UVxf"\n",
1158                 PTR2UV(cx->blk_sub.retop));
1159         break;
1160     case CXt_EVAL:
1161         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1162                 (long)CxOLD_IN_EVAL(cx));
1163         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1164                 PL_op_name[CxOLD_OP_TYPE(cx)],
1165                 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1166         if (cx->blk_eval.old_namesv)
1167             PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1168                           SvPVX_const(cx->blk_eval.old_namesv));
1169         PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1170                 PTR2UV(cx->blk_eval.old_eval_root));
1171         PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%"UVxf"\n",
1172                 PTR2UV(cx->blk_eval.retop));
1173         break;
1174
1175     case CXt_LOOP_LAZYIV:
1176     case CXt_LOOP_LAZYSV:
1177     case CXt_LOOP_FOR:
1178     case CXt_LOOP_PLAIN:
1179         PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1180         PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1181                 (long)cx->blk_loop.resetsp);
1182         PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
1183                 PTR2UV(cx->blk_loop.my_op));
1184         PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
1185                 PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
1186         /* XXX: not accurate for LAZYSV/IV */
1187         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1188                 PTR2UV(cx->blk_loop.state_u.ary.ary));
1189         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1190                 (long)cx->blk_loop.state_u.ary.ix);
1191         PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1192                 PTR2UV(CxITERVAR(cx)));
1193         break;
1194
1195     case CXt_SUBST:
1196         PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1197                 (long)cx->sb_iters);
1198         PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1199                 (long)cx->sb_maxiters);
1200         PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1201                 (long)cx->sb_rflags);
1202         PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1203                 (long)CxONCE(cx));
1204         PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1205                 cx->sb_orig);
1206         PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1207                 PTR2UV(cx->sb_dstr));
1208         PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1209                 PTR2UV(cx->sb_targ));
1210         PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1211                 PTR2UV(cx->sb_s));
1212         PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1213                 PTR2UV(cx->sb_m));
1214         PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1215                 PTR2UV(cx->sb_strend));
1216         PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1217                 PTR2UV(cx->sb_rxres));
1218         break;
1219     }
1220 #else
1221     PERL_UNUSED_CONTEXT;
1222     PERL_UNUSED_ARG(cx);
1223 #endif  /* DEBUGGING */
1224 }
1225
1226 /*
1227  * Local variables:
1228  * c-indentation-style: bsd
1229  * c-basic-offset: 4
1230  * indent-tabs-mode: t
1231  * End:
1232  *
1233  * ex: set ts=8 sts=4 sw=4 noet:
1234  */