From b48d6ec196b4bf74d1b9b2df8107ccb57359a626 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 11:43:42 +0000 Subject: perl-Devel-Symdump-2.18 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..4ec29ea --- /dev/null +++ b/Changes @@ -0,0 +1,289 @@ +2017-02-07 k + + * release 2.18 + + * Makefile.PL changes to support perls without "." in @INC (Todd + Rinaldo); no functional change + +2016-04-19 k + + * release 2.17 + + * address #113886: unlist Compress::Zlib as a prereq, it was and + still is only used by a test that won't run for normal user + installs (Thanks to Graham Knop for reporting) + +2016-04-11 k + + * release 2.16 + + * docs only change: create a real link to perlref.pod (Slaven Rezić) + +2015-06-11 k + + * release 2.15 + + * In the tests, always check for exists before checking for + definedness (Reini Urban) + +2014-12-16 k + + * release 2.14 + + * no change to 2.14-TRIAL + +2014-12-08 k + + * release 2.14-TRIAL + + * support for fileno() on directory handles (perl commit v5.21.6-337-g67f2cc7) + +2014-07-26 k + + * release 2.13-TRIAL + + * support for telldir (Brian Fraser) + +2014-06-20 k + + * release 2.12 + + * test rewrite: v5.21.0-424-ge35475d stopped supporting + defined(@$ref) which was used in t/symdump.t (thanks to Aaron + Crane for spotting) + +2013-10-30 k + + * release 2.11 + + * v5.19.5-71-gd456e3f stopped producing the %@ hash at startup + +2013-03-27 k + + * release 2.10 + + * no change to 2.10-TRIAL + +2013-03-24 k + + * release 2.10-TRIAL + + * release 2.09-TRIAL + + * address RT#84139: fix test to work with upcoming perl 5.18 + (Thanks to ZEFRAM) + + * fixed the autogen.t test again, this time for perl 5.8.9 + +2012-05-20 Andreas J. Koenig + + * release 2.08_53 + + * apply doc patch by Nick Stokoe from ticket #77102 + + * declare dependency on Compress::Zlib + +2009-03-01 Andreas J. Koenig + + * release 2.08_51 + + * added a test by Jason M. Mills to chase down the bug he reports + in https://rt.cpan.org/Ticket/Display.html?id=43675 + +2007-10-11 Andreas J. Koenig + + * release 2.08 + + * skip the recurse test on 5.005 + +2007-01-05 Andreas J. Koenig + + * release 2.07 + + * rewrite symdump.t using Test::More + + * adjust test suite to accept main::- also introduced for named + captures + +2006-10-08 Andreas J. Koenig + + * release 2.0604 + + * adjust test suite to accept main::+ introduced by named captures + +2006-09-20 Andreas J. Koenig + + * relase 2.0603 + + * add LICENSE field to Makefile.PL to also have it in the META.yml + +2006-07-19 Andreas J. Koenig + + * release 2.0602 + + * adjust test suite to accept new variable in bleadperl, the hash + $main::^H + +2006-05-03 Andreas J. Koenig + + * release 2.0601 + + * add copyright and license + +2006-01-18 Andreas J. Koenig + + * release 2.06 + + * New warnings in bleadperl now suppressed; minor pod issues fixed + +2006-01-02 Andreas J. Koenig + + * release 2.05 + + * fix the testcase for recursion so that it compiles and works + also after patch 26370 to perl after which stashes are not + autovivified anymore. + +2005-12-25 Andreas J. Koenig + + * release 2.04 + + * Export.pm now strict clean + + * Makefile.PL up to date + + * added ChangeLog.svn + + * added tests for recursion, pod, podcover + + * Fixed rt.cpan.org #8766--recursion + +2002-03-01 Andreas J. Koenig + + * lib/Devel/Symdump.pm: perl 5.6.1 introduced a package name of + "" to work around a bug if somebody uses the deprecated + C without an argument. I believe we need to ignore that + symbol completely so that at least we follow the lead of the B:: + extensions. Thanks to Sreeji K Das /sreeji_k at yahoo.com/ for the + report. + +2000-10-31 Andreas J. Koenig + + * Typo fix: hashs --> hashes. Thanks to Sebastien Blondeel + for the report. + +2000-06-14 Andreas J. Koenig + + * Fixed my email address in and made a few tiny editorial changes + to the manpage. + + * Replaced Changes file with this ChangeLog file, appended the + full Changes file below. + + * Fixed the test 6 in t/symdump.t. This test was broken by + perl-5.6.0 but not Devel::Symdump itself. + +1997-05-16 Andreas Koenig + + * Release 2.00 + + * Fixed typos in the manpage, added a test for tree, no functional + change, released 2.00. + +1997-03-31 Andreas Koenig + + * 1.99_01 + + * 1.99_01 is the designated 2.00. + + * Between 1.20 and 1.23 the method as_HTML was introduced and a + few code cleanups happened. + + * 2.00 switches implementation to use *ENTRY{XXX} internally. This + means that we can determine scalarness even for undefined scalars. + We don't expect unknowns anymore. + + * 2.00 introduces the new ios() method which should replace the + older filehandles() and dirhandles() methods. For backwards + compatibility the old methods continue to work as they used to. + + * 2.00 comes with isa_tree and inh_tree utility methods for + analysing the inheritance tree. Devel::Symdump objects may be used + to create snapshots, but their typical use would be as class + methods. + +1995-08-16 Andreas Koenig + + * 1.20 + + * test 7 of t/symdump.t was too capricious. In fact the test was + based on wrong assumptions about loaded packages in the perl + binary. Static perls and dynamic perls have different symbol + tables when they run thetests. So test 7 is gone. + + * test 4 of t/symdump.t relied on $@ being set like in perl5.001m. + This might not be a correct assumption. So test 4 is replaced with + a dummy 'print ok' until the $@ problem is sorted out + +1995-07-03 Andreas Koenig + + * 1.19 + + * Added an as_string method. + + * Rewrote the test scripts so they output standard test strings + "ok nnn". This is dangerous for new perl releases, but will help + me do get bug reports early. + + * Renamed the exporting example package to Devel::Symdump::Export. + +1995-05-29 Andreas Koenig + + * 1.16 + + * Changed '${pack}::' and relatives back to "$pack\:\:" to make + the package "-w" safe. Deleted the debug statement in _doit() + after Gurusamy Sarathy fixed the bug in perl5.001, but left a + comment there. + + * Changed the AUTHORS section to plain "Andreas & Tom". + + * Added this Changes file :) + +1995-05-28 Andreas Koenig + + * 1.14 + + * After a considerable amount of mail exchange between Tom and me, + we now have a unknowns() method for all the rest in the symbol + table that we currently don't follow further. new() is renamed to + rnew() which stands for recursive new. new() now does not go into + recursion which becomes the default behaviour for people calling + directly Devel::Symdump->arrays etc. + + * Added a Devel::Symdump::Exp package for Tom who wanted the + methods exported. Tom had tried to add Exporter to the package and + to export the undefined methods directly. Andreas didn't trust + this trick although it seemed to work fine. So they are still + considering if it can be done. + +1995-05-27 Andreas Koenig + + * 1.09 + + * Drops all prettyprint functionality and becomes a primitiv + package after some talk with Tom Christiansen and Gurusamy + Sarathy. Moreover, Dean Roehrich's additions to the perlbot + manpage gave me (Andreas) some hints about package globals which + now get a new dress within the object. + +1995-05-xx Andreas Koenig + + * 1.05 + + * First release of the formerly Devel::Debug called package. + + Local Variables: + mode: change-log + change-log-default-name: "Changes" + End: diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..382a816 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,18 @@ +Changes +lib/Devel/Symdump.pm +lib/Devel/Symdump/Export.pm +Makefile.PL +MANIFEST +README +t/autogen.t +t/diff.t +t/export.t +t/glob_to_local_typeglob.t +t/pod.t +t/podcover.t +t/recur.t +t/symdump.t +t/tree.t +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) +SIGNATURE Public-key signature (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..b1869a9 --- /dev/null +++ b/META.json @@ -0,0 +1,53 @@ +{ + "abstract" : "dump symbol names or the symbol table", + "author" : [ + "Andreas Koenig " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", + "keywords" : [ + "symbol table inspection" + ], + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Devel-Symdump", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Compress::Zlib" : "0", + "Test::More" : "0", + "perl" : "5.004" + } + } + }, + "release_status" : "stable", + "resources" : { + "repository" : { + "type" : "git", + "url" : "git://github.com/andk/devel-symdump.git" + } + }, + "version" : "2.18", + "x_serialization_backend" : "JSON::PP version 2.27400_02" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..83558ab --- /dev/null +++ b/META.yml @@ -0,0 +1,29 @@ +--- +abstract: 'dump symbol names or the symbol table' +author: + - 'Andreas Koenig ' +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' +keywords: + - 'symbol table inspection' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Devel-Symdump +no_index: + directory: + - t + - inc +requires: + Compress::Zlib: '0' + Test::More: '0' + perl: '5.004' +resources: + repository: git://github.com/andk/devel-symdump.git +version: '2.18' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..1a51f20 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,225 @@ +#!/usr/bin/perl -w -*- mode: cperl -*- +use strict; +use vars qw( $VERSION ); +use ExtUtils::MakeMaker qw(:DEFAULT); + +my $version_diff = 0; # we'll have to die if this becomes true +my $is_trial = 0; +my $version; +{ + local $^W; + $ExtUtils::MakeMaker::VERSION = eval $ExtUtils::MakeMaker::VERSION; +} + +print "Require Devel::Symdump from the local tarball.\n"; + +BEGIN { + local @INC = @INC; + unshift @INC, './lib'; + require Devel::Symdump; +} + +$version = $Devel::Symdump::VERSION; +if ($is_trial && $version !~ /_/) { + $version .= "-TRIAL"; +} +{ + my $version_set_manually = 1; # not by SVN + if ($ARGV[0] && $ARGV[0] eq "--setversion") { + die "Your perl is a bit dated[$]].\nDo not make a release with it\n" if $] < 5.008; + die "Your MakeMaker is a bit dated[$ExtUtils::MakeMaker::VERSION].\nDo not make a release with it\n" + if $ExtUtils::MakeMaker::VERSION < 6.4502; + die "Your MakeMaker doesn't do the sign woodoo" unless + MM->can("signature_target"); + shift @ARGV; + my $st; + local $ENV{LANG} = "C"; + my $dirty = `git status --porcelain --untracked-files=no`; + die "Not everything checked in or out?\n====\n$dirty====\n" if $dirty; + + if ($version_set_manually) { + # we must control that the VERSION in this .pm is the same as in the Makefile + open my $fh, "make the-release-name|" or die; + my $have_version; + while (<$fh>) { + next unless /^version\s+([\d\._]+(?:-TRIAL)?)/; + $have_version = $1; + } + die "could not determine current version from Makefile" unless $have_version; + eval q{ + no warnings "numeric"; + my $dsv = $Devel::Symdump::VERSION; + if ($dsv != $have_version) { + warn "Not equal: D:S:VERSION[$dsv] Makefile version[$have_version]"; + $version_diff = 1; + } +}; + die $@ if $@; + } + exit unless $version_diff; + } +} + +my $prereq_pm = { + 'Test::More' => 0, + }; +my @interesting_modules = + ( + 'Compress::Zlib', # only for t/glob_to_local_typeglob.t + ); +for my $interesting_module (@interesting_modules) { + my $have = eval "require $interesting_module; 1;"; + if ($have) { + $prereq_pm->{$interesting_module} ||= 0; + } +} +my @sign = (MM->can("signature_target") ? (SIGN => 1) : ()); +WriteMakefile( + NAME => "Devel::Symdump", + DISTNAME => "Devel-Symdump", + VERSION => $version, + PREREQ_PM => $prereq_pm, + ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? + (LICENSE => "perl") : (), + ), + ($ExtUtils::MakeMaker::VERSION >= 6.48 ? + (MIN_PERL_VERSION => '5.004') : (), + ), + clean => { + FILES => '*/*/*~', + }, + @sign, + ($] >= 5.005 ? + ( + ABSTRACT_FROM => 'lib/Devel/Symdump.pm', # retrieve abstract from module + AUTHOR => 'Andreas Koenig ') : (), + ), + dist => { + DIST_DEFAULT => join(" ", # note: order matters! + "verify-no-subdir", + "verify-changes-date", + "verify-changes-version", + "Makefile", + "setversion", + "README", + "all", + "tardist", + ), + COMPRESS => 'gzip -9', + }, + # I took it from RT-CPAN ticket 30098: + ($ExtUtils::MakeMaker::VERSION >= 6.4502 ? + (META_ADD => { + resources => { + repository => "git://github.com/andk/devel-symdump.git", + }, + keywords => ['symbol table inspection'], + }) : ()), + ); + +if ($version_diff){ + die " +==> I had to update some \$VERSIONs <== +==> Your Makefile has been rebuilt. <== +==> Please rerun the make command. <== +"; +} + +package MY; +sub distsignature { + my($self) = shift; + my $ret = $self->SUPER::distsignature_target(@_); + $ret =~ s|cpansign|\`dirname \$(PERL)\`/cpansign|g; + return $ret; +} +sub macro { + q{ +LC_ALL_noexport=en_GB.utf8 + +YAML_MODULE=YAML::Syck +} +} + +sub postamble { + q{ +# the subdirs on MY OWN BOX are allowed here (only used for make dist!) +OKDIRS=benchmark|bin|blib|lib|scripts|t + +verify-no-subdir: + @$(PERL) -e 'my$$s=join",",grep{!/^($(OKDIRS))\z/x&&-d($$_)}glob"*";' \ + -e 'die"unexpected dir:$$s"if$$s' + +verify-changes-date: + @$(PERL) -ne 'BEGIN{my@t=(localtime)[5,4,3];$$t[0]+=1900;$$t[1]++;$$t=sprintf"%04d-%02d-%02d",@t}' \ + -e '$$ok++,exit if /^$$t\s/; END{die "Alert: did not find <$$t> in Changes file" unless $$ok}' Changes + +verify-changes-version: + @$(PERL) -ne '$$ok++,exit if /\b$(VERSION)\b/; END{die "Alert: did not find <$(VERSION)> in Changes file" unless $$ok}' Changes + +setversion: + $(PERL) Makefile.PL --setversion + +README: lib/Devel/Symdump.pm Makefile + -test -r $@ && chmod +w $@ + -$(PERL) -MPod::Text -e 'Pod::Text->new->parse_from_file(\*ARGV)' lib/Devel/Symdump.pm > $@ + +the-release-name : + $(NOECHO) $(ECHO) 'version ' $(VERSION) + $(NOECHO) $(ECHO) 'release-name ' $(DISTVNAME).tar$(SUFFIX) + +release :: disttest + git tag -m 'This is $(VERSION)' "$(VERSION)" + ls -l $(DISTVNAME).tar$(SUFFIX) + rm -rf $(DISTVNAME) + $(NOECHO) $(ECHO) '#### Suggested next steps:' + $(NOECHO) $(ECHO) ' git push --tags origin master' + +sign: + cpansign -s + +howto-release: + @$(ECHO) manually set version in Symdump.pm, edit ChangeLog + @$(ECHO) make ci dist \&\& make release +} +} + +sub dist_ci { + return qq{ci : + svn ci +}; +} + +sub dist_test { + return q{ +# if we depend on $(DISTVNAME).tar$(SUFFIX), then the rest of the +# Makefile breaks our intent to NOT remake dist +disttest : + rm -rf $(DISTVNAME) + tar xvzf $(DISTVNAME).tar$(SUFFIX) + cd $(DISTVNAME) && $(ABSPERLRUN) Makefile.PL + cd $(DISTVNAME) && $(MAKE) $(PASTHRU) + cd $(DISTVNAME) && $(MAKE) test $(PASTHRU) + +distdir :: + touch $(DISTVNAME)/SIGNATURE && $(CP) $(DISTVNAME)/SIGNATURE ./SIGNATURE + $(CP) $(DISTVNAME)/META.yml ./META.yml + $(CP) $(DISTVNAME)/META.json ./META.json + $(CP) $(DISTVNAME)/MANIFEST ./MANIFEST + +} +} + +sub distdir { + my $self = shift; + my $out = $self->SUPER::distdir; + $out =~ s/distdir :/distdir ::/g; + return $out; +} + +# dist_dir was the name in very old MakeMaker as of 5.005_04 +sub dist_dir { + my $self = shift; + my $out = $self->SUPER::dist_dir; + $out =~ s/distdir :/distdir ::/g; + return $out; +} diff --git a/README b/README new file mode 100644 index 0000000..77a3950 --- /dev/null +++ b/README @@ -0,0 +1,151 @@ +NAME + Devel::Symdump - dump symbol names or the symbol table + +SYNOPSIS + # Constructor + require Devel::Symdump; + @packs = qw(some_package another_package); + $obj = Devel::Symdump->new(@packs); # no recursion + $obj = Devel::Symdump->rnew(@packs); # with recursion + + # Methods + @array = $obj->packages; + @array = $obj->scalars; + @array = $obj->arrays; + @array = $obj->hashes; + @array = $obj->functions; + @array = $obj->filehandles; # deprecated, use ios instead + @array = $obj->dirhandles; # deprecated, use ios instead + @array = $obj->ios; + @array = $obj->unknowns; # only perl version < 5.003 had some + + $string = $obj->as_string; + $string = $obj->as_HTML; + $string = $obj1->diff($obj2); + + $string = Devel::Symdump->isa_tree; # or $obj->isa_tree + $string = Devel::Symdump->inh_tree; # or $obj->inh_tree + + # Methods with autogenerated objects + # all of those call new(@packs) internally + @array = Devel::Symdump->packages(@packs); + @array = Devel::Symdump->scalars(@packs); + @array = Devel::Symdump->arrays(@packs); + @array = Devel::Symdump->hashes(@packs); + @array = Devel::Symdump->functions(@packs); + @array = Devel::Symdump->ios(@packs); + @array = Devel::Symdump->unknowns(@packs); + +DESCRIPTION + This little package serves to access the symbol table of perl. + + "Devel::Symdump->rnew(@packages)" + returns a symbol table object for all subtrees below @packages. + Nested Modules are analyzed recursively. If no package is given as + argument, it defaults to "main". That means to get the whole symbol + table, just do a "rnew" without arguments. + + The global variable $Devel::Symdump::MAX_RECURSION limits the + recursion to prevent contention. The default value is set to 97, + just low enough to survive the test suite without a warning about + deep recursion. + + "Devel::Symdump->new(@packages)" + does not go into recursion and only analyzes the packages that are + given as arguments. + + packages, scalars, arrays, hashes, functions, ios + The methods packages(), scalars(), arrays(), hashes(), functions(), + ios(), and (for older perls) unknowns() each return an array of + fully qualified symbols of the specified type in all packages that + are held within a Devel::Symdump object, but without the leading + "$", "@" or "%". In a scalar context, they will return the number of + such symbols. Unknown symbols are usually either formats or + variables that haven't yet got a defined value. + + Note that scalar symbol table entries are a special case. If a + symbol table entry exists at all, presence of a scalar is currently + unknowable, due to a feature of Perl described in "Making + References" in perlref point 7. For example, this package will mark + a scalar value $foo as present if any of @foo, %foo, &foo etc. have + been declared or used. + + as_string + as_HTML + As_string() and as_HTML() return a simple string/HTML + representations of the object. + + diff + Diff() prints the difference between two Devel::Symdump objects in + human readable form. The format is similar to the one used by the + as_string method. + + isa_tree + inh_tree + Isa_tree() and inh_tree() both return a simple string representation + of the current inheritance tree. The difference between the two + methods is the direction from which the tree is viewed: top-down or + bottom-up. As I'm sure, many users will have different expectation + about what is top and what is bottom, I'll provide an example what + happens when the Socket module is loaded: + + % print Devel::Symdump->inh_tree + AutoLoader + DynaLoader + Socket + DynaLoader + Socket + Exporter + Carp + Config + Socket + + The inh_tree method shows on the left hand side a package name and + indented to the right the packages that use the former. + + % print Devel::Symdump->isa_tree + Carp + Exporter + Config + Exporter + DynaLoader + AutoLoader + Socket + Exporter + DynaLoader + AutoLoader + + The isa_tree method displays from left to right ISA relationships, + so Socket IS A DynaLoader and DynaLoader IS A AutoLoader. (Actually, + they were at the time this manpage was written) + + You may call both methods, isa_tree() and inh_tree(), with an object. If + you do that, the object will store the output and retrieve it when you + call the same method again later. The typical usage would be to use them + as class methods directly though. + +SUBCLASSING + The design of this package is intentionally primitive and allows it to + be subclassed easily. An example of a (maybe) useful subclass is + Devel::Symdump::Export, a package which exports all methods of the + Devel::Symdump package and turns them into functions. + +SEE ALSO + Routines for manipulating stashes: "Package::Stash"; to work with + lexicals: "PadWalker". + +AUTHORS + Andreas Koenig and Tom Christiansen . + Based on the old dumpvar.pl by Larry Wall. + +COPYRIGHT, LICENSE + This module is + + Copyright (c) 1995, 1997, 2000, 2002, 2005, 2006 Andreas Koenig + "". + + All rights reserved. + + This library is free software; you may use, redistribute and/or modify + it under the same terms as Perl itself. + diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..f0d1dd4 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,39 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.81. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 76085d7698e84bf76d7ffc576a256d598479055b Changes +SHA1 1a8c5d596cff0111353e14fa44e6caca7cce8c13 MANIFEST +SHA1 6236051bc6f6b1f86b8aa9b29901e40f0f431319 META.json +SHA1 fcc59c27ba127d01d52da5ff0672f0c48c2bc70d META.yml +SHA1 fe3b80d5f1faa1ac94d5e05832aef0da8a4eb306 Makefile.PL +SHA1 8133699b30ab8ed3b6a176caafd587f3831f5299 README +SHA1 b3d427cbe0fc78d6757a8087d2e3cb6547e18bac lib/Devel/Symdump.pm +SHA1 fef2e4c5ea88bd09f2af618e32a58ee87be965a4 lib/Devel/Symdump/Export.pm +SHA1 6fbcf9e39c02e9889a6d8bf9cb2c6444967dc841 t/autogen.t +SHA1 ac80cb093bffdce80ea28209197e58ec40b0cdd4 t/diff.t +SHA1 6bc8983394b0a72d8ee3234b4788f9f81fbefca1 t/export.t +SHA1 2c06c8719cca447d6ffa97081cf213eabbad35ad t/glob_to_local_typeglob.t +SHA1 889f97a506e0781a6600dc15804485aa068a6c1f t/pod.t +SHA1 bb02a8211bc11f5e05a40d4fa426e9a23e1e1dd7 t/podcover.t +SHA1 a3c92f14ca7be245384a8a9f1425f6b99c2f42f1 t/recur.t +SHA1 eb77a889d1fbfc55658cb80e9791c63b10b369bd t/symdump.t +SHA1 d7e8e57a5c9676c8fd716b6b0fe13559c83d8711 t/tree.t +-----BEGIN PGP SIGNATURE----- + +iF0EARECAB0WIQRQoO0miqKVvSygQR7sgDnwoxfBXQUCWJkEaAAKCRDsgDnwoxfB +XT2MAJ45dnDpSOxtF03dJ7EWooiisJTlVwCfR4Qm2wgMsVqBLNhHUZuqSO4o4RE= +=HKOq +-----END PGP SIGNATURE----- diff --git a/lib/Devel/Symdump.pm b/lib/Devel/Symdump.pm new file mode 100644 index 0000000..a76f58b --- /dev/null +++ b/lib/Devel/Symdump.pm @@ -0,0 +1,500 @@ +package Devel::Symdump; + +use 5.003; +use Carp (); +use strict; +use vars qw($Defaults $VERSION *ENTRY $MAX_RECURSION); + +$VERSION = '2.18'; +$MAX_RECURSION = 97; + +$Defaults = { + 'RECURS' => 0, + 'AUTOLOAD' => { + 'packages' => 1, + 'scalars' => 1, + 'arrays' => 1, + 'hashes' => 1, + 'functions' => 1, + 'ios' => 1, + 'unknowns' => 1, + }, + 'SEEN' => {}, + }; + +sub rnew { + my($class,@packages) = @_; + no strict "refs"; + my $self = bless {%${"$class\::Defaults"}}, $class; + $self->{RECURS}++; + $self->_doit(@packages); +} + +sub new { + my($class,@packages) = @_; + no strict "refs"; + my $self = bless {%${"$class\::Defaults"}}, $class; + $self->_doit(@packages); +} + +sub _doit { + my($self,@packages) = @_; + @packages = ("main") unless @packages; + $self->{RESULT} = $self->_symdump(@packages); + return $self; +} + +sub _symdump { + my($self,@packages) = @_ ; + my($key,$val,$num,$pack,@todo,$tmp); + my $result = {}; + foreach $pack (@packages){ + no strict; + while (($key,$val) = each(%{*{"$pack\::"}})) { + my $gotone = 0; + local(*ENTRY) = $val; + #### SCALAR #### + if (defined $val && defined *ENTRY{SCALAR}) { + $result->{$pack}{SCALARS}{$key}++; + $gotone++; + } + #### ARRAY #### + if (defined $val && defined *ENTRY{ARRAY}) { + $result->{$pack}{ARRAYS}{$key}++; + $gotone++; + } + #### HASH #### + if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) { + $result->{$pack}{HASHES}{$key}++; + $gotone++; + } + #### PACKAGE #### + if (defined $val && defined *ENTRY{HASH} && $key =~ /::$/ && + $key ne "main::" && $key ne "::") { + my($p) = $pack ne "main" ? "$pack\::" : ""; + ($p .= $key) =~ s/::$//; + $result->{$pack}{PACKAGES}{$p}++; + $gotone++; + if (++$self->{SEEN}{*$val} > $Devel::Symdump::MAX_RECURSION){ + next; + } + push @todo, $p; + } + #### FUNCTION #### + if (defined $val && defined *ENTRY{CODE}) { + $result->{$pack}{FUNCTIONS}{$key}++; + $gotone++; + } + + #### IO #### had to change after 5.003_10 + if ($] > 5.003_10){ + if (defined $val && defined *ENTRY{IO}){ # fileno and telldir... + $result->{$pack}{IOS}{$key}++; + $gotone++; + } + } else { + #### FILEHANDLE #### + if (defined fileno(ENTRY)){ + $result->{$pack}{IOS}{$key}++; + $gotone++; + } elsif (defined telldir(ENTRY)){ + #### DIRHANDLE #### + $result->{$pack}{IOS}{$key}++; + $gotone++; + } + } + + #### SOMETHING ELSE #### + unless ($gotone) { + $result->{$pack}{UNKNOWNS}{$key}++; + } + } + } + + return (@todo && $self->{RECURS}) + ? { %$result, %{$self->_symdump(@todo)} } + : $result; +} + +sub _partdump { + my($self,$part)=@_; + my ($pack, @result); + my $prepend = ""; + foreach $pack (keys %{$self->{RESULT}}){ + $prepend = "$pack\::" unless $part eq 'PACKAGES'; + push @result, map {"$prepend$_"} keys %{$self->{RESULT}{$pack}{$part} || {}}; + } + return @result; +} + +# this is needed so we don't try to AUTOLOAD the DESTROY method +sub DESTROY {} + +sub as_string { + my $self = shift; + my($type,@m); + for $type (sort keys %{$self->{'AUTOLOAD'}}) { + push @m, $type; + push @m, "\t" . join "\n\t", map { + s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg; + $_; + } sort $self->_partdump(uc $type); + } + return join "\n", @m; +} + +sub as_HTML { + my $self = shift; + my($type,@m); + push @m, ""; + for $type (sort keys %{$self->{'AUTOLOAD'}}) { + push @m, ""; + push @m, ""; + } + push @m, "
$type" . join ", ", map { + s/([\000-\037\177])/ '^' . + pack('c', ord($1) ^ 64) + /eg; $_; + } sort $self->_partdump(uc $type); + push @m, "
"; + return join "\n", @m; +} + +sub diff { + my($self,$second) = @_; + my($type,@m); + for $type (sort keys %{$self->{'AUTOLOAD'}}) { + my(%first,%second,%all,$symbol); + foreach $symbol ($self->_partdump(uc $type)){ + $first{$symbol}++; + $all{$symbol}++; + } + foreach $symbol ($second->_partdump(uc $type)){ + $second{$symbol}++; + $all{$symbol}++; + } + my(@typediff); + foreach $symbol (sort keys %all){ + next if $first{$symbol} && $second{$symbol}; + push @typediff, "- $symbol" unless $second{$symbol}; + push @typediff, "+ $symbol" unless $first{$symbol}; + } + foreach (@typediff) { + s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64) /eg; + } + push @m, $type, @typediff if @typediff; + } + return join "\n", @m; +} + +sub inh_tree { + my($self) = @_; + return $self->{INHTREE} if ref $self && defined $self->{INHTREE}; + my($inherited_by) = {}; + my($m)=""; + my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays; + my $isa; + foreach $isa (sort @isa) { + $isa =~ s/::ISA$//; + my($isaisa); + no strict 'refs'; + foreach $isaisa (@{"$isa\::ISA"}){ + $inherited_by->{$isaisa}{$isa}++; + } + } + my $item; + foreach $item (sort keys %$inherited_by) { + $m .= "$item\n"; + $m .= _inh_tree($item,$inherited_by); + } + $self->{INHTREE} = $m if ref $self; + $m; +} + +sub _inh_tree { + my($package,$href,$depth) = @_; + return unless defined $href; + $depth ||= 0; + $depth++; + if ($depth > 100){ + warn "Deep recursion in ISA\n"; + return; + } + my($m) = ""; + # print "DEBUG: package[$package]depth[$depth]\n"; + my $i; + foreach $i (sort keys %{$href->{$package}}) { + $m .= qq{\t} x $depth; + $m .= qq{$i\n}; + $m .= _inh_tree($i,$href,$depth); + } + $m; +} + +sub isa_tree{ + my($self) = @_; + return $self->{ISATREE} if ref $self && defined $self->{ISATREE}; + my(@isa) = grep /\bISA$/, Devel::Symdump->rnew->arrays; + my($m) = ""; + my($isa); + foreach $isa (sort @isa) { + $isa =~ s/::ISA$//; + $m .= qq{$isa\n}; + $m .= _isa_tree($isa) + } + $self->{ISATREE} = $m if ref $self; + $m; +} + +sub _isa_tree{ + my($package,$depth) = @_; + $depth ||= 0; + $depth++; + if ($depth > 100){ + warn "Deep recursion in ISA\n"; + return; + } + my($m) = ""; + # print "DEBUG: package[$package]depth[$depth]\n"; + my $isaisa; + no strict 'refs'; + foreach $isaisa (@{"$package\::ISA"}) { + $m .= qq{\t} x $depth; + $m .= qq{$isaisa\n}; + $m .= _isa_tree($isaisa,$depth); + } + $m; +} + +AUTOLOAD { + my($self,@packages) = @_; + unless (ref $self) { + $self = $self->new(@packages); + } + no strict "vars"; + (my $auto = $AUTOLOAD) =~ s/.*:://; + + $auto =~ s/(file|dir)handles/ios/; + my $compat = $1; + + unless ($self->{'AUTOLOAD'}{$auto}) { + Carp::croak("invalid Devel::Symdump method: $auto()"); + } + + my @syms = $self->_partdump(uc $auto); + if (defined $compat) { + no strict 'refs'; + local $^W; # bleadperl@26631 introduced an io warning here + if ($compat eq "file") { + @syms = grep { defined(fileno($_)) } @syms; + } else { + @syms = grep { _is_dirhandle($_) } @syms; + } + } + return @syms; # make sure now it gets context right +} + +use Config (); +use constant HAVE_TELLDIR => $Config::Config{d_telldir}; +sub _is_dirhandle { + my ($glob) = @_; + if ( HAVE_TELLDIR ) { + return defined(telldir($glob)); + } + else { + if ( !ref $glob ) { + no strict 'refs'; + $glob = \*{$glob}; + } + require B; + my $obj = B::svref_2object($glob); + return if !$obj || !eval{ $obj->IO; $obj->IO->IoTYPE; 1 }; + my $mode = $obj->IO->IoTYPE; + return $mode eq "\0" ? 1 : 0; + } +} + +1; + +__END__ + +=head1 NAME + +Devel::Symdump - dump symbol names or the symbol table + +=head1 SYNOPSIS + + # Constructor + require Devel::Symdump; + @packs = qw(some_package another_package); + $obj = Devel::Symdump->new(@packs); # no recursion + $obj = Devel::Symdump->rnew(@packs); # with recursion + + # Methods + @array = $obj->packages; + @array = $obj->scalars; + @array = $obj->arrays; + @array = $obj->hashes; + @array = $obj->functions; + @array = $obj->filehandles; # deprecated, use ios instead + @array = $obj->dirhandles; # deprecated, use ios instead + @array = $obj->ios; + @array = $obj->unknowns; # only perl version < 5.003 had some + + $string = $obj->as_string; + $string = $obj->as_HTML; + $string = $obj1->diff($obj2); + + $string = Devel::Symdump->isa_tree; # or $obj->isa_tree + $string = Devel::Symdump->inh_tree; # or $obj->inh_tree + + # Methods with autogenerated objects + # all of those call new(@packs) internally + @array = Devel::Symdump->packages(@packs); + @array = Devel::Symdump->scalars(@packs); + @array = Devel::Symdump->arrays(@packs); + @array = Devel::Symdump->hashes(@packs); + @array = Devel::Symdump->functions(@packs); + @array = Devel::Symdump->ios(@packs); + @array = Devel::Symdump->unknowns(@packs); + +=head1 DESCRIPTION + +This little package serves to access the symbol table of perl. + +=over 4 + +=item Crnew(@packages)> + +returns a symbol table object for all subtrees below @packages. +Nested Modules are analyzed recursively. If no package is given as +argument, it defaults to C
. That means to get the whole symbol +table, just do a C without arguments. + +The global variable $Devel::Symdump::MAX_RECURSION limits the +recursion to prevent contention. The default value is set to 97, just +low enough to survive the test suite without a warning about deep +recursion. + +=item Cnew(@packages)> + +does not go into recursion and only analyzes the packages that are +given as arguments. + +=item packages, scalars, arrays, hashes, functions, ios + +The methods packages(), scalars(), arrays(), hashes(), functions(), +ios(), and (for older perls) unknowns() each return an array of fully +qualified symbols of the specified type in all packages that are held +within a Devel::Symdump object, but without the leading C<$>, C<@> or +C<%>. In a scalar context, they will return the number of such +symbols. Unknown symbols are usually either formats or variables that +haven't yet got a defined value. + +Note that scalar symbol table entries are a special case. If a symbol +table entry exists at all, presence of a scalar is currently +unknowable, due to a feature of Perl described in L point 7. For example, this package will mark a scalar +value C<$foo> as present if any of C<@foo>, C<%foo>, C<&foo> etc. have +been declared or used. + +=item as_string + +=item as_HTML + +As_string() and as_HTML() return a simple string/HTML representations +of the object. + +=item diff + +Diff() prints the difference between two Devel::Symdump objects in +human readable form. The format is similar to the one used by the +as_string method. + +=item isa_tree + +=item inh_tree + +Isa_tree() and inh_tree() both return a simple string representation +of the current inheritance tree. The difference between the two +methods is the direction from which the tree is viewed: top-down or +bottom-up. As I'm sure, many users will have different expectation +about what is top and what is bottom, I'll provide an example what +happens when the Socket module is loaded: + +=item % print Devel::Symdump-Einh_tree + + AutoLoader + DynaLoader + Socket + DynaLoader + Socket + Exporter + Carp + Config + Socket + +The inh_tree method shows on the left hand side a package name and +indented to the right the packages that use the former. + +=item % print Devel::Symdump-Eisa_tree + + Carp + Exporter + Config + Exporter + DynaLoader + AutoLoader + Socket + Exporter + DynaLoader + AutoLoader + +The isa_tree method displays from left to right ISA relationships, so +Socket IS A DynaLoader and DynaLoader IS A AutoLoader. (Actually, they +were at the time this manpage was written) + +=back + +You may call both methods, isa_tree() and inh_tree(), with an +object. If you do that, the object will store the output and retrieve +it when you call the same method again later. The typical usage would +be to use them as class methods directly though. + +=head1 SUBCLASSING + +The design of this package is intentionally primitive and allows it to +be subclassed easily. An example of a (maybe) useful subclass is +Devel::Symdump::Export, a package which exports all methods of the +Devel::Symdump package and turns them into functions. + +=head1 SEE ALSO + +Routines for manipulating stashes: C; to work with +lexicals: C. + +=head1 AUTHORS + +Andreas Koenig F<< >> and Tom Christiansen +F<< >>. Based on the old F by Larry +Wall. + +=head1 COPYRIGHT, LICENSE + +This module is + +Copyright (c) 1995, 1997, 2000, 2002, 2005, 2006 Andreas Koenig C<< >>. + +All rights reserved. + +This library is free software; +you may use, redistribute and/or modify it under the same +terms as Perl itself. + +=cut + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# End: diff --git a/lib/Devel/Symdump/Export.pm b/lib/Devel/Symdump/Export.pm new file mode 100644 index 0000000..2401e5f --- /dev/null +++ b/lib/Devel/Symdump/Export.pm @@ -0,0 +1,39 @@ +package Devel::Symdump::Export; +require Devel::Symdump; +require Exporter; +use Carp; +use strict; +use vars qw(@ISA @EXPORT_OK $AUTOLOAD); +@ISA=('Exporter'); + +@EXPORT_OK=( + 'packages' , + 'scalars' , + 'arrays' , + 'hashes' , + 'functions' , + 'filehandles' , + 'dirhandles' , + 'ios' , + 'unknowns' , +); +my %OK; +@OK{@EXPORT_OK}=(1) x @EXPORT_OK; + +push @EXPORT_OK, "symdump"; + +# undocumented feature symdump() -- does it save enough typing? +sub symdump { + my @packages = @_; + Devel::Symdump->new(@packages)->as_string; +} + +AUTOLOAD { + my @packages = @_; + (my $auto = $AUTOLOAD) =~ s/.*:://; + confess("Unknown function call $auto") unless $OK{$auto}; + my @ret = Devel::Symdump->new->$auto(@packages); + return @ret; +} + +1; diff --git a/t/autogen.t b/t/autogen.t new file mode 100644 index 0000000..dfd7f21 --- /dev/null +++ b/t/autogen.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl -w + +BEGIN { unshift @INC, '.' ;} + +require Devel::Symdump; + +print "1..8\n"; + +@p = qw( +scalars arrays hashes functions +unknowns filehandles dirhandles packages); + +$i=0; +if ($] < 5.010) { + # with 5.8.9 just calling a sort() left something behind on the symbol table + @x1 = sort (1,2); +} +for (@p){ + @x1 = sort Devel::Symdump->$_(); + @x2 = sort Devel::Symdump->new->$_(); + unless ("@x1" eq "@x2"){ + my %h1 = map {$_=>1} @x1; + my %h2 = map {$_=>1} @x2; + my %hm; + for (@x1,@x2) { + $hm{$_}++; + } + for my $k (sort keys %hm) { + next if $hm{$k}==2; + if (!exists $h1{$k}) { + print "# only in x2 [$k]\n"; + } else { + print "# only in x1 [$k]\n"; + } + } + print "not "; + } + print "ok ", ++$i, "\n"; +} + diff --git a/t/diff.t b/t/diff.t new file mode 100644 index 0000000..63f3b08 --- /dev/null +++ b/t/diff.t @@ -0,0 +1,72 @@ +#!/usr/bin/perl -w + +use lib 'lib' ; + +use Devel::Symdump (); +BEGIN { + $SIG{__WARN__}=sub {return "" if $_[0] =~ /used only once/; print @_;}; +} + +print "1..1\n"; + +$scalar = 1; +@array = 1; +%hash = (A=>B); +%package::hash = (A=>B); +sub package::function {} +open FH, ">/dev/null"; +opendir DH, "."; + +my $a = Devel::Symdump->rnew; + +my($eval) = <<'END'; +$scalar2 = 1; +undef @array; +undef %hash; +%hash2 = (A=>B); +$package2::scalar3 = 3; +close FH; +closedir DH; +END + +eval $eval; + +my $b = Devel::Symdump->rnew; + +# testing diff is too difficult at the stage between 5.003 and 5.004 +# we have new variables and new methods to determine them. Both have +# an impact on diff, so we're backing out this test and always say ok + +if ( 1 || $a->diff($b) eq 'arrays +- main::array +dirhandles +- main::DH +filehandles +- main::FH +hashes +- main::hash ++ main::hash2 +packages ++ package2 +scalars ++ main::scalar2 ++ package2::scalar3 +unknowns ++ main::DH ++ main::FH ++ main::array ++ main::hash' +){ + print "ok 1\n"; +} else { + print "not ok: +a +- +", $a->as_string, " +b +- +", $b->as_string, " +diff +---- +", $a->diff($b), "\n"; +} diff --git a/t/export.t b/t/export.t new file mode 100644 index 0000000..9ee4971 --- /dev/null +++ b/t/export.t @@ -0,0 +1,16 @@ +print "1..2\n"; + +use Devel::Symdump::Export "symdump"; +$x = symdump(); +if (length($x) > 500){ + print "ok 1\n"; +} else { + print "not ok 1\n", length($x), ":\n$x\n"; +} + +if ($x =~ /arrays.*functions.*hashes.*ios.*packages.*scalars.*unknowns/xs){ + print "ok 2\n"; +} else { + print "not ok 2 $x\n"; +} + diff --git a/t/glob_to_local_typeglob.t b/t/glob_to_local_typeglob.t new file mode 100644 index 0000000..77d7611 --- /dev/null +++ b/t/glob_to_local_typeglob.t @@ -0,0 +1,79 @@ +BEGIN { + $|++; + my $exit_message = ""; + unless ($ENV{AUTHOR_TEST}) { + $exit_message = "test only run when envariable AUTHOR_TEST is set"; + } + unless ($exit_message) { + unless (eval { require Compress::Zlib; 1 }) { + $exit_message = "Compress::Zlib not found"; + } + } + if ($exit_message) { + print "1..0 # SKIP $exit_message\n"; + eval "require POSIX; 1" and POSIX::_exit(0); + exit; + } +} + +use strict; +use warnings; +use Test::More 'no_plan'; +use English; + +diag("OS == $^O"); + +use Compress::Zlib; +use Devel::Symdump; + +diag('$Devel::Symdump::VERSION == '.$Devel::Symdump::VERSION); +diag('$Compress::Zlib::VERSION == '.$Compress::Zlib::VERSION); +diag("Perl == $]"); + +my $glob_ref = eval { + no strict 'refs'; + ${*{"Compress::Zlib::"}}{GZIP_NULL_BYTE}; +}; + +ok(!$@,'reference assignment'); +diag('ref($glob_ref) == "'.ref($glob_ref).'"'); + +_check_child(sub { + local *ENTRY; + diag "Checking GLOB assignment to reference..."; + *ENTRY = $glob_ref; +}); + +_check_child(sub { + diag "Checking Devel::Symdump->rnew->packages..."; + Devel::Symdump->rnew->packages; +}); + +sub _check_child { + local *CHILD; + + my $code = shift; + my $pid = open(CHILD, "|-"); + + unless ($pid) { + $code->(); + exit 0; + } else { + my $w = waitpid($pid,0); + ok($w != -1 && $w == $pid,'waitpid()'); + my $e = $? >> 8; + my $s = $? & 127; + my $c = $? & 128; + diag "exit value = $e"; + diag "exit with signal = $s"; + diag "dumped core? $c"; + ok($s != 11,'child did not SEGV'); + ok($e == 0 && $s == 0,'child exited properly'); + } +} + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# End: diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..756e032 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,17 @@ +# -*- mode: cperl -*- + +BEGIN { + $|++; + unless ($ENV{AUTHOR_TEST}) { + $|=1; + print "1..0 # SKIP test only run when envariable AUTHOR_TEST is set\n"; + eval "require POSIX; 1" and POSIX::_exit(0); + exit; + } +} + +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok(); + diff --git a/t/podcover.t b/t/podcover.t new file mode 100644 index 0000000..ced38d3 --- /dev/null +++ b/t/podcover.t @@ -0,0 +1,16 @@ +# -*- mode: cperl -*- + +BEGIN { + $|++; + unless ($ENV{AUTHOR_TEST}) { + $|=1; + print "1..0 # SKIP test only run when envariable AUTHOR_TEST is set\n"; + eval "require POSIX; 1" and POSIX::_exit(0); + exit; + } +} +use Test::More; +eval "use Test::Pod::Coverage"; +plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if $@; +plan tests => 1; +pod_coverage_ok( "Devel::Symdump" ); diff --git a/t/recur.t b/t/recur.t new file mode 100644 index 0000000..1e1baf3 --- /dev/null +++ b/t/recur.t @@ -0,0 +1,32 @@ +BEGIN { + $|++; + if ($] <= 5.006) { + print "1..0 # Skip: this test is known to fail with 5.005xx\n"; + # (2007-06-25 akoenig: I have seen it working in the debugger) + eval "require POSIX; 1" and POSIX::_exit(0); + } +} +package Acme::Meta; + +BEGIN { + $::Meta::VERSION = $VERSION = 0; # autovivify for perl >= @26370 + $Meta::{'Meta::'} = $main::{'Meta::'}; + $Acme::Meta::{'Meta::'} = $main::{'Meta::'}; +} +use strict; +require Test::More; +my $tests = 3; +Test::More->import( tests => $tests ); +exit unless $tests; +Test::More::ok(1); +$Acme::Meta::Meta::Pie = "good"; +Test::More::is ($Acme::Meta::Meta::Meta::Meta::Pie, "good"); +Test::More::use_ok('Devel::Symdump'); +Devel::Symdump->rnew("Acme"); + +__END__ + +# Local Variables: +# mode: cperl +# cperl-indent-level: 2 +# End: diff --git a/t/symdump.t b/t/symdump.t new file mode 100644 index 0000000..5315183 --- /dev/null +++ b/t/symdump.t @@ -0,0 +1,230 @@ +#!/usr/bin/perl -w + +BEGIN { unshift @INC, '.' ; + $SIG{__WARN__}=sub {return "" if $_[0] =~ /used only once/; print @_;}; +} + +use Devel::Symdump::Export qw(filehandles hashes arrays); +use Test::More; + +plan tests => 13; + +init(); + +my %prefices = qw( + scalars $ + arrays @ + hashes % + functions & + unknowns * + ); + +@prefices{qw(filehandles dirhandles packages)}=("") x 3; + + +format i_am_the_symbol_printing_format_lest_there_be_any_doubt = +Got these @* + "$t:" +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $a + +. + +$~ = 'i_am_the_symbol_printing_format_lest_there_be_any_doubt'; + +@a = packsort(filehandles('main')); +$t = 'filehandles'; +$a = "@a"; +# write; +ok ( + $a eq "main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::stderr main::stdin main::stdout" + || + $a eq "main::ARGV main::DATA main::Hmmmm main::STDERR main::STDIN main::STDOUT main::i_am_the_symbol_printing_format_lest_there_be_any_doubt main::stderr main::stdin main::stdout" + || + $a eq "main::DATA main::DOT main::Hmmmm main::STDERR main::STDIN main::STDOUT main::stderr main::stdin main::stdout", # v5.21.6-337-g67f2cc7 + $a + ); + +@a = packsort(hashes 'main'); +$t = 'hashes'; +$a = uncontrol("@a"); +$a =~ s/main:://g; +#write; +ok ( + $a eq "^H + - @ ENV INC SIG" # + named capture 29682 + || + $a eq "^H + @ ENV INC SIG" # + named capture 28957 + || + $a eq "^H @ ENV INC SIG" # ^H hints 27643 (?) + || + $a eq "^H ENV INC SIG" # v5.19.5-71-gd456e3f + || + $a eq "@ ENV INC SIG" + || + $a eq "ENV INC SIG", + $a + ); + +@a = packsort(arrays()); +$t = 'arrays'; +$a = "@a"; +#write; +like ( + $a, "/main::INC.*main::_.*main::a/", "packsort arrays" + ); + +eval { + @a = Devel::Symdump->really_bogus('main'); +}; +$a = $@ ? $@ : "@a"; +like ($a, + "/^invalid Devel::Symdump method: really_bogus\(\)/", + "really_bogus"); + +$sob = rnew Devel::Symdump; + +@m=(); +for (active_packages($sob)) { + push @m, "$_"; +} +$a="@m"; +like ($a, + "/Carp.*Devel.*Devel::Symdump.*Devel::Symdump::Export.*DynaLoader.*Exporter.*Hidden.*big::long::hairy.*funny::little.*strict/", "active_packages"); + +my %m=(); +for (active_modules($sob)) { + $m{$_}=undef; +} +$a = join " ", keys %m; +#print "[$a]\n"; +ok (exists $m{"Devel::Symdump"} && + exists $m{"Devel::Symdump::Export"} && + exists $m{"Exporter"} && + exists $m{"strict"} && + exists $m{"vars"}, "active_modules"); + +# Cannot test on the number of packages and functions because not +# every perl is built the same way. Static perls will reveal more +# packages and more functions being in them +# Testing on >= seems no problem to me, we'll see + +# (Time passes) Much less unknowns in version 1.22 (perl5.003_10). + +my %Expect=qw( +packages 13 scalars 28 arrays 7 hashes 5 functions 35 filehandles 9 +dirhandles 2 unknowns 53 +); + +#we don't count the unknowns. Newer perls might have different outcomes +for $type ( qw{ + packages + scalars arrays hashes + functions filehandles dirhandles + }){ + next unless @syms = $sob->$type(); + + if ($I_REALLY_WANT_A_CORE_DUMP) { + # if this block execute , mysteriously COREDUMPS at for() below + # NOT TRUE anymore (watched by Andreas, 15.6.1995) + @vars = ($type eq 'packages') ? sort(@syms) : packsort(@syms); + } else { + if ($type eq 'packages') { + @syms = sort @syms; + } else { + @syms = packsort(@syms); + } + } + + ok (@syms >= $Expect{$type}, $type); +} + +exit; + +sub active_modules { + my $ob = shift; + my @modules = (); + my($pack); + for $pack ("main", sort $ob->packages) { + no strict 'refs'; + my %stash = %{"$pack\::"}; + # With restricted hashes we need to check with exists first + # XXX Core limitation: copying to %stash removes the READONLY flag + my $restricted = Internals::SvREADONLY(%{"$pack\::"}); + #warn (($restricted ? "" : "un")."restricted $pack\::\n"); + FUNCS: + for my $f (qw(import AUTOLOAD ISA EXPORT EXPORT_OK)) { + if (!$restricted or exists($stash{$f})) { + if (defined &{ "$pack\::$f"}) { + push @modules, $pack; + #warn "$pack \n"; + last FUNCS; + } + } + } + } + return sort @modules; +} + +sub active_packages { + my $ob = shift; + + my @modules = (); + my $pack; + for $pack ($ob->packages) { + $pob = new Devel::Symdump $pack; + if ( $pob->scalars() || + $pob->hashes() || + $pob->arrays() || + $pob->functions() || + $pob->filehandles()|| + $pob->dirhandles() + ) + { + push @modules, $pack; + } + } + return sort @modules; +} + + +sub uncontrol { + local $_ = $_[0]; + s/([\200-\377])/ 'M-' . pack('c', ord($1) & 0177 ) /eg; + s/([\000-\037\177])/ '^' . pack('c', ord($1) ^ 64 ) /eg; + return $_; +} + +sub packsort { + my (@vars, @pax, @fullnames); + + for (@_) { + my($pack, $name) = /^(.*::)(.*)$/s; + push(@vars, $name); + push(@pax, $pack); + push(@fullnames, $_); + } + + return @fullnames [ + sort { + ($pax[$a] ne 'main::') <=> ($pax[$b] ne 'main::') + || + $pax[$a] cmp $pax[$b] + || + $vars[$a] cmp $vars[$b] + } 0 .. $#fullnames + ]; +} + + +sub init { + $big::long::hairy::thing++; + sub Devel::testsub {}; + opendir(DOT, '.'); + opendir(funny::little::imadir, '/'); + $i_am_a_scalar_variable = 1; + open(Hmmmm, ">/dev/null"); + open(Hidden::FH, ">/dev/null"); +} + + +__END__ diff --git a/t/tree.t b/t/tree.t new file mode 100644 index 0000000..b97ebc4 --- /dev/null +++ b/t/tree.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl -w + +# tree.t + +use Devel::Symdump; + +package Coffee; +@ISA = qw(Liquid Black); + +package Liquid; +package Black; + +package Martini; +@ISA = qw(Liquid); + +package Martini::White; +@ISA = qw(Martini); +package Martini::Red; +@ISA = qw(Martini); + +print "1..2\n"; +my @s = split /\n/, Devel::Symdump->isa_tree; +print @s >= 11 ? "ok 1\n" : "not ok [@s]\n"; +@s = split /\n/, Devel::Symdump->inh_tree; +print @s >= 9 ? "ok 2\n" : "not ok [@s]\n"; + +# The tests are testing with the > operator, because we never know where +# Exporter and Carp (and others) are developing into.