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

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