From 074f871aa19d5ce8cd11abd722d87e7364a6ba94 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 15:15:56 +0000 Subject: perl-PadWalker-2.3 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..1a1d4f8 --- /dev/null +++ b/Changes @@ -0,0 +1,191 @@ +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 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d78f40e --- /dev/null +++ b/MANIFEST @@ -0,0 +1,21 @@ +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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..139ab29 --- /dev/null +++ b/META.json @@ -0,0 +1,42 @@ +{ + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..62b1ca9 --- /dev/null +++ b/META.yml @@ -0,0 +1,23 @@ +--- +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' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..28d2a32 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,38 @@ +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", +); diff --git a/PadWalker.pm b/PadWalker.pm new file mode 100644 index 0000000..7e006b9 --- /dev/null +++ b/PadWalker.pm @@ -0,0 +1,160 @@ +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 diff --git a/PadWalker.xs b/PadWalker.xs new file mode 100644 index 0000000..b76efa1 --- /dev/null +++ b/PadWalker.xs @@ -0,0 +1,641 @@ +#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)))); diff --git a/README b/README new file mode 100644 index 0000000..351e65f --- /dev/null +++ b/README @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +| 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. diff --git a/t/bar.pl b/t/bar.pl new file mode 100644 index 0000000..5293c93 --- /dev/null +++ b/t/bar.pl @@ -0,0 +1,5 @@ +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"); diff --git a/t/baz.pl b/t/baz.pl new file mode 100644 index 0000000..9cf2efc --- /dev/null +++ b/t/baz.pl @@ -0,0 +1,5 @@ +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"); diff --git a/t/closure.t b/t/closure.t new file mode 100644 index 0000000..efdafc8 --- /dev/null +++ b/t/closure.t @@ -0,0 +1,109 @@ +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"; diff --git a/t/dm.t b/t/dm.t new file mode 100644 index 0000000..ceb0225 --- /dev/null +++ b/t/dm.t @@ -0,0 +1,65 @@ +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"); diff --git a/t/foo.t b/t/foo.t new file mode 100644 index 0000000..104e9ec --- /dev/null +++ b/t/foo.t @@ -0,0 +1,16 @@ +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); +} diff --git a/t/our.t b/t/our.t new file mode 100644 index 0000000..2e74e69 --- /dev/null +++ b/t/our.t @@ -0,0 +1,19 @@ +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"); diff --git a/t/recurse.t b/t/recurse.t new file mode 100644 index 0000000..f824f19 --- /dev/null +++ b/t/recurse.t @@ -0,0 +1,19 @@ +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(); diff --git a/t/sub.t b/t/sub.t new file mode 100644 index 0000000..0572383 --- /dev/null +++ b/t/sub.t @@ -0,0 +1,57 @@ +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"); diff --git a/t/test.t b/t/test.t new file mode 100644 index 0000000..7b818f5 --- /dev/null +++ b/t/test.t @@ -0,0 +1,137 @@ +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) } diff --git a/t/tt.t b/t/tt.t new file mode 100644 index 0000000..a45b78b --- /dev/null +++ b/t/tt.t @@ -0,0 +1,34 @@ +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 $@; diff --git a/t/var_name.t b/t/var_name.t new file mode 100644 index 0000000..3c14c9e --- /dev/null +++ b/t/var_name.t @@ -0,0 +1,35 @@ +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"; diff --git a/t/vn-inc-1.pl b/t/vn-inc-1.pl new file mode 100644 index 0000000..3d2f747 --- /dev/null +++ b/t/vn-inc-1.pl @@ -0,0 +1,5 @@ +my %waaah; + +print (var_name(0, \%waaah) eq '%waaah' ? "ok 5\n" : "not ok 5\n"); + +do "./vn-inc-2.pl"; diff --git a/t/vn-inc-2.pl b/t/vn-inc-2.pl new file mode 100644 index 0000000..97b9ec2 --- /dev/null +++ b/t/vn-inc-2.pl @@ -0,0 +1,11 @@ +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;