File: PadWalker.xs

package info (click to toggle)
libpadwalker-perl 0.10-1
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 60 kB
  • ctags: 15
  • sloc: perl: 113; makefile: 54
file content (245 lines) | stat: -rw-r--r-- 6,439 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* For development testing */
#define debug_log(x)

/* For 5.005 compatibility */
#ifndef aTHX_
#  define aTHX_
#endif
#ifndef pTHX_
#  define pTHX_
#endif
#ifndef pTHX
#  define pTHX
#endif
#ifndef aTHX
#  define aTHX
#endif
#ifndef CxTYPE
#  define CxTYPE(cx) ((cx)->cx_type)
#endif

/* Originally stolen from pp_ctl.c; now significantly different */

I32
dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
    dTHR;
    I32 i;
    PERL_CONTEXT *cx;
    for (i = startingblock; i >= 0; i--) {
        cx = &cxstk[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
        case CXt_SUB:
    	/* In Perl 5.005, formats just used CXt_SUB */
#ifdef CXt_FORMAT
        case CXt_FORMAT:
#endif
            debug_log((aTHX_ "**(Found sub #%ld)\n", (long)i));
            return i;
        }
    }
    return i;
}

I32
dopoptosub(pTHX_ I32 startingblock)
{
    dTHR;
    return dopoptosub_at(aTHX_ cxstack, startingblock);
}

PERL_CONTEXT*
upcontext(pTHX_ I32 count, U32 *cop_seq_p, PERL_CONTEXT **ccstack_p, I32 *cxix_p)
{
    PERL_SI *top_si = PL_curstackinfo;
    I32 cxix = dopoptosub(aTHX_ cxstack_ix);
    PERL_CONTEXT *cx;
    PERL_CONTEXT *ccstack = cxstack;
    I32 dbcxix;

    for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
            top_si  = top_si->si_prev;
            ccstack = top_si->si_cxstack;
            cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
        }
        if (cxix < 0 && count == 0) {
            if (ccstack_p) *ccstack_p = ccstack;
            if (cxix_p)    *cxix_p    = 1;
            return (PERL_CONTEXT *)0;
        }
        else if (cxix < 0) {
            return (PERL_CONTEXT *)-1;
        }
        if (PL_DBsub && cxix >= 0 &&
                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            count++;
        if (!count--)
            break;

        if (cop_seq_p) *cop_seq_p = ccstack[cxix].blk_oldcop->cop_seq;
        cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
    }
    if (ccstack_p) *ccstack_p = ccstack;
    if (cxix_p)    *cxix_p    = cxix;
    return &ccstack[cxix];
}

/* end thievery */

void
pads_into_hash(AV* pad_namelist, AV* pad_vallist, HV* hash, U32 valid_at_seq)
{
    I32 i;

    for (i=0; i<=av_len(pad_namelist); ++i) {
      SV** name_ptr = av_fetch(pad_namelist, i, 0);

      if (name_ptr) {
        SV*   name_sv = *name_ptr;

	if (SvPOKp(name_sv)) {
          char* name_str = SvPVX(name_sv);

        debug_log((aTHX_ "** %s (%x,%x) [%x]\n", name_str,
               I_32(SvNVX(name_sv)), SvIVX(name_sv), valid_at_seq));
        
        /* Check that this variable is valid at the cop_seq
         * specified, by peeking into the NV and IV slots
         * of the name sv. (This must be one of those "breathtaking
         * optimisations" mentioned in the Panther book).

         * Anonymous subs are stored here with a name of "&",
         * so also check that the name is longer than one char.
         * (Note that the prefix letter is here as well, so a
         * valid variable will _always_ be >1 char)
         */

        if ((0 == valid_at_seq || (valid_at_seq <= SvIVX(name_sv) &&
            valid_at_seq > I_32(SvNVX(name_sv)))) &&
            strlen(name_str) > 1 )

          {
            SV **val_ptr, *val_sv;

            val_ptr = av_fetch(pad_vallist, i, 0);
            val_sv = val_ptr ? *val_ptr : &PL_sv_undef;

	    hv_store(hash, name_str, strlen(name_str),
                     newRV_inc(val_sv), 0);
          }
        }
      }
    }
}

void
padlist_into_hash(AV* padlist, HV* hash, U32 valid_at_seq, U16 depth)
{
    /* We blindly deref this, cos it's always there (AFAIK!) */
    AV* pad_namelist = (AV*) *av_fetch(padlist, 0, FALSE);
    AV* pad_vallist  = (AV*) *av_fetch(padlist, depth, FALSE);

    pads_into_hash(pad_namelist, pad_vallist, hash, valid_at_seq);
}

void
context_vars(PERL_CONTEXT *cx, HV* ret, U32 seq)
{
    if (cx == (PERL_CONTEXT*)-1)
        croak("Not nested deeply enough");
    else if (!cx && !PL_compcv)
        pads_into_hash(PL_comppad_name, PL_comppad, ret, seq);

    else {
        CV* cur_cv = cx ? cx->blk_sub.cv           : PL_compcv;
        U16 depth  = cx ? cx->blk_sub.olddepth + 1 : 1;

        if (!cur_cv)
            die("panic: Context has no CV!\n");
    
        while (cur_cv) {
            /* printf("cv name = %s; seq=%x; depth=%d\n",
                      CvGV(cur_cv) ? GvNAME(CvGV(cur_cv)) : "(null)", seq, depth); */
            padlist_into_hash(CvPADLIST(cur_cv), ret, seq, depth);
            cur_cv = CvOUTSIDE(cur_cv);
            if (cur_cv) depth  = CvDEPTH(cur_cv);
        }
    }
}

MODULE = PadWalker		PACKAGE = PadWalker
PROTOTYPES: DISABLE		

void
peek_my(uplevel)
I32 uplevel;
  PREINIT:
    HV* ret = newHV();
    PERL_CONTEXT *cx, *ccstack;
    U32 seq = PL_curcop->cop_seq;
    I32 cxix;
    bool saweval = FALSE;

  PPCODE:
    cx = upcontext(aTHX_ uplevel, &seq, &ccstack, &cxix);
    debug_log((aTHX_ "** cxix = %d\n", cxix));
    context_vars(cx, ret, seq);

    for (; cxix >= 0; --cxix) {
        debug_log((aTHX_ "** CxTYPE = %d\n", CxTYPE(&ccstack[cxix])));
        switch (CxTYPE(&ccstack[cxix])) {
        case CXt_EVAL:
            switch(ccstack[cxix].blk_eval.old_op_type) {
            case OP_ENTEREVAL:
                /* printf("Found eval: %d\n", cxix); */
                saweval = TRUE;
                seq = ccstack[cxix].blk_oldcop->cop_seq;
                break;
            case OP_REQUIRE:
                goto END;
            }
            break;

        case CXt_SUB:
#ifdef CXt_FORMAT
        case CXt_FORMAT:
#endif
            if (!saweval) goto END;
            context_vars(&ccstack[cxix], ret, seq);

        default:
            if (cxix == 0 && saweval) {
                padlist_into_hash(CvPADLIST(PL_main_cv), ret, seq, 1);
            }
        }
    }

 END:
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));

void
peek_sub(cur_sv)
SV* cur_sv;
  PREINIT:
    CV* cur_cv = (CV*)SvRV(cur_sv);
    HV* ret = newHV();
    AV* cv_padlist;
  PPCODE:
    padlist_into_hash(CvPADLIST(cur_cv), ret, 0, CvDEPTH(cur_cv));
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));

void
_upcontext(uplevel)
I32 uplevel
  PPCODE:
    XPUSHs(sv_2mortal(newSViv((U32)upcontext(aTHX_ uplevel, 0, 0, 0))));