source: trunk/third/perl/scope.c @ 17035

Revision 17035, 24.3 KB checked in by zacheiss, 22 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r17034, which included commits to RCS files with non-trunk default branches.
Line 
1/*    scope.c
2 *
3 *    Copyright (c) 1991-2001, Larry Wall
4 *
5 *    You may distribute under the terms of either the GNU General Public
6 *    License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * "For the fashion of Minas Tirith was such that it was built on seven
12 * levels..."
13 */
14
15#include "EXTERN.h"
16#define PERL_IN_SCOPE_C
17#include "perl.h"
18
19#if defined(PERL_FLEXIBLE_EXCEPTIONS)
20void *
21Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
22                     protect_body_t body, ...)
23{
24    void *ret;
25    va_list args;
26    va_start(args, body);
27    ret = vdefault_protect(pcur_env, excpt, body, &args);
28    va_end(args);
29    return ret;
30}
31
32void *
33Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
34                      protect_body_t body, va_list *args)
35{
36    int ex;
37    void *ret;
38
39    JMPENV_PUSH(ex);
40    if (ex)
41        ret = NULL;
42    else
43        ret = CALL_FPTR(body)(aTHX_ *args);
44    *excpt = ex;
45    JMPENV_POP;
46    return ret;
47}
48#endif
49
50SV**
51Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
52{
53#if defined(DEBUGGING) && !defined(USE_THREADS)
54    static int growing = 0;
55    if (growing++)
56      abort();
57#endif
58    PL_stack_sp = sp;
59#ifndef STRESS_REALLOC
60    av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
61#else
62    av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
63#endif
64#if defined(DEBUGGING) && !defined(USE_THREADS)
65    growing--;
66#endif
67    return PL_stack_sp;
68}
69
70#ifndef STRESS_REALLOC
71#define GROW(old) ((old) * 3 / 2)
72#else
73#define GROW(old) ((old) + 1)
74#endif
75
76PERL_SI *
77Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
78{
79    PERL_SI *si;
80    New(56, si, 1, PERL_SI);
81    si->si_stack = newAV();
82    AvREAL_off(si->si_stack);
83    av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
84    AvALLOC(si->si_stack)[0] = &PL_sv_undef;
85    AvFILLp(si->si_stack) = 0;
86    si->si_prev = 0;
87    si->si_next = 0;
88    si->si_cxmax = cxitems - 1;
89    si->si_cxix = -1;
90    si->si_type = PERLSI_UNDEF;
91    New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
92    return si;
93}
94
95I32
96Perl_cxinc(pTHX)
97{
98    cxstack_max = GROW(cxstack_max);
99    Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);      /* XXX should fix CXINC macro */
100    return cxstack_ix + 1;
101}
102
103void
104Perl_push_return(pTHX_ OP *retop)
105{
106    if (PL_retstack_ix == PL_retstack_max) {
107        PL_retstack_max = GROW(PL_retstack_max);
108        Renew(PL_retstack, PL_retstack_max, OP*);
109    }
110    PL_retstack[PL_retstack_ix++] = retop;
111}
112
113OP *
114Perl_pop_return(pTHX)
115{
116    if (PL_retstack_ix > 0)
117        return PL_retstack[--PL_retstack_ix];
118    else
119        return Nullop;
120}
121
122void
123Perl_push_scope(pTHX)
124{
125    if (PL_scopestack_ix == PL_scopestack_max) {
126        PL_scopestack_max = GROW(PL_scopestack_max);
127        Renew(PL_scopestack, PL_scopestack_max, I32);
128    }
129    PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
130
131}
132
133void
134Perl_pop_scope(pTHX)
135{
136    I32 oldsave = PL_scopestack[--PL_scopestack_ix];
137    LEAVE_SCOPE(oldsave);
138}
139
140void
141Perl_markstack_grow(pTHX)
142{
143    I32 oldmax = PL_markstack_max - PL_markstack;
144    I32 newmax = GROW(oldmax);
145
146    Renew(PL_markstack, newmax, I32);
147    PL_markstack_ptr = PL_markstack + oldmax;
148    PL_markstack_max = PL_markstack + newmax;
149}
150
151void
152Perl_savestack_grow(pTHX)
153{
154    PL_savestack_max = GROW(PL_savestack_max) + 4;
155    Renew(PL_savestack, PL_savestack_max, ANY);
156}
157
158#undef GROW
159
160void
161Perl_tmps_grow(pTHX_ I32 n)
162{
163#ifndef STRESS_REALLOC
164    if (n < 128)
165        n = (PL_tmps_max < 512) ? 128 : 512;
166#endif
167    PL_tmps_max = PL_tmps_ix + n + 1;
168    Renew(PL_tmps_stack, PL_tmps_max, SV*);
169}
170
171
172void
173Perl_free_tmps(pTHX)
174{
175    /* XXX should tmps_floor live in cxstack? */
176    I32 myfloor = PL_tmps_floor;
177    while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
178        SV* sv = PL_tmps_stack[PL_tmps_ix];
179        PL_tmps_stack[PL_tmps_ix--] = Nullsv;
180        if (sv) {
181            SvTEMP_off(sv);
182            SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
183        }
184    }
185}
186
187STATIC SV *
188S_save_scalar_at(pTHX_ SV **sptr)
189{
190    register SV *sv;
191    SV *osv = *sptr;
192
193    sv = *sptr = NEWSV(0,0);
194    if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
195        sv_upgrade(sv, SvTYPE(osv));
196        if (SvGMAGICAL(osv)) {
197            MAGIC* mg;
198            bool oldtainted = PL_tainted;
199            mg_get(osv);                /* note, can croak! */
200            if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) {
201                SAVESPTR(mg->mg_obj);
202                mg->mg_obj = osv;
203            }
204            SvFLAGS(osv) |= (SvFLAGS(osv) &
205                (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
206            PL_tainted = oldtainted;
207        }
208        SvMAGIC(sv) = SvMAGIC(osv);
209        SvFLAGS(sv) |= SvMAGICAL(osv);
210        /* XXX SvMAGIC() is *shared* between osv and sv.  This can
211         * lead to coredumps when both SVs are destroyed without one
212         * of their SvMAGIC() slots being NULLed. */
213        PL_localizing = 1;
214        SvSETMAGIC(sv);
215        PL_localizing = 0;
216    }
217    return sv;
218}
219
220SV *
221Perl_save_scalar(pTHX_ GV *gv)
222{
223    SV **sptr = &GvSV(gv);
224    SSCHECK(3);
225    SSPUSHPTR(SvREFCNT_inc(gv));
226    SSPUSHPTR(SvREFCNT_inc(*sptr));
227    SSPUSHINT(SAVEt_SV);
228    return save_scalar_at(sptr);
229}
230
231SV*
232Perl_save_svref(pTHX_ SV **sptr)
233{
234    SSCHECK(3);
235    SSPUSHPTR(sptr);
236    SSPUSHPTR(SvREFCNT_inc(*sptr));
237    SSPUSHINT(SAVEt_SVREF);
238    return save_scalar_at(sptr);
239}
240
241/* Like save_sptr(), but also SvREFCNT_dec()s the new value.  Can be used to
242 * restore a global SV to its prior contents, freeing new value. */
243void
244Perl_save_generic_svref(pTHX_ SV **sptr)
245{
246    SSCHECK(3);
247    SSPUSHPTR(sptr);
248    SSPUSHPTR(SvREFCNT_inc(*sptr));
249    SSPUSHINT(SAVEt_GENERIC_SVREF);
250}
251
252/* Like save_pptr(), but also Safefree()s the new value if it is different
253 * from the old one.  Can be used to restore a global char* to its prior
254 * contents, freeing new value. */
255void
256Perl_save_generic_pvref(pTHX_ char **str)
257{
258    SSCHECK(3);
259    SSPUSHPTR(str);
260    SSPUSHPTR(*str);
261    SSPUSHINT(SAVEt_GENERIC_PVREF);
262}
263
264void
265Perl_save_gp(pTHX_ GV *gv, I32 empty)
266{
267    SSCHECK(6);
268    SSPUSHIV((IV)SvLEN(gv));
269    SvLEN(gv) = 0; /* forget that anything was allocated here */
270    SSPUSHIV((IV)SvCUR(gv));
271    SSPUSHPTR(SvPVX(gv));
272    SvPOK_off(gv);
273    SSPUSHPTR(SvREFCNT_inc(gv));
274    SSPUSHPTR(GvGP(gv));
275    SSPUSHINT(SAVEt_GP);
276
277    if (empty) {
278        register GP *gp;
279
280        Newz(602, gp, 1, GP);
281
282        if (GvCVu(gv))
283            PL_sub_generation++;        /* taking a method out of circulation */
284        if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
285            gp->gp_io = newIO();
286            IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
287        }
288        GvGP(gv) = gp_ref(gp);
289        GvSV(gv) = NEWSV(72,0);
290        GvLINE(gv) = CopLINE(PL_curcop);
291        GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
292        GvEGV(gv) = gv;
293    }
294    else {
295        gp_ref(GvGP(gv));
296        GvINTRO_on(gv);
297    }
298}
299
300AV *
301Perl_save_ary(pTHX_ GV *gv)
302{
303    AV *oav = GvAVn(gv);
304    AV *av;
305
306    if (!AvREAL(oav) && AvREIFY(oav))
307        av_reify(oav);
308    SSCHECK(3);
309    SSPUSHPTR(gv);
310    SSPUSHPTR(oav);
311    SSPUSHINT(SAVEt_AV);
312
313    GvAV(gv) = Null(AV*);
314    av = GvAVn(gv);
315    if (SvMAGIC(oav)) {
316        SvMAGIC(av) = SvMAGIC(oav);
317        SvFLAGS((SV*)av) |= SvMAGICAL(oav);
318        SvMAGICAL_off(oav);
319        SvMAGIC(oav) = 0;
320        PL_localizing = 1;
321        SvSETMAGIC((SV*)av);
322        PL_localizing = 0;
323    }
324    return av;
325}
326
327HV *
328Perl_save_hash(pTHX_ GV *gv)
329{
330    HV *ohv, *hv;
331
332    SSCHECK(3);
333    SSPUSHPTR(gv);
334    SSPUSHPTR(ohv = GvHVn(gv));
335    SSPUSHINT(SAVEt_HV);
336
337    GvHV(gv) = Null(HV*);
338    hv = GvHVn(gv);
339    if (SvMAGIC(ohv)) {
340        SvMAGIC(hv) = SvMAGIC(ohv);
341        SvFLAGS((SV*)hv) |= SvMAGICAL(ohv);
342        SvMAGICAL_off(ohv);
343        SvMAGIC(ohv) = 0;
344        PL_localizing = 1;
345        SvSETMAGIC((SV*)hv);
346        PL_localizing = 0;
347    }
348    return hv;
349}
350
351void
352Perl_save_item(pTHX_ register SV *item)
353{
354    register SV *sv = NEWSV(0,0);
355
356    sv_setsv(sv,item);
357    SSCHECK(3);
358    SSPUSHPTR(item);            /* remember the pointer */
359    SSPUSHPTR(sv);              /* remember the value */
360    SSPUSHINT(SAVEt_ITEM);
361}
362
363void
364Perl_save_int(pTHX_ int *intp)
365{
366    SSCHECK(3);
367    SSPUSHINT(*intp);
368    SSPUSHPTR(intp);
369    SSPUSHINT(SAVEt_INT);
370}
371
372void
373Perl_save_long(pTHX_ long int *longp)
374{
375    SSCHECK(3);
376    SSPUSHLONG(*longp);
377    SSPUSHPTR(longp);
378    SSPUSHINT(SAVEt_LONG);
379}
380
381void
382Perl_save_I32(pTHX_ I32 *intp)
383{
384    SSCHECK(3);
385    SSPUSHINT(*intp);
386    SSPUSHPTR(intp);
387    SSPUSHINT(SAVEt_I32);
388}
389
390void
391Perl_save_I16(pTHX_ I16 *intp)
392{
393    SSCHECK(3);
394    SSPUSHINT(*intp);
395    SSPUSHPTR(intp);
396    SSPUSHINT(SAVEt_I16);
397}
398
399void
400Perl_save_I8(pTHX_ I8 *bytep)
401{
402    SSCHECK(3);
403    SSPUSHINT(*bytep);
404    SSPUSHPTR(bytep);
405    SSPUSHINT(SAVEt_I8);
406}
407
408void
409Perl_save_iv(pTHX_ IV *ivp)
410{
411    SSCHECK(3);
412    SSPUSHIV(*ivp);
413    SSPUSHPTR(ivp);
414    SSPUSHINT(SAVEt_IV);
415}
416
417/* Cannot use save_sptr() to store a char* since the SV** cast will
418 * force word-alignment and we'll miss the pointer.
419 */
420void
421Perl_save_pptr(pTHX_ char **pptr)
422{
423    SSCHECK(3);
424    SSPUSHPTR(*pptr);
425    SSPUSHPTR(pptr);
426    SSPUSHINT(SAVEt_PPTR);
427}
428
429void
430Perl_save_vptr(pTHX_ void *ptr)
431{
432    SSCHECK(3);
433    SSPUSHPTR(*(char**)ptr);
434    SSPUSHPTR(ptr);
435    SSPUSHINT(SAVEt_VPTR);
436}
437
438void
439Perl_save_sptr(pTHX_ SV **sptr)
440{
441    SSCHECK(3);
442    SSPUSHPTR(*sptr);
443    SSPUSHPTR(sptr);
444    SSPUSHINT(SAVEt_SPTR);
445}
446
447void
448Perl_save_padsv(pTHX_ PADOFFSET off)
449{
450    SSCHECK(4);
451    SSPUSHPTR(PL_curpad[off]);
452    SSPUSHPTR(PL_curpad);
453    SSPUSHLONG((long)off);
454    SSPUSHINT(SAVEt_PADSV);
455}
456
457SV **
458Perl_save_threadsv(pTHX_ PADOFFSET i)
459{
460#ifdef USE_THREADS
461    SV **svp = &THREADSV(i);    /* XXX Change to save by offset */
462    DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
463                          (UV)i, svp, *svp, SvPEEK(*svp)));
464    save_svref(svp);
465    return svp;
466#else
467    Perl_croak(aTHX_ "panic: save_threadsv called in non-threaded perl");
468    return 0;
469#endif /* USE_THREADS */
470}
471
472void
473Perl_save_nogv(pTHX_ GV *gv)
474{
475    SSCHECK(2);
476    SSPUSHPTR(gv);
477    SSPUSHINT(SAVEt_NSTAB);
478}
479
480void
481Perl_save_hptr(pTHX_ HV **hptr)
482{
483    SSCHECK(3);
484    SSPUSHPTR(*hptr);
485    SSPUSHPTR(hptr);
486    SSPUSHINT(SAVEt_HPTR);
487}
488
489void
490Perl_save_aptr(pTHX_ AV **aptr)
491{
492    SSCHECK(3);
493    SSPUSHPTR(*aptr);
494    SSPUSHPTR(aptr);
495    SSPUSHINT(SAVEt_APTR);
496}
497
498void
499Perl_save_freesv(pTHX_ SV *sv)
500{
501    SSCHECK(2);
502    SSPUSHPTR(sv);
503    SSPUSHINT(SAVEt_FREESV);
504}
505
506void
507Perl_save_mortalizesv(pTHX_ SV *sv)
508{
509    SSCHECK(2);
510    SSPUSHPTR(sv);
511    SSPUSHINT(SAVEt_MORTALIZESV);
512}
513
514void
515Perl_save_freeop(pTHX_ OP *o)
516{
517    SSCHECK(2);
518    SSPUSHPTR(o);
519    SSPUSHINT(SAVEt_FREEOP);
520}
521
522void
523Perl_save_freepv(pTHX_ char *pv)
524{
525    SSCHECK(2);
526    SSPUSHPTR(pv);
527    SSPUSHINT(SAVEt_FREEPV);
528}
529
530void
531Perl_save_clearsv(pTHX_ SV **svp)
532{
533    SSCHECK(2);
534    SSPUSHLONG((long)(svp-PL_curpad));
535    SSPUSHINT(SAVEt_CLEARSV);
536}
537
538void
539Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
540{
541    SSCHECK(4);
542    SSPUSHINT(klen);
543    SSPUSHPTR(key);
544    SSPUSHPTR(SvREFCNT_inc(hv));
545    SSPUSHINT(SAVEt_DELETE);
546}
547
548void
549Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
550{
551    register SV *sv;
552    register I32 i;
553
554    for (i = 1; i <= maxsarg; i++) {
555        sv = NEWSV(0,0);
556        sv_setsv(sv,sarg[i]);
557        SSCHECK(3);
558        SSPUSHPTR(sarg[i]);             /* remember the pointer */
559        SSPUSHPTR(sv);                  /* remember the value */
560        SSPUSHINT(SAVEt_ITEM);
561    }
562}
563
564void
565Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
566{
567    SSCHECK(3);
568    SSPUSHDPTR(f);
569    SSPUSHPTR(p);
570    SSPUSHINT(SAVEt_DESTRUCTOR);
571}
572
573void
574Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
575{
576    SSCHECK(3);
577    SSPUSHDXPTR(f);
578    SSPUSHPTR(p);
579    SSPUSHINT(SAVEt_DESTRUCTOR_X);
580}
581
582void
583Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
584{
585    SSCHECK(4);
586    SSPUSHPTR(SvREFCNT_inc(av));
587    SSPUSHINT(idx);
588    SSPUSHPTR(SvREFCNT_inc(*sptr));
589    SSPUSHINT(SAVEt_AELEM);
590    save_scalar_at(sptr);
591}
592
593void
594Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
595{
596    SSCHECK(4);
597    SSPUSHPTR(SvREFCNT_inc(hv));
598    SSPUSHPTR(SvREFCNT_inc(key));
599    SSPUSHPTR(SvREFCNT_inc(*sptr));
600    SSPUSHINT(SAVEt_HELEM);
601    save_scalar_at(sptr);
602}
603
604void
605Perl_save_op(pTHX)
606{
607    SSCHECK(2);
608    SSPUSHPTR(PL_op);
609    SSPUSHINT(SAVEt_OP);
610}
611
612I32
613Perl_save_alloc(pTHX_ I32 size, I32 pad)
614{
615    register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
616                                - (char*)PL_savestack);
617    register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
618
619    /* SSCHECK may not be good enough */
620    while (PL_savestack_ix + elems + 2 > PL_savestack_max)
621        savestack_grow();
622
623    PL_savestack_ix += elems;
624    SSPUSHINT(elems);
625    SSPUSHINT(SAVEt_ALLOC);
626    return start;
627}
628
629void
630Perl_leave_scope(pTHX_ I32 base)
631{
632    register SV *sv;
633    register SV *value;
634    register GV *gv;
635    register AV *av;
636    register HV *hv;
637    register void* ptr;
638    register char* str;
639    I32 i;
640
641    if (base < -1)
642        Perl_croak(aTHX_ "panic: corrupt saved stack index");
643    while (PL_savestack_ix > base) {
644        switch (SSPOPINT) {
645        case SAVEt_ITEM:                        /* normal string */
646            value = (SV*)SSPOPPTR;
647            sv = (SV*)SSPOPPTR;
648            sv_replace(sv,value);
649            PL_localizing = 2;
650            SvSETMAGIC(sv);
651            PL_localizing = 0;
652            break;
653        case SAVEt_SV:                          /* scalar reference */
654            value = (SV*)SSPOPPTR;
655            gv = (GV*)SSPOPPTR;
656            ptr = &GvSV(gv);
657            SvREFCNT_dec(gv);
658            goto restore_sv;
659        case SAVEt_GENERIC_PVREF:               /* generic pv */
660            str = (char*)SSPOPPTR;
661            ptr = SSPOPPTR;
662            if (*(char**)ptr != str) {
663                Safefree(*(char**)ptr);
664                *(char**)ptr = str;
665            }
666            break;
667        case SAVEt_GENERIC_SVREF:               /* generic sv */
668            value = (SV*)SSPOPPTR;
669            ptr = SSPOPPTR;
670            sv = *(SV**)ptr;
671            *(SV**)ptr = value;
672            SvREFCNT_dec(sv);
673            SvREFCNT_dec(value);
674            break;
675        case SAVEt_SVREF:                       /* scalar reference */
676            value = (SV*)SSPOPPTR;
677            ptr = SSPOPPTR;
678        restore_sv:
679            sv = *(SV**)ptr;
680            DEBUG_S(PerlIO_printf(Perl_debug_log,
681                                  "restore svref: %p %p:%s -> %p:%s\n",
682                                  ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
683            if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
684                SvTYPE(sv) != SVt_PVGV)
685            {
686                (void)SvUPGRADE(value, SvTYPE(sv));
687                SvMAGIC(value) = SvMAGIC(sv);
688                SvFLAGS(value) |= SvMAGICAL(sv);
689                SvMAGICAL_off(sv);
690                SvMAGIC(sv) = 0;
691            }
692            /* XXX This branch is pretty bogus.  This code irretrievably
693             * clears(!) the magic on the SV (either to avoid further
694             * croaking that might ensue when the SvSETMAGIC() below is
695             * called, or to avoid two different SVs pointing at the same
696             * SvMAGIC()).  This needs a total rethink.  --GSAR */
697            else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
698                     SvTYPE(value) != SVt_PVGV)
699            {
700                SvFLAGS(value) |= (SvFLAGS(value) &
701                                   (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
702                SvMAGICAL_off(value);
703                /* XXX this is a leak when we get here because the
704                 * mg_get() in save_scalar_at() croaked */
705                SvMAGIC(value) = 0;
706            }
707            SvREFCNT_dec(sv);
708            *(SV**)ptr = value;
709            PL_localizing = 2;
710            SvSETMAGIC(value);
711            PL_localizing = 0;
712            SvREFCNT_dec(value);
713            break;
714        case SAVEt_AV:                          /* array reference */
715            av = (AV*)SSPOPPTR;
716            gv = (GV*)SSPOPPTR;
717            if (GvAV(gv)) {
718                AV *goner = GvAV(gv);
719                SvMAGIC(av) = SvMAGIC(goner);
720                SvFLAGS((SV*)av) |= SvMAGICAL(goner);
721                SvMAGICAL_off(goner);
722                SvMAGIC(goner) = 0;
723                SvREFCNT_dec(goner);
724            }
725            GvAV(gv) = av;
726            if (SvMAGICAL(av)) {
727                PL_localizing = 2;
728                SvSETMAGIC((SV*)av);
729                PL_localizing = 0;
730            }
731            break;
732        case SAVEt_HV:                          /* hash reference */
733            hv = (HV*)SSPOPPTR;
734            gv = (GV*)SSPOPPTR;
735            if (GvHV(gv)) {
736                HV *goner = GvHV(gv);
737                SvMAGIC(hv) = SvMAGIC(goner);
738                SvFLAGS(hv) |= SvMAGICAL(goner);
739                SvMAGICAL_off(goner);
740                SvMAGIC(goner) = 0;
741                SvREFCNT_dec(goner);
742            }
743            GvHV(gv) = hv;
744            if (SvMAGICAL(hv)) {
745                PL_localizing = 2;
746                SvSETMAGIC((SV*)hv);
747                PL_localizing = 0;
748            }
749            break;
750        case SAVEt_INT:                         /* int reference */
751            ptr = SSPOPPTR;
752            *(int*)ptr = (int)SSPOPINT;
753            break;
754        case SAVEt_LONG:                        /* long reference */
755            ptr = SSPOPPTR;
756            *(long*)ptr = (long)SSPOPLONG;
757            break;
758        case SAVEt_I32:                         /* I32 reference */
759            ptr = SSPOPPTR;
760            *(I32*)ptr = (I32)SSPOPINT;
761            break;
762        case SAVEt_I16:                         /* I16 reference */
763            ptr = SSPOPPTR;
764            *(I16*)ptr = (I16)SSPOPINT;
765            break;
766        case SAVEt_I8:                          /* I8 reference */
767            ptr = SSPOPPTR;
768            *(I8*)ptr = (I8)SSPOPINT;
769            break;
770        case SAVEt_IV:                          /* IV reference */
771            ptr = SSPOPPTR;
772            *(IV*)ptr = (IV)SSPOPIV;
773            break;
774        case SAVEt_SPTR:                        /* SV* reference */
775            ptr = SSPOPPTR;
776            *(SV**)ptr = (SV*)SSPOPPTR;
777            break;
778        case SAVEt_VPTR:                        /* random* reference */
779        case SAVEt_PPTR:                        /* char* reference */
780            ptr = SSPOPPTR;
781            *(char**)ptr = (char*)SSPOPPTR;
782            break;
783        case SAVEt_HPTR:                        /* HV* reference */
784            ptr = SSPOPPTR;
785            *(HV**)ptr = (HV*)SSPOPPTR;
786            break;
787        case SAVEt_APTR:                        /* AV* reference */
788            ptr = SSPOPPTR;
789            *(AV**)ptr = (AV*)SSPOPPTR;
790            break;
791        case SAVEt_NSTAB:
792            gv = (GV*)SSPOPPTR;
793            (void)sv_clear((SV*)gv);
794            break;
795        case SAVEt_GP:                          /* scalar reference */
796            ptr = SSPOPPTR;
797            gv = (GV*)SSPOPPTR;
798            if (SvPVX(gv) && SvLEN(gv) > 0) {
799                Safefree(SvPVX(gv));
800            }
801            SvPVX(gv) = (char *)SSPOPPTR;
802            SvCUR(gv) = (STRLEN)SSPOPIV;
803            SvLEN(gv) = (STRLEN)SSPOPIV;
804            gp_free(gv);
805            GvGP(gv) = (GP*)ptr;
806            if (GvCVu(gv))
807                PL_sub_generation++;  /* putting a method back into circulation */
808            SvREFCNT_dec(gv);
809            break;
810        case SAVEt_FREESV:
811            ptr = SSPOPPTR;
812            SvREFCNT_dec((SV*)ptr);
813            break;
814        case SAVEt_MORTALIZESV:
815            ptr = SSPOPPTR;
816            sv_2mortal((SV*)ptr);
817            break;
818        case SAVEt_FREEOP:
819            ptr = SSPOPPTR;
820            if (PL_comppad)
821                PL_curpad = AvARRAY(PL_comppad);
822            op_free((OP*)ptr);
823            break;
824        case SAVEt_FREEPV:
825            ptr = SSPOPPTR;
826            Safefree((char*)ptr);
827            break;
828        case SAVEt_CLEARSV:
829            ptr = (void*)&PL_curpad[SSPOPLONG];
830            sv = *(SV**)ptr;
831            /* Can clear pad variable in place? */
832            if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
833                if (SvTHINKFIRST(sv))
834                    sv_force_normal(sv);
835                if (SvMAGICAL(sv))
836                    mg_free(sv);
837
838                switch (SvTYPE(sv)) {
839                case SVt_NULL:
840                    break;
841                case SVt_PVAV:
842                    av_clear((AV*)sv);
843                    break;
844                case SVt_PVHV:
845                    hv_clear((HV*)sv);
846                    break;
847                case SVt_PVCV:
848                    Perl_croak(aTHX_ "panic: leave_scope pad code");
849                case SVt_RV:
850                case SVt_IV:
851                case SVt_NV:
852                    (void)SvOK_off(sv);
853                    break;
854                default:
855                    (void)SvOK_off(sv);
856                    (void)SvOOK_off(sv);
857                    break;
858                }
859            }
860            else {      /* Someone has a claim on this, so abandon it. */
861                U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
862                switch (SvTYPE(sv)) {   /* Console ourselves with a new value */
863                case SVt_PVAV:  *(SV**)ptr = (SV*)newAV();      break;
864                case SVt_PVHV:  *(SV**)ptr = (SV*)newHV();      break;
865                default:        *(SV**)ptr = NEWSV(0,0);        break;
866                }
867                SvREFCNT_dec(sv);       /* Cast current value to the winds. */
868                SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
869            }
870            break;
871        case SAVEt_DELETE:
872            ptr = SSPOPPTR;
873            hv = (HV*)ptr;
874            ptr = SSPOPPTR;
875            (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
876            SvREFCNT_dec(hv);
877            Safefree(ptr);
878            break;
879        case SAVEt_DESTRUCTOR:
880            ptr = SSPOPPTR;
881            (*SSPOPDPTR)(ptr);
882            break;
883        case SAVEt_DESTRUCTOR_X:
884            ptr = SSPOPPTR;
885            (*SSPOPDXPTR)(aTHXo_ ptr);
886            break;
887        case SAVEt_REGCONTEXT:
888        case SAVEt_ALLOC:
889            i = SSPOPINT;
890            PL_savestack_ix -= i;       /* regexp must have croaked */
891            break;
892        case SAVEt_STACK_POS:           /* Position on Perl stack */
893            i = SSPOPINT;
894            PL_stack_sp = PL_stack_base + i;
895            break;
896        case SAVEt_AELEM:               /* array element */
897            value = (SV*)SSPOPPTR;
898            i = SSPOPINT;
899            av = (AV*)SSPOPPTR;
900            ptr = av_fetch(av,i,1);
901            if (ptr) {
902                sv = *(SV**)ptr;
903                if (sv && sv != &PL_sv_undef) {
904                    if (SvTIED_mg((SV*)av, 'P'))
905                        (void)SvREFCNT_inc(sv);
906                    SvREFCNT_dec(av);
907                    goto restore_sv;
908                }
909            }
910            SvREFCNT_dec(av);
911            SvREFCNT_dec(value);
912            break;
913        case SAVEt_HELEM:               /* hash element */
914            value = (SV*)SSPOPPTR;
915            sv = (SV*)SSPOPPTR;
916            hv = (HV*)SSPOPPTR;
917            ptr = hv_fetch_ent(hv, sv, 1, 0);
918            if (ptr) {
919                SV *oval = HeVAL((HE*)ptr);
920                if (oval && oval != &PL_sv_undef) {
921                    ptr = &HeVAL((HE*)ptr);
922                    if (SvTIED_mg((SV*)hv, 'P'))
923                        (void)SvREFCNT_inc(*(SV**)ptr);
924                    SvREFCNT_dec(hv);
925                    SvREFCNT_dec(sv);
926                    goto restore_sv;
927                }
928            }
929            SvREFCNT_dec(hv);
930            SvREFCNT_dec(sv);
931            SvREFCNT_dec(value);
932            break;
933        case SAVEt_OP:
934            PL_op = (OP*)SSPOPPTR;
935            break;
936        case SAVEt_HINTS:
937            *(I32*)&PL_hints = (I32)SSPOPINT;
938            break;
939        case SAVEt_COMPPAD:
940            PL_comppad = (AV*)SSPOPPTR;
941            if (PL_comppad)
942                PL_curpad = AvARRAY(PL_comppad);
943            else
944                PL_curpad = Null(SV**);
945            break;
946        case SAVEt_PADSV:
947            {
948                PADOFFSET off = (PADOFFSET)SSPOPLONG;
949                ptr = SSPOPPTR;
950                if (ptr)
951                    ((SV**)ptr)[off] = (SV*)SSPOPPTR;
952            }
953            break;
954        default:
955            Perl_croak(aTHX_ "panic: leave_scope inconsistency");
956        }
957    }
958}
959
960void
961Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
962{
963#ifdef DEBUGGING
964    PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
965    if (CxTYPE(cx) != CXt_SUBST) {
966        PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
967        PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
968                      PTR2UV(cx->blk_oldcop));
969        PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
970        PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
971        PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
972        PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
973                      PTR2UV(cx->blk_oldpm));
974        PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
975    }
976    switch (CxTYPE(cx)) {
977    case CXt_NULL:
978    case CXt_BLOCK:
979        break;
980    case CXt_FORMAT:
981        PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
982                PTR2UV(cx->blk_sub.cv));
983        PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n",
984                PTR2UV(cx->blk_sub.gv));
985        PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n",
986                PTR2UV(cx->blk_sub.dfoutgv));
987        PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
988                (int)cx->blk_sub.hasargs);
989        break;
990    case CXt_SUB:
991        PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
992                PTR2UV(cx->blk_sub.cv));
993        PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
994                (long)cx->blk_sub.olddepth);
995        PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
996                (int)cx->blk_sub.hasargs);
997        PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n",
998                (int)cx->blk_sub.lval);
999        break;
1000    case CXt_EVAL:
1001        PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1002                (long)cx->blk_eval.old_in_eval);
1003        PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1004                PL_op_name[cx->blk_eval.old_op_type],
1005                PL_op_desc[cx->blk_eval.old_op_type]);
1006        if (cx->blk_eval.old_namesv)
1007            PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1008                          SvPVX(cx->blk_eval.old_namesv));
1009        PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
1010                PTR2UV(cx->blk_eval.old_eval_root));
1011        break;
1012
1013    case CXt_LOOP:
1014        PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
1015                cx->blk_loop.label);
1016        PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
1017                (long)cx->blk_loop.resetsp);
1018        PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%"UVxf"\n",
1019                PTR2UV(cx->blk_loop.redo_op));
1020        PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
1021                PTR2UV(cx->blk_loop.next_op));
1022        PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%"UVxf"\n",
1023                PTR2UV(cx->blk_loop.last_op));
1024        PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1025                (long)cx->blk_loop.iterix);
1026        PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1027                PTR2UV(cx->blk_loop.iterary));
1028        PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
1029                PTR2UV(CxITERVAR(cx)));
1030        if (CxITERVAR(cx))
1031            PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n",
1032                PTR2UV(cx->blk_loop.itersave));
1033        PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n",
1034                PTR2UV(cx->blk_loop.iterlval));
1035        break;
1036
1037    case CXt_SUBST:
1038        PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1039                (long)cx->sb_iters);
1040        PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1041                (long)cx->sb_maxiters);
1042        PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1043                (long)cx->sb_rflags);
1044        PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1045                (long)cx->sb_once);
1046        PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1047                cx->sb_orig);
1048        PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1049                PTR2UV(cx->sb_dstr));
1050        PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1051                PTR2UV(cx->sb_targ));
1052        PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1053                PTR2UV(cx->sb_s));
1054        PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1055                PTR2UV(cx->sb_m));
1056        PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1057                PTR2UV(cx->sb_strend));
1058        PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1059                PTR2UV(cx->sb_rxres));
1060        break;
1061    }
1062#endif  /* DEBUGGING */
1063}
Note: See TracBrowser for help on using the repository browser.