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