PadWalker-2.3/000755 000765 000120 00000000000 13201411763 013464 5ustar00robinadmin000000 000000 PadWalker-2.3/Changes000644 000765 000120 00000015226 13201367573 014776 0ustar00robinadmin000000 000000 Revision history for Perl extension PadWalker. 0.01 Thu Nov 9 12:58:10 2000 - original version; created by h2xs 1.19 Revision history between 0.01 and 0.03 has been lost in the mists of time. Sorry about that. 0.03 was the first public release. 0.04 Thu Jul 19 13:50:19 BST 2001 - Applied patch from Richard Soderberg to let it compile under ithreads 0.05 Thu Jan 10 21:12:10 GMT 2002 - Experimental peek_sub routine 0.06 Wed Mar 6 22:16:13 GMT 2002 - Proper test script - Two bug fixes 0.07 Thu Mar 14 19:56:29 GMT 2002 - Clean up POD documentation - Behave properly with debugger - Work under Perl 5.005 0.08 Mon Mar 18 17:54:16 GMT 2002 - _upcontext() XSUB, for Richard Clamp - work properly with recursion - see past eval 0.09 Wed May 21 17:24:32 BST 2003 - compile on threaded builds - skip test 9 if we're on Perl 5.8. (Otherwise it fails.) 0.10 Wed Jul 30 18:40:03 BST 2003 - accommodate the new versions of perl (5.8.1) - acknowledge that test 9 fails because nested eval handling is simply broken. (Fix in a future release.) 0.11 Wed Aug 10 20:06:41 BST 2005 - fix various nasty bugs, specifically: o peek_my(1) now works correctly in a sub called from the top level; o deal better with sub calls across source files - don't return 'our' variables. (It is peek_my(), after all! And the values were never properly returned.) 0.12 Tue Aug 16 15:40:04 BST 2005 - make it work (up to a point) with Perl 5.6. 0.13 Mon Oct 3 11:54:23 BST 2005 - don't build a debugging build unless explicitly told to! 0.14 Thu Oct 6 17:19:06 BST 2005 - Fix the bugs reported by Dave Mitchell: o if one variable masks another, make sure we return the appropriate one; o for a variable whose value has been lost, return undef rather than the name of the variable; o Don't die if PadWalker is called from a closure whose containing scope has disappeared. 0.99 Fri Oct 7 17:23:09 BST 2005 - Make peek_sub return the values, if possible, even when it's not in the call chain; - Allow an our variable to mask a my variable, and vice versa; - Add peek_our and closed_over routines. 0.99_91 Thu Oct 13 17:35:11 BST 2005 - Make peek_my work correctly when called from a do "file"; - Add var_name routine; - Add an :all EXPORT_TAG; - Drop support for perl < 5.8; - Eliminate compiler warnings (at least on gcc). 0.99_92 Sat Oct 15 00:17:24 BST 2005 - Add license info to META.yml; - Use tabs consistently in the Changes file... - Don't use snprintf (apparently Bill Gates doesn't approve); - ignore 'our' variables in closed_over(); - Eliminate more compiler warnings, this time on Win32. 0.99_93 Fri Oct 28 13:18:20 BST 2005 - Change the sekrit undocumented second return value of closed_over() to something slightly different. 1.0 Wed Nov 2 12:25:49 GMT 2005 - Bump version number to 1.0 1.1 Sun Oct 22 16:13:40 BST 2006 - Accommodate change 27312 "Store the stash for our in magic slot" (See http://www.mail-archive.com/perl5-changes@perl.org/msg14073.html or http://public.activestate.com/cgi-bin/perlbrowse/27312) See also http://public.activestate.com/cgi-bin/perlbrowse/27306 1.2 Thu Nov 16 22:33:27 GMT 2006 - Change prerequisites to accurately reflect versions of Perl that PadWalker actually works with (i.e. 5.8.2 or later). - Fix memory leak: thanks to Rocco Caputo 1.3 Tue Jan 2 23:10:35 GMT 2007 - Accommodate changes 29629-29630 "Move the low/high cop sequences from NVX/IVX to a two U32 structure". 1.4 Fri Jan 5 09:12:11 GMT 2007 - Accommodate change 29679 "Rename OURSTASH to SvOURSTASH and OURSTASH_set to SvOURSTASH_set". (Dear Nick, please stop breaking PadWalker. kthxbye.) 1.5 Fri Jan 5 16:22:27 GMT 2007 - Fix egregrious bug in 1.4 :-( 1.6 Mon Jan 14 10:48:09 GMT 2008 - Make _upcontext work in 64-bit architectures. (http://rt.cpan.org/Ticket/Display.html?id=32287) Thanks to Niko Tyni. 1.7 Mon Feb 4 09:56:31 GMT 2008 - Keep up with changes in blead post-5.10 (@33030) 1.8 Thu 25 Jun 2009 21:17:17 BST - Apply patches from doy (#41710) and nothingmuch (set_closed_over). 1.9 Fri 26 Jun 2009 10:01:17 BST - Identical to 1.8, but with the bogus metadata ._ files removed from the distributed tar file. 1.91 Wed 14 Jul 2010 01:07:05 BST - Incorporate patches from Florian Ragwitz and Yuval Kogman (see http://github.com/robinhouston/PadWalker/commits/master) 1.92 Thu 15 Jul 2010 17:05:05 BST - Remove "Jobsian dot file cruft" reported by Steve Mynott. - Incorporate patch from Fuji, Goro, correcting earlier patch from Yuval Kogman. 1.93 Sun 5 Feb 2012 15:52:57 GMT - Correct the version number in META.yml (https://rt.cpan.org/Ticket/Display.html?id=59459) Do this by using MakeMaker to auto-generate META.yml, to prevent similar problems in future. This is possible because the new MakeMaker parameter MIN_PERL_VERSION was added in MakeMaker 6.47_01; the fact that this didn’t used to exist is the reason we managed META.yml by hand till now. 1.94 Tue 26 Jun 2012 09:51:27 BST - Make one of the tests a bit more flexible, to accommodate a subtle change in behaviour caused by a recent change to perl (viz a0d2bbd5c47035a4f7369e4fddd46b502764d86e). 1.95 Thu 23 Aug 2012 11:42:21 BST - Pad changes in 5.17.4-to-be This is a patch from Father Chrysostomous. See https://rt.cpan.org/Public/Bug/Display.html?id=79154 1.96 Fri 24 Aug 2012 13:03:31 BST - Restore compatibility with Perl 5.8 Thanks again to Father Chrysostomous 1.97 Sun 27 Oct 2013 10:09:41 GMT - Improve peek_sub error handling Thanks to Zefram for the bug report. See https://rt.cpan.org/Ticket/Display.html?id=89679 1.98 Sun 27 Oct 2013 16:27:19 GMT - Make new test compatible with old versions of perl. 1.99 Tue 11 Nov 2014 15:01:37 CET - Make it compatible with bleadperl. Patch from Father Chrysostomous at https://rt.cpan.org/Public/Bug/Display.html?id=100262 1.99_1 Tue 11 Nov 2014 19:38:17 CET - Restore compatibility with perl 5.8 Patch from paul@city-fan.org at https://rt.cpan.org/Public/Bug/Display.html?id=100262#txn-1431869 2.0 Mon 8 Dec 2014 13:45:37 GMT - Restore compatibility with bleadperl Patch from Dagfinn Ilmari Mannsåker at https://github.com/robinhouston/PadWalker/pull/3 2.1 Fri 24 Apr 2015 20:29:12 BST - Another bleadperl fix https://rt.cpan.org/Public/Bug/Display.html?id=101037 2.2 Fri 23 Oct 2015 17:55:31 BST - Convert to PERL_NO_GET_CONTEXT https://github.com/robinhouston/PadWalker/pull/2 2.3 Fri 10 Nov 2017 18:26:29 GMT - Make tests work with -Ddefault_inc_excludes_dot https://rt.cpan.org/Public/Bug/Display.html?id=120421 PadWalker-2.3/MANIFEST000644 000765 000120 00000000543 13201411763 014617 0ustar00robinadmin000000 000000 Changes Makefile.PL MANIFEST PadWalker.xs PadWalker.pm README t/bar.pl t/baz.pl t/closure.t t/dm.t t/foo.t t/our.t t/recurse.t t/sub.t t/test.t t/tt.t t/var_name.t t/vn-inc-1.pl t/vn-inc-2.pl META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PadWalker-2.3/t/000755 000765 000120 00000000000 13201411763 013727 5ustar00robinadmin000000 000000 PadWalker-2.3/README000644 000765 000120 00000010215 13201367512 014345 0ustar00robinadmin000000 000000 ----------------------------------------------------------------------------- | PadWalker v2.3 - Robin Houston ----------------------------------------------------------------------------- NAME PadWalker - play with other peoples' lexical variables SYNOPSIS use PadWalker qw(peek_my peek_our peek_sub closed_over); ... DESCRIPTION PadWalker is a module which allows you to inspect (and even change!) lexical variables in any subroutine which called you. It will only show those variables which are in scope at the point of the call. PadWalker is particularly useful for debugging. It's even used by Perl's built-in debugger. (It can also be used for evil, of course.) I wouldn't recommend using PadWalker directly in production code, but it's your call. Some of the modules that use PadWalker internally are certainly safe for and useful in production. peek_my LEVEL peek_our LEVEL The LEVEL argument is interpreted just like the argument to "caller". So peek_my(0) returns a reference to a hash of all the "my" variables that are currently in scope; peek_my(1) returns a reference to a hash of all the "my" variables that are in scope at the point where the current sub was called, and so on. "peek_our" works in the same way, except that it lists the "our" variables rather than the "my" variables. The hash associates each variable name with a reference to its value. The variable names include the sigil, so the variable $x is represented by the string '$x'. For example: my $x = 12; my $h = peek_my (0); ${$h->{'$x'}}++; print $x; # prints 13 Or a more complex example: sub increment_my_x { my $h = peek_my (1); ${$h->{'$x'}}++; } my $x=5; increment_my_x; print $x; # prints 6 peek_sub SUB The "peek_sub" routine takes a coderef as its argument, and returns a hash of the "my" variables used in that sub. The values will usu- ally be undefined unless the sub is in use (i.e. in the call-chain) at the time. On the other hand: my $x = "Hello!"; my $r = peek_sub(sub {$x})->{'$x'}; print "$$r\n"; # prints 'Hello!' If the sub defines several "my" variables with the same name, you'll get the last one. I don't know of any use for "peek_sub" that isn't broken as a result of this, and it will probably be dep- recated in a future version in favour of some alternative inter- face. closed_over SUB "closed_over" is similar to "peek_sub", except that it only lists the "my" variables which are used in the subroutine but defined outside: in other words, the variables which it closes over. This does have reasonable uses: see Data::Dump::Streamer, for example (a future version of which may in fact use "closed_over"). set_closed_over SUB, HASH_REF "set_closed_over" reassigns the pad variables that are closed over by the subroutine. The second argument is a hash of references, much like the one returned from "closed_over". var_name LEVEL, VAR_REF var_name SUB, VAR_REF "var_name(sub, var_ref)" returns the name of the variable referred to by "var_ref", provided it is a "my" variable used in the sub. The "sub" parameter can be either a CODE reference or a number. If it's a number, it's treated the same way as the argument to "peek_my". For example, my $foo; print var_name(0, \$foo); # prints '$foo' sub my_name { return var_name(1, shift); } print my_name(\$foo); # ditto AUTHOR Robin Houston With contributions from Father Chrysostomous, Richard Soberberg, Florian Ragwitz, Yuval Kogman, and Fuji, Goro, bug-spotting from Peter Scott and Dave Mitchell, and suggestions from demerphq. SEE ALSO Devel::LexAlias, Devel::Caller, Sub::Parameters COPYRIGHT Copyright (c) 2000-2012, Robin Houston. All Rights Reserved. This mod- ule is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. PadWalker-2.3/META.yml000644 000765 000120 00000000772 13201411763 014743 0ustar00robinadmin000000 000000 --- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PadWalker no_index: directory: - t - inc requires: perl: '5.008001' version: '2.3' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PadWalker-2.3/PadWalker.xs000644 000765 000120 00000044242 12612463150 015722 0ustar00robinadmin000000 000000 #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef isGV_with_GP #define isGV_with_GP(x) isGV(x) #endif #ifndef CxOLD_OP_TYPE # define CxOLD_OP_TYPE(cx) (0 + (cx)->blk_eval.old_op_type) #endif #ifndef CvISXSUB #define CvISXSUB(sv) CvXSUB(sv) #endif /* For development testing */ #ifdef PADWALKER_DEBUGGING # define debug_print(x) printf x #else # define debug_print(x) #endif /* For debugging */ #ifdef PADWALKER_DEBUGGING char * cxtype_name(U32 cx_type) { switch(cx_type & CXTYPEMASK) { case CXt_NULL: return "null"; case CXt_SUB: return "sub"; case CXt_EVAL: return "eval"; case CXt_LOOP: return "loop"; case CXt_SUBST: return "subst"; case CXt_BLOCK: return "block"; case CXt_FORMAT: return "format"; default: debug_print(("Unknown context type 0x%lx\n", cx_type)); return "(unknown)"; } } void show_cxstack(void) { I32 i; for (i = cxstack_ix; i>=0; --i) { printf(" =%ld= %s (%lx)", (long)i, cxtype_name(CxTYPE(&cxstack[i])), cxstack[i].blk_oldcop->cop_seq); if (CxTYPE(&cxstack[i]) == CXt_SUB) { CV *cv = cxstack[i].blk_sub.cv; printf("\t%s", (cv && CvGV(cv)) ? GvNAME(CvGV(cv)) :"(null)"); } printf("\n"); } } #else # define show_cxstack() #endif #ifndef SvOURSTASH # ifdef OURSTASH # define SvOURSTASH OURSTASH # else # define SvOURSTASH GvSTASH # endif #endif #ifndef COP_SEQ_RANGE_LOW # define COP_SEQ_RANGE_LOW(sv) U_32(SvNVX(sv)) #endif #ifndef COP_SEQ_RANGE_HIGH # define COP_SEQ_RANGE_HIGH(sv) U_32(SvUVX(sv)) #endif #ifndef PadARRAY typedef AV PADNAMELIST; typedef SV PADNAME; # if PERL_VERSION < 8 || (PERL_VERSION == 8 && !PERL_SUBVERSION) typedef AV PADLIST; typedef AV PAD; # endif # define PadlistARRAY(pl) ((PAD **)AvARRAY(pl)) # define PadlistMAX(pl) AvFILLp(pl) # define PadlistNAMES(pl) (*PadlistARRAY(pl)) # define PadnamelistARRAY(pnl) ((PADNAME **)AvARRAY(pnl)) # define PadnamelistMAX(pnl) AvFILLp(pnl) # define PadARRAY AvARRAY # define PadnameIsOUR(pn) !!(SvFLAGS(pn) & SVpad_OUR) # define PadnameOURSTASH(pn) SvOURSTASH(pn) # define PadnameOUTER(pn) !!SvFAKE(pn) # define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL) #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_print(("**dopoptosub_at: found sub #%ld\n", (long)i)); return i; } } debug_print(("**dopoptosub_at: not found #%ld\n", (long)i)); return i; } I32 dopoptosub(pTHX_ I32 startingblock) { dTHR; return dopoptosub_at(aTHX_ cxstack, startingblock); } /* This function is based on the code of pp_caller */ PERL_CONTEXT* upcontext(pTHX_ I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p, I32 *cxix_from_p, I32 *cxix_to_p) { PERL_SI *top_si = PL_curstackinfo; I32 cxix = dopoptosub(aTHX_ cxstack_ix); PERL_CONTEXT *ccstack = cxstack; if (cxix_from_p) *cxix_from_p = cxstack_ix+1; if (cxix_to_p) *cxix_to_p = cxix; 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_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p; if (cxix_to_p) *cxix_to_p = cxix; } if (cxix < 0 && count == 0) { if (ccstack_p) *ccstack_p = ccstack; 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_p) *cop_p = ccstack[cxix].blk_oldcop; cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p; if (cxix_to_p) *cxix_to_p = cxix; } if (ccstack_p) *ccstack_p = ccstack; return &ccstack[cxix]; } /* end thievery */ SV* fetch_from_stash(pTHX_ HV *stash, char *name_str, U32 name_len) { /* This isn't the most efficient approach, but it has * the advantage that it uses documented API functions. */ char *package_name = HvNAME(stash); char *qualified_name; SV *ret = 0; /* Initialise to silence spurious compiler warning */ New(0, qualified_name, strlen(package_name) + 2 + name_len, char); strcpy(qualified_name, package_name); strcat(qualified_name, "::"); strcat(qualified_name, name_str+1); debug_print(("fetch_from_stash: Looking for %c%s\n", name_str[0], qualified_name)); switch (name_str[0]) { case '$': ret = get_sv(qualified_name, FALSE); break; case '@': ret = (SV*) get_av(qualified_name, FALSE); break; case '%': ret = (SV*) get_hv(qualified_name, FALSE); break; default: die("PadWalker: variable '%s' of unknown type", name_str); } if (ret) debug_print(("%s\n", sv_peek(ret))); else /* I don't _think_ this should ever happen */ debug_print(("XXXX - Variable %c%s not found\n", name_str[0], qualified_name)); Safefree(qualified_name); return ret; } void pads_into_hash(pTHX_ PADNAMELIST* pad_namelist, PAD* pad_vallist, HV* my_hash, HV* our_hash, U32 valid_at_seq) { I32 i; debug_print(("pads_into_hash(%p, %p, ..)\n", (void*)pad_namelist, (void*) pad_vallist)); for (i=PadnamelistMAX(pad_namelist); i>=0; --i) { PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i]; if (name_sv) { char *name_str = PadnamePV(name_sv); if (name_str) { debug_print(("** %s (%lx,%lx) [%lx]%s\n", name_str, COP_SEQ_RANGE_LOW(name_sv), COP_SEQ_RANGE_HIGH(name_sv), valid_at_seq, PadnameOUTER(name_sv) ? " " : "")); /* 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 ((PadnameOUTER(name_sv) || 0 == valid_at_seq || (valid_at_seq <= COP_SEQ_RANGE_HIGH(name_sv) && valid_at_seq > COP_SEQ_RANGE_LOW(name_sv))) && strlen(name_str) > 1 ) { SV *val_sv; U32 name_len = strlen(name_str); bool is_our = PadnameIsOUR(name_sv); debug_print(((is_our ? "** FOUND OUR %s\n" : "** FOUND MY %s\n"), name_str)); if ( hv_exists(my_hash, name_str, name_len) || hv_exists(our_hash, name_str, name_len)) { debug_print(("** key already exists - ignoring!\n")); } else { if (is_our) { val_sv = fetch_from_stash(aTHX_ PadnameOURSTASH(name_sv), name_str, name_len); if (!val_sv) { debug_print(("Value of our variable is undefined\n")); val_sv = &PL_sv_undef; } } else { val_sv = pad_vallist ? PadARRAY(pad_vallist)[i] : &PL_sv_undef; if (!val_sv) val_sv = &PL_sv_undef; } hv_store((is_our ? our_hash : my_hash), name_str, name_len, (val_sv ? newRV_inc(val_sv) : &PL_sv_undef), 0); } } } } } } void padlist_into_hash(pTHX_ PADLIST* padlist, HV* my_hash, HV* our_hash, U32 valid_at_seq, long depth) { PADNAMELIST *pad_namelist; PAD *pad_vallist; if (depth == 0) depth = 1; if (!padlist) { /* Probably an XSUB */ die("PadWalker: cv has no padlist"); } pad_namelist = PadlistNAMES(padlist); pad_vallist = PadlistARRAY(padlist)[depth]; pads_into_hash(aTHX_ pad_namelist, pad_vallist, my_hash, our_hash, valid_at_seq); } void context_vars(pTHX_ PERL_CONTEXT *cx, HV* my_ret, HV* our_ret, U32 seq, CV *cv) { /* If cx is null, we take that to mean that we should look * at the cv instead */ debug_print(("**context_vars(%p, %p, %p, 0x%lx)\n", (void*)cx, (void*)my_ret, (void*)our_ret, (long)seq)); if (cx == (PERL_CONTEXT*)-1) croak("Not nested deeply enough"); else { CV* cur_cv = cx ? cx->blk_sub.cv : cv; long depth = cx ? cx->blk_sub.olddepth + 1 : 1; if (!cur_cv) die("panic: Context has no CV!\n"); while (cur_cv) { debug_print(("\tcv name = %s; depth=%ld\n", CvGV(cur_cv) ? GvNAME(CvGV(cur_cv)) :"(null)", depth)); if (CvPADLIST(cur_cv)) padlist_into_hash(aTHX_ CvPADLIST(cur_cv), my_ret, our_ret, seq, depth); cur_cv = CvOUTSIDE(cur_cv); if (cur_cv) depth = CvDEPTH(cur_cv); } } } void do_peek(pTHX_ I32 uplevel, HV* my_hash, HV* our_hash) { PERL_CONTEXT *cx, *ccstack; COP *cop = 0; I32 cxix_from, cxix_to, i; bool first_eval = TRUE; show_cxstack(); if (PL_curstackinfo->si_type != PERLSI_MAIN) debug_print(("!! We're in a higher stack level\n")); cx = upcontext(aTHX_ uplevel, &cop, &ccstack, &cxix_from, &cxix_to); debug_print(("** cxix = (%ld,%ld)\n", cxix_from, cxix_to)); if (cop == 0) { debug_print(("**Setting cop to PL_curcop\n")); cop = PL_curcop; } debug_print(("**Cop file = %s\n", CopFILE(cop))); context_vars(aTHX_ cx, my_hash, our_hash, cop->cop_seq, PL_main_cv); for (i = cxix_from-1; i > cxix_to; --i) { debug_print(("** CxTYPE = %s (cxix = %ld)\n", cxtype_name(CxTYPE(&ccstack[i])), i)); switch (CxTYPE(&ccstack[i])) { case CXt_EVAL: debug_print(("\told_op_type = %ld\n", CxOLD_OP_TYPE(&ccstack[i]))); switch(CxOLD_OP_TYPE(&ccstack[i])) { case OP_ENTEREVAL: if (first_eval) { context_vars(aTHX_ 0, my_hash, our_hash, cop->cop_seq, ccstack[i].blk_eval.cv); first_eval = FALSE; } context_vars(aTHX_ 0, my_hash, our_hash, ccstack[i].blk_oldcop->cop_seq, ccstack[i].blk_eval.cv); break; case OP_REQUIRE: case OP_DOFILE: debug_print(("blk_eval.cv = %p\n", (void*) ccstack[i].blk_eval.cv)); if (first_eval) context_vars(aTHX_ 0, my_hash, our_hash, cop->cop_seq, ccstack[i].blk_eval.cv); return; /* If it's OP_ENTERTRY, we skip this altogether. */ } break; case CXt_SUB: #ifdef CXt_FORMAT case CXt_FORMAT: #endif Perl_die(aTHX_ "PadWalker: internal error"); exit(EXIT_FAILURE); } } } void get_closed_over(pTHX_ CV *cv, HV *hash, HV *indices) { I32 i; U32 val_depth; PADNAMELIST *pad_namelist; PAD *pad_vallist; if (CvISXSUB(cv) || !CvPADLIST(cv)) { return; } val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; pad_namelist = PadlistNAMES(CvPADLIST(cv)); pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth]; debug_print(("PadlistMAX(CvPADLIST(cv)) = %ld\n", PadlistMAX(CvPADLIST(cv)) )); for (i=PadnamelistMAX(pad_namelist); i>=0; --i) { PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i]; if (name_sv && PadnamePV(name_sv)) { char* name_str = PadnamePV(name_sv); STRLEN name_len = strlen(name_str); if (PadnameOUTER(name_sv) && !PadnameIsOUR(name_sv)) { SV *val_sv = PadARRAY(pad_vallist)[i]; if (!val_sv) val_sv = &PL_sv_undef; #ifdef PADWALKER_DEBUGGING debug_print(("Found a fake slot: %s\n", name_str)); if (val == 0) debug_print(("value is null\n")); else sv_dump(*val); #endif hv_store(hash, name_str, name_len, newRV_inc(val_sv), 0); if (indices) { /* Create a temporary SV as a way of getting perl to * stringify 'i' for us. */ SV *i_sv = newSViv(i); hv_store_ent(indices, i_sv, newRV_inc(val_sv), 0); SvREFCNT_dec(i_sv); } } } } } char * get_var_name(CV *cv, SV *var) { I32 i; U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; PADNAMELIST *pad_namelist = PadlistNAMES(CvPADLIST(cv)); PAD *pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth]; for (i=PadnamelistMAX(pad_namelist); i>=0; --i) { PADNAME* name = PadnamelistARRAY(pad_namelist)[i]; char* name_str; if ( name && (name_str = PadnamePV(name)) && PadARRAY(pad_vallist)[i] == var) { return name_str; } } return 0; } CV * up_cv(pTHX_ I32 uplevel, const char * caller_name) { PERL_CONTEXT *cx, *ccstack; I32 cxix_from, cxix_to, i; if (uplevel < 0) croak("%s: sub is < 0", caller_name); cx = upcontext(aTHX_ uplevel, 0, &ccstack, &cxix_from, &cxix_to); if (cx == (PERL_CONTEXT *)-1) { croak("%s: Not nested deeply enough", caller_name); return 0; /* NOT REACHED, but stop picky compilers from whining */ } else if (cx) return cx->blk_sub.cv; else { for (i = cxix_from-1; i > cxix_to; --i) if (CxTYPE(&ccstack[i]) == CXt_EVAL) { I32 old_op_type = CxOLD_OP_TYPE(&ccstack[i]); if (old_op_type == OP_REQUIRE || old_op_type == OP_DOFILE) return ccstack[i].blk_eval.cv; } return PL_main_cv; } } STATIC bool is_scalar_type(SV *sv) { return !( SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVCV || isGV_with_GP(sv) || SvTYPE(sv) == SVt_PVIO ); } STATIC bool is_correct_type(SV *orig, SV *restore) { return ( ( SvTYPE(orig) == SvTYPE(restore) ) || ( is_scalar_type(orig) && is_scalar_type(restore) ) ); } MODULE = PadWalker PACKAGE = PadWalker PROTOTYPES: DISABLE void peek_my(uplevel) I32 uplevel; PREINIT: HV* ret = newHV(); HV* ignore = newHV(); PPCODE: do_peek(aTHX_ uplevel, ret, ignore); SvREFCNT_dec((SV*) ignore); EXTEND(SP, 1); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); void peek_our(uplevel) I32 uplevel; PREINIT: HV* ret = newHV(); HV* ignore = newHV(); PPCODE: do_peek(aTHX_ uplevel, ignore, ret); SvREFCNT_dec((SV*) ignore); EXTEND(SP, 1); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); void peek_sub(cv) CV* cv; PREINIT: HV* ret = newHV(); HV* ignore = newHV(); PPCODE: if (CvISXSUB(cv)) die("PadWalker: cv has no padlist"); padlist_into_hash(aTHX_ CvPADLIST(cv), ret, ignore, 0, CvDEPTH(cv)); SvREFCNT_dec((SV*) ignore); EXTEND(SP, 1); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); void set_closed_over(sv, pad) SV* sv; HV* pad; PREINIT: I32 i; CV *cv = (CV *)SvRV(sv); U32 val_depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1; PADNAMELIST *pad_namelist = PadlistNAMES(CvPADLIST(cv)); PAD *pad_vallist = PadlistARRAY(CvPADLIST(cv))[val_depth]; CODE: for (i=PadnamelistMAX(pad_namelist); i>=0; --i) { PADNAME* name = PadnamelistARRAY(pad_namelist)[i]; char* name_str; if (name && (name_str = PadnamePV(name))) { STRLEN name_len = strlen(name_str); if (PadnameOUTER(name) && !PadnameIsOUR(name)) { SV **restore_ref = hv_fetch(pad, name_str, name_len, FALSE); if ( restore_ref ) { if ( SvROK(*restore_ref) ) { SV *restore = SvRV(*restore_ref); SV *orig = PadARRAY(pad_vallist)[i]; int restore_type = SvTYPE(restore); if ( !orig || is_correct_type(orig, restore) ) { SvREFCNT_inc(restore); PadARRAY(pad_vallist)[i] = restore; } else { croak("Incorrect reftype for variable %s (got %s expected %s)", name_str, sv_reftype(restore, 0), sv_reftype(orig, 0)); } } else { croak("The variable for %s is not a reference", name_str); } } } } } void closed_over(cv) CV* cv; PREINIT: HV* ret = newHV(); HV* targs; PPCODE: if (GIMME_V == G_ARRAY) { targs = newHV(); get_closed_over(aTHX_ cv, ret, targs); EXTEND(SP, 2); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); PUSHs(sv_2mortal(newRV_noinc((SV*)targs))); } else { get_closed_over(aTHX_ cv, ret, 0); EXTEND(SP, 1); PUSHs(sv_2mortal(newRV_noinc((SV*)ret))); } char* var_name(sub, var_ref) SV* sub; SV* var_ref; PREINIT: SV *cv; CODE: if (!SvROK(var_ref)) croak("Usage: PadWalker::var_name(sub, var_ref)"); if (SvROK(sub)) { cv = SvRV(sub); if (SvTYPE(cv) != SVt_PVCV) croak("PadWalker::var_name: sub is neither a CODE reference nor a number"); } else cv = (SV *) up_cv(aTHX_ SvIV(sub), "PadWalker::upcontext"); RETVAL = get_var_name((CV *) cv, SvRV(var_ref)); OUTPUT: RETVAL void _upcontext(uplevel) I32 uplevel PPCODE: /* This is used by Devel::Caller. */ XPUSHs(sv_2mortal(newSViv((IV)upcontext(aTHX_ uplevel, 0, 0, 0, 0)))); PadWalker-2.3/Makefile.PL000644 000765 000120 00000002517 12233160362 015443 0ustar00robinadmin000000 000000 use ExtUtils::MakeMaker; use strict; require 5.008001; # Remember (like I didn't) that WriteMakefile looks at @ARGV, # so an alternative way to configure a debugging build is: # perl Makefile.PL DEFINE=-DPADWALKER_DEBUGGING. my $DEBUGGING = ''; if (@ARGV && $ARGV[0] eq '-d') { warn "Configuring a debugging build of PadWalker\n"; print STDERR < 'PadWalker', 'VERSION_FROM' => 'PadWalker.pm', # finds $VERSION 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => $DEBUGGING, 'INC' => '', # e.g., '-I/usr/include/other', ($DEBUGGING ? (CCFLAGS => '-Wall -ansi') : ()), dist => {TAR => 'env COPYFILE_DISABLE=true tar'}, MIN_PERL_VERSION => "5.008001", ); PadWalker-2.3/PadWalker.pm000644 000765 000120 00000010150 13201366774 015704 0ustar00robinadmin000000 000000 package PadWalker; use strict; use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); require Exporter; require DynaLoader; require 5.008; @ISA = qw(Exporter DynaLoader); @EXPORT_OK = qw(peek_my peek_our closed_over peek_sub var_name set_closed_over); %EXPORT_TAGS = (all => \@EXPORT_OK); $VERSION = '2.3'; bootstrap PadWalker $VERSION; sub peek_my; sub peek_our; sub closed_over; sub peek_sub; sub var_name; 1; __END__ =head1 NAME PadWalker - play with other peoples' lexical variables =head1 SYNOPSIS use PadWalker qw(peek_my peek_our peek_sub closed_over); ... =head1 DESCRIPTION PadWalker is a module which allows you to inspect (and even change!) lexical variables in any subroutine which called you. It will only show those variables which are in scope at the point of the call. PadWalker is particularly useful for debugging. It's even used by Perl's built-in debugger. (It can also be used for evil, of course.) I wouldn't recommend using PadWalker directly in production code, but it's your call. Some of the modules that use PadWalker internally are certainly safe for and useful in production. =over 4 =item peek_my LEVEL =item peek_our LEVEL The LEVEL argument is interpreted just like the argument to C. So C returns a reference to a hash of all the C variables that are currently in scope; C returns a reference to a hash of all the C variables that are in scope at the point where the current sub was called, and so on. C works in the same way, except that it lists the C variables rather than the C variables. The hash associates each variable name with a reference to its value. The variable names include the sigil, so the variable $x is represented by the string '$x'. For example: my $x = 12; my $h = peek_my (0); ${$h->{'$x'}}++; print $x; # prints 13 Or a more complex example: sub increment_my_x { my $h = peek_my (1); ${$h->{'$x'}}++; } my $x=5; increment_my_x; print $x; # prints 6 =item peek_sub SUB The C routine takes a coderef as its argument, and returns a hash of the C variables used in that sub. The values will usually be undefined unless the sub is in use (i.e. in the call-chain) at the time. On the other hand: my $x = "Hello!"; my $r = peek_sub(sub {$x})->{'$x'}; print "$$r\n"; # prints 'Hello!' If the sub defines several C variables with the same name, you'll get the last one. I don't know of any use for C that isn't broken as a result of this, and it will probably be deprecated in a future version in favour of some alternative interface. =item closed_over SUB C is similar to C, except that it only lists the C variables which are used in the subroutine but defined outside: in other words, the variables which it closes over. This I have reasonable uses: see L, for example (a future version of which may in fact use C). =item set_closed_over SUB, HASH_REF C reassigns the pad variables that are closed over by the subroutine. The second argument is a hash of references, much like the one returned from C. =item var_name LEVEL, VAR_REF =item var_name SUB, VAR_REF C returns the name of the variable referred to by C, provided it is a C variable used in the sub. The C parameter can be either a CODE reference or a number. If it's a number, it's treated the same way as the argument to C. For example, my $foo; print var_name(0, \$foo); # prints '$foo' sub my_name { return var_name(1, shift); } print my_name(\$foo); # ditto =back =head1 AUTHOR Robin Houston With contributions from Richard Soberberg, Jesse Luehrs and Yuval Kogman, bug-spotting from Peter Scott, Dave Mitchell and Goro Fuji, and suggestions from demerphq. =head1 SEE ALSO Devel::LexAlias, Devel::Caller, Sub::Parameters =head1 COPYRIGHT Copyright (c) 2000-2009, Robin Houston. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. =cut PadWalker-2.3/META.json000644 000765 000120 00000001572 13201411763 015112 0ustar00robinadmin000000 000000 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "PadWalker", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } } }, "release_status" : "stable", "version" : "2.3", "x_serialization_backend" : "JSON::PP version 2.27400_02" } PadWalker-2.3/t/var_name.t000644 000765 000024 00000001024 13201402502 015706 0ustar00robinstaff000000 000000 use PadWalker 'var_name'; use strict; use warnings; no warnings 'misc'; chdir "t"; print "1..8\n"; my $foo; my $r = \$foo; my $foo; print (var_name(0, $r) eq '$foo' ? "ok 1\n" : "not ok 1\n"); print (var_name(0, \$foo) eq '$foo' ? "ok 2\n" : "not ok 2\n"); foo(); sub foo { my $r = \$foo; print (var_name(1, $r) eq '$foo' ? "ok 3\n" : "not ok 3\n"); } my $closure; { my $aaa; $closure = sub { \$aaa; }; } print (var_name($closure, $closure->()) eq '$aaa' ? "ok 4\n" : "not ok 4\n"); require "./vn-inc-1.pl"; PadWalker-2.3/t/our.t000644 000765 000120 00000000521 10321523041 014710 0ustar00robinadmin000000 000000 use strict; use warnings; use PadWalker 'peek_our'; print "1..2\n"; our $x; our $h; ($x,$h) = (7); no warnings 'misc'; # Yes, I know it masks an earlier declaration! my $h; $h = peek_our(0); print (${$h->{'$x'}} eq 7 ? "ok 1\n" : "not ok 1\n"); # our $h is masked by 'my $h': print (exists($h->{'$h'}) ? "not ok 2\n" : "ok 2\n"); PadWalker-2.3/t/baz.pl000644 000765 000120 00000000323 10323443241 015034 0ustar00robinadmin000000 000000 my $var1; my $var2 = foo(); print ( exists $var2->{'$var1'} ? "ok " : "not ok ", "4\n"); print (!exists $var2->{'$var2'} ? "ok " : "not ok ", "5\n"); print (!exists $var2->{'$nono'} ? "ok " : "not ok ", "6\n"); PadWalker-2.3/t/recurse.t000644 000765 000120 00000000547 10276145436 015604 0ustar00robinadmin000000 000000 use strict; use PadWalker 'peek_my'; print "1..2\n"; sub rec { my ($arg) = @_; my $var = 'first';; if ($arg) { $var = 'second'; my ($h0, $h1) = map peek_my($_), 0, 1; print((${$h0->{'$var'}} eq 'second' ? "ok " : "not ok "), "1\n", (${$h1->{'$var'}} eq 'first' ? "ok " : "not ok "), "2\n"); } else { rec(1); } } rec(); PadWalker-2.3/t/test.t000644 000765 000120 00000005756 10300372641 015106 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..15\n"; } END {print "not ok 1\n" unless $loaded;} use PadWalker; $loaded = 1; print "ok 1\n"; ######################### End of black magic. our $this_one_shouldnt_be_found; $this_one_shouldnt_be_found = 12; # quieten warning sub onlyvars { my (@initial); my ($t, $h, @names) = @_; my %names; @names{@names} = (1) x @names; while (my ($n,$v) = each %$h) { if (!exists $names{$n}) { print "not ok $t\t# Unexpected interloper $n\n"; return; } delete $names{$n}; } if (keys %names) { print "not ok $t\t# Not found: ", join(', ', keys %names), "\n"; return; } print "ok $t\n"; } my $outside_var = 12345; sub foo { my $variable = 23; { my $hmm = 12; } #my $hmm = 21; my $h = PadWalker::peek_my(0); onlyvars(2, $h, qw'$outside_var $variable'); ${$h->{'$variable'}} = 666; } sub bar { local ($t, $l, @v) = @_; my %x = (1 => 2); my $y = 9; onlyvars($t, baz($l), @v); my @z = qw/not yet visible/; } sub baz { my $baz_var; return PadWalker::peek_my(shift); } foo(); # test 2 bar(3, 1, qw($outside_var $y %x)); # test 3 &{ my @array=qw(fring thrum); sub {bar(4, 2, qw(@array $outside_var));} }; # test 4 () = sub {1}; my $alot_before; onlyvars(5, PadWalker::peek_my(0), qw($outside_var $alot_before)); # test 5 my $before; onlyvars(6, baz(1), qw($outside_var $alot_before $before)); # test 6 my $after; onlyvars(7, baz(0), qw($baz_var $outside_var)); # test 7 sub quux { my %quux_var; bar(@_); } quux(8, 2, qw($before $alot_before $after $outside_var %quux_var)); # test 8 # Come right out to the file scope (and test eval handling) my $discriminate1; eval q{ my $inter; eval q{ my $discriminate2; quux(9, 3, qw( $before $alot_before $after $outside_var $discriminate1 $discriminate2 $inter)); # test 9 } }; quux(10, 1, qw($outside_var $y %x)); # test 10 tie my $x, "blah", 2; my $yyy; onlyvars(11, $x, qw($outside_var $x $yyy $alot_before $before $after $discriminate1)); # test 11 my $too_late; # This is quite a subtle one: the variable $x is actually FETCHed from inside # the onlyvars subroutine. The magical scalar is on the stack until line 2 of # onlyvars. So if we peek back one level from the FETCH, we can see inside # onlyvars. tie $x, "blah", 1; onlyvars(12, $x, qw(@initial)); # test 12 eval q{ PadWalker::peek_my(1) }; print (($@ =~ /^Not nested deeply enough/) ? "ok 13\n" : "not ok 13\n"); # test 13 sub recurse { my ($i) = @_; if ($i == 0) { my $vars = PadWalker::peek_my(2); my $val = ${$vars->{'$i'}}; print ($val eq "2" ? "ok 14\n" : "not ok 14\t# $val\n"); } else { recurse($i - 1); } } recurse(5); # test 14 eval q{ my %e; onlyvars(15, PadWalker::peek_my(0), qw($outside_var $x $yyy $alot_before $before $after $discriminate1 $too_late %e)) }; # test 15 package blah; sub TIESCALAR { my ($class, $x)=@_; bless \$x } sub FETCH { my $self = shift; return PadWalker::peek_my($$self) } PadWalker-2.3/t/sub.t000644 000765 000120 00000002214 12233241313 014700 0ustar00robinadmin000000 000000 use strict; use warnings; use PadWalker 'peek_sub'; print "1..6\n"; my $t = 0; sub onlyvars { my (@initial); my ($t, $h, @names) = @_; my %names; @names{@names} = (1) x @names; while (my ($n,$v) = each %$h) { if (!exists $names{$n}) { print "not ok $t\t# Unexpected interloper $n\n"; return; } delete $names{$n}; } if (keys %names) { print "not ok $t\t# Not found: ", join(', ', keys %names), "\n"; return; } print "ok $t\n"; } onlyvars(++$t, peek_sub(\&onlyvars), qw(@initial $t $h @names %names $n $v)); sub f { my $x = shift; sub { my $y = $x; } } onlyvars(++$t, peek_sub(f()), qw($x $y)); sub g { my $x = shift; sub { my $y; } } onlyvars(++$t, peek_sub(g()), qw($y)); my $x = "Hello!"; my $h = peek_sub(sub {my $y = $x}); print (($h->{'$x'} == \$x) ? "ok 4\n" : "not ok 4\n"); # Make sure it correctly signals an exception if the sub is not a Perl sub eval { no warnings "uninitialized"; peek_sub(undef); }; print (($@ =~ /cv is not a code reference/i) ? "ok 5\n" : "not ok 5\n"); eval { peek_sub(\&peek_sub); }; print (($@ =~ /cv has no padlist/) ? "ok 6\n" : "not ok 6\n"); PadWalker-2.3/t/vn-inc-2.pl000644 000765 000120 00000000365 13201367642 015627 0ustar00robinadmin000000 000000 my @bleep; print (var_name(0, \@bleep) eq '@bleep' ? "ok 6\n" : "not ok 6\n"); eval { print (var_name(0, \@bleep) eq '@bleep' ? "ok 7\n" : "not ok 7\n"); }; eval q{ print (var_name(0, \@bleep) eq '@bleep' ? "ok 8\n" : "not ok 8\n"); }; 1; PadWalker-2.3/t/dm.t000644 000765 000120 00000003461 12233160362 014520 0ustar00robinadmin000000 000000 use strict; use warnings; use PadWalker; # All these bugs were reported by Dave Mitchell; he's the first # person to get his very own test script. print "1..8\n"; # Does PadWalker work if it's called from a closure? sub f { my $x = shift; sub { my $t = shift; my $x_val = ${PadWalker::peek_my(0)->{'$x'}}; print ($x_val eq $x ? "ok $t\n" : "not ok $t # $x_val\n"); } } f(6)->(1); # Even if the sub 'f' has been blown away? my $f = f('eh?'); undef &f; $f->(2); # If there's no reference to the value, we expect to get undef; # if there is, we expect to get the value. sub h { my $x = my $y = 'fixed'; sub { my $vals = PadWalker::peek_my(0); my $x_ref = $vals->{'$x'}; my $y_ref = $vals->{'$y'}; # There is a difference in behaviour between different versions # of Perl here. Since a0d2bbd5c47035a4f7369e4fddd46b502764d86e # we don’t see unclosed variables in the pad at all. print (!defined($x_ref)||!defined($$x_ref) ? "ok 3\n" : "not ok 3 # $x_ref\n"); print (defined($y_ref) ? "ok 4\n" : "not ok 4\n"); print ($$y_ref eq 'fixed' ? "ok 5\n" : "not ok 5 # $$y_ref\n"); my $unused = $y; } } h()->(); # How well do we cope with one variable masking another? my $x = 1; sub g { my $x = 2; my $v_x = ${PadWalker::peek_my(0)->{'$x'}}; print ($v_x eq 2 ? "ok 6\n" : "not ok 6 # $v_x\n"); } g(); no warnings 'misc'; # I know it masks an earlier declaration - # that's the whole point! my $x = 'final value'; my $v_x = ${PadWalker::peek_my(0)->{'$x'}}; print ($v_x eq $x ? "ok 7\n" : "not ok 7 # $v_x\n"); # An 'our' variable should mask a 'my': our $x; $x = $x; # Stop old perls from giving 'used only once' warning print (exists PadWalker::peek_my(0)->{'$x'} ? "not ok 8\n" : "ok 8\n"); PadWalker-2.3/t/vn-inc-1.pl000644 000765 000120 00000000145 13201402513 015605 0ustar00robinadmin000000 000000 my %waaah; print (var_name(0, \%waaah) eq '%waaah' ? "ok 5\n" : "not ok 5\n"); do "./vn-inc-2.pl"; PadWalker-2.3/t/bar.pl000644 000765 000120 00000000323 10275674502 015040 0ustar00robinadmin000000 000000 my $var1; my $var2 = foo(); print ( exists $var2->{'$var1'} ? "ok " : "not ok ", "1\n"); print (!exists $var2->{'$var2'} ? "ok " : "not ok ", "2\n"); print (!exists $var2->{'$nono'} ? "ok " : "not ok ", "3\n"); PadWalker-2.3/t/closure.t000644 000765 000024 00000005304 12516514264 015620 0ustar00robinstaff000000 000000 use strict; use warnings; use PadWalker 'closed_over', 'set_closed_over'; print "1..30\n"; my $x=2; my $h = closed_over (my $sub = sub {my $y = $x++}); my @keys = keys %$h; print (@keys == 1 ? "ok 1\n" : "not ok 1\n"); print (${$h->{'$x'}} eq 2 ? "ok 2\n" : "not ok 2\n"); print ($sub->() == 2 ? "ok 3\n" : "not ok 3\n"); print ($sub->() == 3 ? "ok 4\n" : "not ok 4\n"); ${$h->{"\$x"}} = 7; print ($sub->() == 7 ? "ok 5\n" : "not ok 5\n"); print ($sub->() == 8 ? "ok 6\n" : "not ok 6\n"); {my $x = "hello"; sub foo { ++$x }} $h = closed_over(\&foo); @keys = keys %$h; print (@keys == 1 ? "ok 7\n" : "not ok 7\n"); print (${$h->{'$x'}} eq "hello" ? "ok 8\n" : "not ok 8 # $h->{'$x'} -> ${$h->{'$x'}}\n"); foo(); print (${$h->{'$x'}} eq "hellp" ? "ok 9\n" : "not ok 9 # $h->{'$x'} -> ${$h->{'$x'}}\n"); ${$h->{'$x'}} = "phooey"; foo(); print (${$h->{'$x'}} eq "phooez" ? "ok 10\n" : "not ok 10 # $h->{'$x'} -> ${$h->{'$x'}}\n"); sub bar{ bar(2) if !@_; my $m = 13 - (@_ && $_[0]); my $n = $m+1; $h = closed_over(\&bar); @keys = keys %$h; print (@keys == 2 ? "ok $m\n" : "not ok $m\n"); print ($h->{'$h'} = \$h ? "ok $n\n" : "not ok $n\n"); # Break the circular data structure: delete $h->{'$h'}; } bar(); our $blah = 9; no warnings 'misc'; my $blah = sub {$blah}; my ($vars, $indices) = closed_over($blah); print (keys %$vars == 0 ? "ok 15\n" : "not ok 15\n"); print (keys %$indices == 0 ? "ok 16\n" : "not ok 16\n"); { my $x = 1; my @foo = (); my $other = 5; my $ref = \"foo"; my $h = closed_over( my $sub = sub { my $y = $x++; push @foo, $y; $y } ); my @keys = keys %$h; print( @keys == 2 ? "ok 17\n" : "not ok 17\n" ); print( ${ $h->{'$x'} } eq 1 ? "ok 18\n" : "not ok 18\n" ); print( $sub->() == 1 ? "ok 19\n" : "not ok 19\n" ); set_closed_over( $sub, { '$x' => \$other } ); print( $sub->() == 5 ? "ok 20\n" : "not ok 20\n" ); print( $x == 2 ? "ok 21\n" : "not ok 21\n" ); print( $other == 6 ? "ok 22\n" : "not ok 22\n" ); print( @foo == 2 ? "ok 23\n" : "not ok 23\n" ); print( $foo[0] == 1 ? "ok 24\n" : "not ok 24\n" ); print( $foo[1] == 5 ? "ok 25\n" : "not ok 25\n" ); my @other; set_closed_over( $sub, { '@foo' => \@other } ); print( $sub->() == 6 ? "ok 26\n" : "not ok 26\n" ); print( @other == 1 ? "ok 27\n" : "not ok 27\n" ); eval { set_closed_over( $sub, { '@foo' => \"foo" } ) }; print( $@ ? "ok 28\n" : "not ok 28\n" ); # test that REF and SCALAR are interchangiable eval { set_closed_over( $sub, { '$x' => \$ref } ) }; print( $@ ? "not ok 29\n" : "ok 29\n" ); } $h = closed_over(\&utf8::encode); print +(%$h == 0 ? "ok 30" : "not ok 30") . " - closed_over on XSUB\n"; PadWalker-2.3/t/foo.t000644 000765 000024 00000000312 13201402521 014701 0ustar00robinstaff000000 000000 use strict; use PadWalker; use Data::Dumper; print "1..6\n"; chdir "t"; require "./bar.pl"; do "./baz.pl"; my $nono; sub foo { my $inner = "You shouldn't see this one"; PadWalker::peek_my(1); } PadWalker-2.3/t/tt.t000644 000765 000120 00000001320 10321241106 014527 0ustar00robinadmin000000 000000 use strict; use PadWalker; print "1..5\n"; our %h; my $out1 = 'out1'; my $out2 = 'out2'; sub f1() { my $local = 'local'; %h = %{PadWalker::peek_my(1)}; print (${$h{'$out1'}} eq 'out1' ? "ok 1\n" : "not ok 1\n"); print (${$h{'$out2'}} eq 'out2' ? "ok 2\n" : "not ok 2\n"); } f1(); eval q{ my $in_eval = 'in_eval'; eval q{ () = $in_eval; %h = %{PadWalker::peek_my(0)}; print (exists $h{'$out1'} && ${$h{'$out1'}} eq 'out1' ? "ok 3\n" : "not ok 3\n"); print (exists $h{'$out2'} && ${$h{'$out2'}} eq 'out2' ? "ok 4\n" : "not ok 4\n"); print (exists $h{'$in_eval'} && ${$h{'$in_eval'}} eq 'in_eval' ? "ok 5\n" : "not ok 5\n"); }; die $@ if $@; }; die $@ if $@;