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