File Coverage

PadWalker.xs
Criterion Covered Total %
statement 217 233 93.1
branch 158 220 71.8
condition n/a
subroutine n/a
pod n/a
total 375 453 82.7


line stmt bran cond sub pod time code
1             #define PERL_NO_GET_CONTEXT
2             #include "EXTERN.h"
3             #include "perl.h"
4             #include "XSUB.h"
5              
6             #ifndef isGV_with_GP
7             #define isGV_with_GP(x) isGV(x)
8             #endif
9              
10             #ifndef CxOLD_OP_TYPE
11             # define CxOLD_OP_TYPE(cx) (0 + (cx)->blk_eval.old_op_type)
12             #endif
13              
14             #ifndef CvISXSUB
15             #define CvISXSUB(sv) CvXSUB(sv)
16             #endif
17              
18             /* For development testing */
19             #ifdef PADWALKER_DEBUGGING
20             # define debug_print(x) printf x
21             #else
22             # define debug_print(x)
23             #endif
24              
25             /* For debugging */
26             #ifdef PADWALKER_DEBUGGING
27             char *
28             cxtype_name(U32 cx_type)
29             {
30             switch(cx_type & CXTYPEMASK)
31             {
32             case CXt_NULL: return "null";
33             case CXt_SUB: return "sub";
34             case CXt_EVAL: return "eval";
35             case CXt_LOOP: return "loop";
36             case CXt_SUBST: return "subst";
37             case CXt_BLOCK: return "block";
38             case CXt_FORMAT: return "format";
39              
40             default: debug_print(("Unknown context type 0x%lx\n", cx_type));
41             return "(unknown)";
42             }
43             }
44              
45             void
46             show_cxstack(void)
47             {
48             I32 i;
49             for (i = cxstack_ix; i>=0; --i)
50             {
51             printf(" =%ld= %s (%lx)", (long)i,
52             cxtype_name(CxTYPE(&cxstack[i])), cxstack[i].blk_oldcop->cop_seq);
53             if (CxTYPE(&cxstack[i]) == CXt_SUB) {
54             CV *cv = cxstack[i].blk_sub.cv;
55             printf("\t%s", (cv && CvGV(cv)) ? GvNAME(CvGV(cv)) :"(null)");
56             }
57             printf("\n");
58             }
59             }
60             #else
61             # define show_cxstack()
62             #endif
63              
64             #ifndef SvOURSTASH
65             # ifdef OURSTASH
66             # define SvOURSTASH OURSTASH
67             # else
68             # define SvOURSTASH GvSTASH
69             # endif
70             #endif
71              
72             #ifndef COP_SEQ_RANGE_LOW
73             # define COP_SEQ_RANGE_LOW(sv) U_32(SvNVX(sv))
74             #endif
75             #ifndef COP_SEQ_RANGE_HIGH
76             # define COP_SEQ_RANGE_HIGH(sv) U_32(SvUVX(sv))
77             #endif
78              
79             #ifndef PadARRAY
80             typedef AV PADNAMELIST;
81             typedef SV PADNAME;
82             # if PERL_VERSION < 8 || (PERL_VERSION == 8 && !PERL_SUBVERSION)
83             typedef AV PADLIST;
84             typedef AV PAD;
85             # endif
86             # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl))
87             # define PadlistMAX(pl) AvFILLp(pl)
88             # define PadlistNAMES(pl) (*PadlistARRAY(pl))
89             # define PadnamelistARRAY(pnl) ((PADNAME **)AvARRAY(pnl))
90             # define PadnamelistMAX(pnl) AvFILLp(pnl)
91             # define PadARRAY AvARRAY
92             # define PadnameIsOUR(pn) !!(SvFLAGS(pn) & SVpad_OUR)
93             # define PadnameOURSTASH(pn) SvOURSTASH(pn)
94             # define PadnameOUTER(pn) !!SvFAKE(pn)
95             # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL)
96             #endif
97              
98              
99             /* Originally stolen from pp_ctl.c; now significantly different */
100              
101             I32
102 56           dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
103             {
104             dTHR;
105             I32 i;
106             PERL_CONTEXT *cx;
107 105 100         for (i = startingblock; i >= 0; i--) {
108 83           cx = &cxstk[i];
109 83 100         switch (CxTYPE(cx)) {
110             default:
111 49           continue;
112             case CXt_SUB:
113             /* In Perl 5.005, formats just used CXt_SUB */
114             #ifdef CXt_FORMAT
115             case CXt_FORMAT:
116             #endif
117             debug_print(("**dopoptosub_at: found sub #%ld\n", (long)i));
118 34           return i;
119             }
120             }
121             debug_print(("**dopoptosub_at: not found #%ld\n", (long)i));
122 22           return i;
123             }
124              
125             I32
126 34           dopoptosub(pTHX_ I32 startingblock)
127             {
128             dTHR;
129 34           return dopoptosub_at(aTHX_ cxstack, startingblock);
130             }
131              
132             /* This function is based on the code of pp_caller */
133             PERL_CONTEXT*
134 34           upcontext(pTHX_ I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p,
135             I32 *cxix_from_p, I32 *cxix_to_p)
136             {
137 34           PERL_SI *top_si = PL_curstackinfo;
138 34           I32 cxix = dopoptosub(aTHX_ cxstack_ix);
139 34           PERL_CONTEXT *ccstack = cxstack;
140              
141 34 50         if (cxix_from_p) *cxix_from_p = cxstack_ix+1;
142 34 50         if (cxix_to_p) *cxix_to_p = cxix;
143             for (;;) {
144             /* we may be in a higher stacklevel, so dig down deeper */
145 56 100         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
    100          
146 2           top_si = top_si->si_prev;
147 2           ccstack = top_si->si_cxstack;
148 2           cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
149 2 50         if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
    50          
150 2 50         if (cxix_to_p) *cxix_to_p = cxix;
151             }
152 54 100         if (cxix < 0 && count == 0) {
    100          
153 19 50         if (ccstack_p) *ccstack_p = ccstack;
154 19           return (PERL_CONTEXT *)0;
155             }
156 35 100         else if (cxix < 0)
157 1           return (PERL_CONTEXT *)-1;
158 34 50         if (PL_DBsub && cxix >= 0 &&
    50          
    50          
159 34           ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
160 0           count++;
161 34 100         if (!count--)
162 14           break;
163              
164 20 100         if (cop_p) *cop_p = ccstack[cxix].blk_oldcop;
165 20           cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
166 20 50         if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p;
    50          
167 20 50         if (cxix_to_p) *cxix_to_p = cxix;
168 20           }
169 14 50         if (ccstack_p) *ccstack_p = ccstack;
170 14           return &ccstack[cxix];
171             }
172              
173             /* end thievery */
174              
175             SV*
176 17           fetch_from_stash(pTHX_ HV *stash, char *name_str, U32 name_len)
177             {
178             /* This isn't the most efficient approach, but it has
179             * the advantage that it uses documented API functions. */
180 17 50         char *package_name = HvNAME(stash);
    50          
    50          
    0          
    50          
    50          
181             char *qualified_name;
182 17           SV *ret = 0; /* Initialise to silence spurious compiler warning */
183            
184 17           New(0, qualified_name, strlen(package_name) + 2 + name_len, char);
185 17           strcpy(qualified_name, package_name);
186 17           strcat(qualified_name, "::");
187 17           strcat(qualified_name, name_str+1);
188              
189             debug_print(("fetch_from_stash: Looking for %c%s\n",
190             name_str[0], qualified_name));
191 17           switch (name_str[0]) {
192 15           case '$': ret = get_sv(qualified_name, FALSE); break;
193 0           case '@': ret = (SV*) get_av(qualified_name, FALSE); break;
194 2           case '%': ret = (SV*) get_hv(qualified_name, FALSE); break;
195 17           default: die("PadWalker: variable '%s' of unknown type", name_str);
196             }
197             if (ret)
198             debug_print(("%s\n", sv_peek(ret)));
199             else
200             /* I don't _think_ this should ever happen */
201             debug_print(("XXXX - Variable %c%s not found\n",
202             name_str[0], qualified_name));
203 17           Safefree(qualified_name);
204 17           return ret;
205             }
206              
207             void
208 68           pads_into_hash(pTHX_ PADNAMELIST* pad_namelist, PAD* pad_vallist, HV* my_hash,
209             HV* our_hash, U32 valid_at_seq)
210             {
211             I32 i;
212              
213             debug_print(("pads_into_hash(%p, %p, ..)\n",
214             (void*)pad_namelist, (void*) pad_vallist));
215              
216 764 100         for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
217 696           PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i];
218              
219 696 100         if (name_sv) {
220 530           char *name_str = PadnamePV(name_sv);
221 530 100         if (name_str) {
222              
223             debug_print(("** %s (%lx,%lx) [%lx]%s\n", name_str,
224             COP_SEQ_RANGE_LOW(name_sv), COP_SEQ_RANGE_HIGH(name_sv), valid_at_seq,
225             PadnameOUTER(name_sv) ? " " : ""));
226            
227             /* Check that this variable is valid at the cop_seq
228             * specified, by peeking into the NV and IV slots
229             * of the name sv. (This must be one of those "breathtaking
230             * optimisations" mentioned in the Panther book).
231              
232             * Anonymous subs are stored here with a name of "&",
233             * so also check that the name is longer than one char.
234             * (Note that the prefix letter is here as well, so a
235             * valid variable will _always_ be >1 char)
236             */
237              
238 346 100         if ((PadnameOUTER(name_sv) || 0 == valid_at_seq ||
    100          
    100          
239 211 100         (valid_at_seq <= COP_SEQ_RANGE_HIGH(name_sv) &&
240 123 50         valid_at_seq > COP_SEQ_RANGE_LOW(name_sv))) &&
241 123           strlen(name_str) > 1 )
242              
243             {
244             SV *val_sv;
245 123           U32 name_len = strlen(name_str);
246 123           bool is_our = PadnameIsOUR(name_sv);
247              
248             debug_print(((is_our ? "** FOUND OUR %s\n"
249             : "** FOUND MY %s\n"), name_str));
250              
251 123 100         if ( hv_exists(my_hash, name_str, name_len)
252 116 100         || hv_exists(our_hash, name_str, name_len))
253             {
254             debug_print(("** key already exists - ignoring!\n"));
255             }
256             else {
257 109 100         if (is_our) {
258 17           val_sv = fetch_from_stash(aTHX_ PadnameOURSTASH(name_sv),
259             name_str, name_len);
260 17 50         if (!val_sv) {
261             debug_print(("Value of our variable is undefined\n"));
262 17           val_sv = &PL_sv_undef;
263             }
264             }
265             else
266             {
267 92           val_sv =
268 92 50         pad_vallist ? PadARRAY(pad_vallist)[i] : &PL_sv_undef;
269 92 50         if (!val_sv) val_sv = &PL_sv_undef;
270             }
271              
272 109 50         hv_store((is_our ? our_hash : my_hash), name_str, PadnameUTF8(name_sv) ? -name_len : name_len,
    100          
273             (val_sv ? newRV_inc(val_sv) : &PL_sv_undef), 0);
274             }
275             }
276             }
277             }
278             }
279 68           }
280              
281             void
282 68           padlist_into_hash(pTHX_ PADLIST* padlist, HV* my_hash, HV* our_hash,
283             U32 valid_at_seq, long depth)
284             {
285             PADNAMELIST *pad_namelist;
286             PAD *pad_vallist;
287            
288 68 100         if (depth == 0) depth = 1;
289              
290 68 50         if (!padlist) {
291             /* Probably an XSUB */
292 0           die("PadWalker: cv has no padlist");
293             }
294 68           pad_namelist = PadlistNAMES(padlist);
295 68           pad_vallist = PadlistARRAY(padlist)[depth];
296              
297 68           pads_into_hash(aTHX_ pad_namelist, pad_vallist, my_hash, our_hash, valid_at_seq);
298 68           }
299              
300             void
301 37           context_vars(pTHX_ PERL_CONTEXT *cx, HV* my_ret, HV* our_ret, U32 seq, CV *cv)
302             {
303             /* If cx is null, we take that to mean that we should look
304             * at the cv instead
305             */
306              
307             debug_print(("**context_vars(%p, %p, %p, 0x%lx)\n",
308             (void*)cx, (void*)my_ret, (void*)our_ret, (long)seq));
309 37 100         if (cx == (PERL_CONTEXT*)-1)
310 1           croak("Not nested deeply enough");
311              
312             else {
313 36 100         CV* cur_cv = cx ? cx->blk_sub.cv : cv;
314 36 100         long depth = cx ? cx->blk_sub.olddepth + 1 : 1;
315              
316 36 50         if (!cur_cv)
317 0           die("panic: Context has no CV!\n");
318            
319 101 100         while (cur_cv) {
320             debug_print(("\tcv name = %s; depth=%ld\n",
321             CvGV(cur_cv) ? GvNAME(CvGV(cur_cv)) :"(null)", depth));
322 65 100         if (CvPADLIST(cur_cv))
323 64           padlist_into_hash(aTHX_ CvPADLIST(cur_cv), my_ret, our_ret, seq, depth);
324 65           cur_cv = CvOUTSIDE(cur_cv);
325 65 100         if (cur_cv) depth = CvDEPTH(cur_cv);
326             }
327             }
328 36           }
329              
330             void
331 27           do_peek(pTHX_ I32 uplevel, HV* my_hash, HV* our_hash)
332             {
333             PERL_CONTEXT *cx, *ccstack;
334 27           COP *cop = 0;
335             I32 cxix_from, cxix_to, i;
336 27           bool first_eval = TRUE;
337              
338             show_cxstack();
339 27           if (PL_curstackinfo->si_type != PERLSI_MAIN)
340             debug_print(("!! We're in a higher stack level\n"));
341              
342 27           cx = upcontext(aTHX_ uplevel, &cop, &ccstack, &cxix_from, &cxix_to);
343             debug_print(("** cxix = (%ld,%ld)\n", cxix_from, cxix_to));
344 27 100         if (cop == 0) {
345             debug_print(("**Setting cop to PL_curcop\n"));
346 14           cop = PL_curcop;
347             }
348             debug_print(("**Cop file = %s\n", CopFILE(cop)));
349              
350 27           context_vars(aTHX_ cx, my_hash, our_hash, cop->cop_seq, PL_main_cv);
351              
352 49 100         for (i = cxix_from-1; i > cxix_to; --i) {
353             debug_print(("** CxTYPE = %s (cxix = %ld)\n",
354             cxtype_name(CxTYPE(&ccstack[i])), i));
355 25           switch (CxTYPE(&ccstack[i])) {
356             case CXt_EVAL:
357             debug_print(("\told_op_type = %ld\n", CxOLD_OP_TYPE(&ccstack[i])));
358 7           switch(CxOLD_OP_TYPE(&ccstack[i])) {
359             case OP_ENTEREVAL:
360 5 100         if (first_eval) {
361 3           context_vars(aTHX_ 0, my_hash, our_hash, cop->cop_seq, ccstack[i].blk_eval.cv);
362 3           first_eval = FALSE;
363             }
364 5           context_vars(aTHX_ 0, my_hash, our_hash, ccstack[i].blk_oldcop->cop_seq,
365 5           ccstack[i].blk_eval.cv);
366 5           break;
367             case OP_REQUIRE:
368             case OP_DOFILE:
369             debug_print(("blk_eval.cv = %p\n", (void*) ccstack[i].blk_eval.cv));
370 2 50         if (first_eval)
371 2           context_vars(aTHX_ 0, my_hash, our_hash,
372 4           cop->cop_seq, ccstack[i].blk_eval.cv);
373 2           return;
374             /* If it's OP_ENTERTRY, we skip this altogether. */
375             }
376 5           break;
377              
378             case CXt_SUB:
379             #ifdef CXt_FORMAT
380             case CXt_FORMAT:
381             #endif
382 0           Perl_die(aTHX_ "PadWalker: internal error");
383             exit(EXIT_FAILURE);
384             }
385             }
386             }
387              
388             void
389 7           get_closed_over(pTHX_ CV *cv, HV *hash, HV *indices)
390             {
391             I32 i;
392             U32 val_depth;
393             PADNAMELIST *pad_namelist;
394             PAD *pad_vallist;
395              
396 7 100         if (CvISXSUB(cv) || !CvPADLIST(cv)) {
    50          
397 1           return;
398             }
399              
400 6 100         val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
401 6           pad_namelist = PadlistNAMES(CvPADLIST(cv));
402 6           pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth];
403              
404             debug_print(("PadlistMAX(CvPADLIST(cv)) = %ld\n",
405             PadlistMAX(CvPADLIST(cv)) ));
406            
407 72 100         for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
408 66           PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i];
409              
410 66 50         if (name_sv && PadnamePV(name_sv)) {
    100          
411 15           char* name_str = PadnamePV(name_sv);
412 15           STRLEN name_len = strlen(name_str);
413            
414 15 100         if (PadnameOUTER(name_sv) && !PadnameIsOUR(name_sv)) {
    100          
415 8           SV *val_sv = PadARRAY(pad_vallist)[i];
416 8 50         if (!val_sv) val_sv = &PL_sv_undef;
417             #ifdef PADWALKER_DEBUGGING
418             debug_print(("Found a fake slot: %s\n", name_str));
419             if (val == 0)
420             debug_print(("value is null\n"));
421             else
422             sv_dump(*val);
423             #endif
424 8           hv_store(hash, name_str, name_len, newRV_inc(val_sv), 0);
425 8 50         if (indices) {
426             /* Create a temporary SV as a way of getting perl to
427             * stringify 'i' for us. */
428 0           SV *i_sv = newSViv(i);
429 0           hv_store_ent(indices, i_sv, newRV_inc(val_sv), 0);
430 0           SvREFCNT_dec(i_sv);
431             }
432             }
433             }
434             }
435             }
436              
437             char *
438 8           get_var_name(CV *cv, SV *var)
439             {
440             I32 i;
441 8 100         U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
442 8           PADNAMELIST *pad_namelist = PadlistNAMES(CvPADLIST(cv));
443 8           PAD *pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth];
444              
445 40 50         for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
446 40           PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
447             char* name_str;
448              
449 40 100         if ( name && (name_str = PadnamePV(name))
    50          
450 19 100         && PadARRAY(pad_vallist)[i] == var) {
451 8           return name_str;
452             }
453             }
454 0           return 0;
455             }
456              
457             CV *
458 7           up_cv(pTHX_ I32 uplevel, const char * caller_name)
459             {
460             PERL_CONTEXT *cx, *ccstack;
461             I32 cxix_from, cxix_to, i;
462              
463 7 50         if (uplevel < 0)
464 0           croak("%s: sub is < 0", caller_name);
465              
466 7           cx = upcontext(aTHX_ uplevel, 0, &ccstack, &cxix_from, &cxix_to);
467 7 50         if (cx == (PERL_CONTEXT *)-1) {
468 0           croak("%s: Not nested deeply enough", caller_name);
469             return 0; /* NOT REACHED, but stop picky compilers from whining */
470             }
471 7 50         else if (cx)
472 0           return cx->blk_sub.cv;
473            
474             else {
475              
476 12 100         for (i = cxix_from-1; i > cxix_to; --i)
477 9 100         if (CxTYPE(&ccstack[i]) == CXt_EVAL) {
478 6           I32 old_op_type = CxOLD_OP_TYPE(&ccstack[i]);
479 6 100         if (old_op_type == OP_REQUIRE || old_op_type == OP_DOFILE)
    100          
480 4           return ccstack[i].blk_eval.cv;
481             }
482              
483 7           return PL_main_cv;
484             }
485             }
486              
487             STATIC bool
488 3           is_scalar_type(SV *sv) {
489 5 100         return !(
    50          
490 3           SvTYPE(sv) == SVt_PVAV
491 2 50         || SvTYPE(sv) == SVt_PVHV
492 2 50         || SvTYPE(sv) == SVt_PVCV
493 2 50         || isGV_with_GP(sv)
    0          
    0          
494 2           || SvTYPE(sv) == SVt_PVIO
495             );
496             }
497              
498             STATIC bool
499 4           is_correct_type(SV *orig, SV *restore) {
500 4           return (
501 4           ( SvTYPE(orig) == SvTYPE(restore) )
502 7           ||
503 3 50         ( is_scalar_type(orig) && is_scalar_type(restore) )
504             );
505             }
506              
507              
508             MODULE = PadWalker PACKAGE = PadWalker
509             PROTOTYPES: DISABLE
510              
511             void
512             peek_my(uplevel)
513             I32 uplevel;
514             PREINIT:
515 26           HV* ret = newHV();
516 26           HV* ignore = newHV();
517             PPCODE:
518 26           do_peek(aTHX_ uplevel, ret, ignore);
519 25           SvREFCNT_dec((SV*) ignore);
520 25 50         EXTEND(SP, 1);
521 25           PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
522              
523             void
524             peek_our(uplevel)
525             I32 uplevel;
526             PREINIT:
527 1           HV* ret = newHV();
528 1           HV* ignore = newHV();
529             PPCODE:
530 1           do_peek(aTHX_ uplevel, ignore, ret);
531 1           SvREFCNT_dec((SV*) ignore);
532 1 50         EXTEND(SP, 1);
533 1           PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
534              
535              
536             void
537             peek_sub(cv)
538             CV* cv;
539             PREINIT:
540 6           HV* ret = newHV();
541 6           HV* ignore = newHV();
542             PPCODE:
543 5 100         if (CvISXSUB(cv))
544 1           die("PadWalker: cv has no padlist");
545 4           padlist_into_hash(aTHX_ CvPADLIST(cv), ret, ignore, 0, CvDEPTH(cv));
546 4           SvREFCNT_dec((SV*) ignore);
547 4 50         EXTEND(SP, 1);
548 4           PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
549              
550             void
551             set_closed_over(sv, pad)
552             SV* sv;
553             HV* pad;
554             PREINIT:
555             I32 i;
556 4           CV *cv = (CV *)SvRV(sv);
557 4 50         U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
558 4           PADNAMELIST *pad_namelist = PadlistNAMES(CvPADLIST(cv));
559 4           PAD *pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth];
560             CODE:
561 23 100         for (i=PadnamelistMAX(pad_namelist); i>=0; --i) {
562 20           PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
563             char* name_str;
564              
565 20 50         if (name && (name_str = PadnamePV(name))) {
    100          
566 10           STRLEN name_len = strlen(name_str);
567              
568 10 100         if (PadnameOUTER(name) && !PadnameIsOUR(name)) {
    50          
569 7           SV **restore_ref = hv_fetch(pad, name_str, name_len, FALSE);
570 7 100         if ( restore_ref ) {
571 4 50         if ( SvROK(*restore_ref) ) {
572 4           SV *restore = SvRV(*restore_ref);
573 4           SV *orig = PadARRAY(pad_vallist)[i];
574 4           int restore_type = SvTYPE(restore);
575              
576 4 50         if ( !orig || is_correct_type(orig, restore) ) {
    100          
577 3           SvREFCNT_inc(restore);
578              
579 3           PadARRAY(pad_vallist)[i] = restore;
580             } else {
581 1           croak("Incorrect reftype for variable %s (got %s expected %s)", name_str, sv_reftype(restore, 0), sv_reftype(orig, 0));
582             }
583             } else {
584 0           croak("The variable for %s is not a reference", name_str);
585             }
586             }
587             }
588             }
589             }
590              
591              
592              
593             void
594             closed_over(cv)
595             CV* cv;
596             PREINIT:
597 7           HV* ret = newHV();
598             HV* targs;
599             PPCODE:
600 7 50         if (GIMME_V == G_ARRAY) {
    100          
601 1           targs = newHV();
602 1           get_closed_over(aTHX_ cv, ret, targs);
603            
604 1 50         EXTEND(SP, 2);
605 1           PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
606 1           PUSHs(sv_2mortal(newRV_noinc((SV*)targs)));
607             }
608             else {
609 6           get_closed_over(aTHX_ cv, ret, 0);
610            
611 6 50         EXTEND(SP, 1);
612 6           PUSHs(sv_2mortal(newRV_noinc((SV*)ret)));
613             }
614              
615             char*
616             var_name(sub, var_ref)
617             SV* sub;
618             SV* var_ref;
619             PREINIT:
620             SV *cv;
621             CODE:
622 8 50         if (!SvROK(var_ref))
623 0           croak("Usage: PadWalker::var_name(sub, var_ref)");
624            
625 8 100         if (SvROK(sub)) {
626 1           cv = SvRV(sub);
627 1 50         if (SvTYPE(cv) != SVt_PVCV)
628 0           croak("PadWalker::var_name: sub is neither a CODE reference nor a number");
629             } else
630 7 50         cv = (SV *) up_cv(aTHX_ SvIV(sub), "PadWalker::upcontext");
631            
632 8           RETVAL = get_var_name((CV *) cv, SvRV(var_ref));
633             OUTPUT:
634             RETVAL
635              
636             void
637             _upcontext(uplevel)
638             I32 uplevel
639             PPCODE:
640             /* This is used by Devel::Caller. */
641 0 0         XPUSHs(sv_2mortal(newSViv((IV)upcontext(aTHX_ uplevel, 0, 0, 0, 0))));