Module-Info-0.39/000755 000765 000024 00000000000 14663552275 014036 5ustar00neilbstaff000000 000000 Module-Info-0.39/bin/000755 000765 000024 00000000000 14663552275 014606 5ustar00neilbstaff000000 000000 Module-Info-0.39/Changes000644 000765 000024 00000022366 14663552074 015337 0ustar00neilbstaff000000 000000 Revision history for perl module Module::Info 0.39 2024-08-28 NEILB - Fixed RT#129677 with patch from HAARG++. 0.38 2024-08-28 NEILB - Get rid of ' as package namespace separator 0.37 2015-11-01 NEILB - Added a has_pod() method, which returns the path to the file containing the pod (it could be a .pod file), if there is one. Thanks to YANICK for this. - Listed NEILB as the current maintainer in the AUTHOR section. Thanks again to YANICK. - Added link to github repo to doc. 0.36 2015-10-23 NEILB - Dropped our own fork of B::Utils, now rely on CPAN one - RT#13524 - Now works on recent versions of Perl - RT#97105 - Pod tests not run on installation - RT#90599 0.35_07 2015-10-19 NEILB - I had missed another instance of "the Windows cwd() issue" affecting t/n1_modules_required.t 0.35_06 2015-10-17 NEILB - Added "use strict" to both modules - Made the pod coverage test a release test RT#90599 - Added MIN_PERL_VERSION to Makefile.PL - Added a basic README 0.35_05 2015-10-16 NEILB - Had a single failure reported by CPAN Testers for Perl 5.22/Windows. On Windows, if you "use Cwd" and then call cwd(), then it does an implicit "use Win32". On recent perls (sometime after 5.20.1) this seems to get built into the op tree in a way that looks like the scope doing the cwd() use'd Win32. There are several magic functions in Cwd.pm which will probably trigger this behaviour. I'll see how this change tests out, and possibly just document it for a non dev release. 0.35_04 2015-10-14 NEILB - Sigh, forgot to update the min version of B::Utils in Makefile.PL Thanks to SREZIC for letting me know. 0.35_03 2015-10-13 NEILB - Removed File::Spec from t/lib/ - Set min required version of B::Utils to 0.27, as that release fixes the remaining failing tests. - Hacked const_sv() to cope with the change in OP_METHOD_NAMED that happened at 5.21.5 (or possibly an earlier 5.21.*). 0.35_02 2015-06-15 NEILB - Sigh, forgot to add B::Utils to PREREQ_PM 0.35_01 2015-06-15 NEILB - Dropped B::BUtils in favour of using the standard B::Utils. subroutines_called() stopped working correctly for standard function calls, identifying them as calls via symbolic references. Fixed that. - Dropped Build.PL 0.35 2013-09-08 14:10:31 CEST - Handle 'package NAME VERSION' syntax (patch by Norbert Gruener) - Added repository and license info to metadata - Tweaked format of Changes (this file) to match CPAN::Changes::Spec 0.34 2013-05-21 21:48:49 CEST - Replace Test::Soundex in tests with Class::Struct, since Text::Soundex will not be in core in Perl 5.19 and up. - Replace ExtUtils::MY_Metafile with META_MERGE in Makefile.PL. 0.33 2013-02-9 13:12:22 CET - Fix tests under Perl 5.6.2 when some core modules have been upgraded (patch by Andreas Koenig). 0.32 2010-09-8 23:15:13 CEST - Add archlib and privlib to the search path for core modules (patch by Jonas B. Nielsen). 0.31_01 2010-04-12 23:53:53 CEST - Many test fixes. 0.31 2007-05-28 21:40:10 CEST - Fixed tests in presence of version.pm 0.72 or newer. - Added -h option to module_info. 0.30 2005-12-20 20:17:09 CET - Renamed the forked B::Utils to B::BUtils to avoid clashes until it is merged into the mainline. 0.29 2005-11-22 21:28:26 CET - Fixed version() for complex expressions. - Corrected some POD errors in module_info. 0.28_50 2005-07-10 21:48:19 CEST - Added support for version.pm (based upon a patch by John Peacock). - Fixed the safe() attribute to be per-object instead of global. 0.28 2005-04-17 17:10:33 CET - Correct the attributions of the fixes in 0.27 (I swapped authors' names). - Added Module::Build support as an alternative to ExtUtils::MakeMaker. - Added safe() option to forbid unsafe operations (currently executes version() code in a Safe compartment and forbids most other operations). - Fixed compatibility down to Perl 5.004_04. 0.27 2005-03-4 07:56:58 CET - Added missing localization of $_ in version(). (thanks to Johan Lodin) - Fixed new_from_loaded() to return nothing when the module is in fact not loaded. (thanks to Boris Zentner) 0.26 2004-07-11 17:15:36 CEST - Fix tests for Perl 5.8.x and 5.6.x. 0.25 2004-07-11 16:36:11 CEST - Fix test to work around modules_required reporting different version numbers (0.25 vs. 0.250) under bleadperl. - Report subroutine/method calls and modules required inside anonymous subroutines. 0.24 2003-10-1 11:45:45 CEST - Fixed version reported by modules_required for bleadperl. 0.23 2003-09-4 17:44:52 CEST - Fixes for modules other than the one being examined loaded from paths containing spaces. 0.22 2003-08-18 14:44:23 CEST - Fixed reporting of static method calls in Perl 5.8.1 RC4 - Fixed reporting of module versions in Perl 5.8.1 RC4 when "use Foo 1.2.3;" is used 0.21 2003-08-15 18:48:53 CEST - Added licensing information to Module::Info POD - Added modules_required(). Original patch by Martyn J. Pearce, adapted by me (Mattia Barbon) 0.20 2003-05-22 10:30:31 CEST - Fixed a warning in module_info (thanks to Nathan Torkington) - Corrected number of skipped tests for Perl versions earlier than 5.6.1 (thanks to Mike Fragassi) - Fixed syntax error with Perl 5.004 0.19 2003-04-1 15:45:43 CEST - Added package_versions() (patch by Ken Williams) - Fixed handling of v-strings in use/require 0.18 2003-03-8 17:44:24 CET - Upgraded bundled B::Utils to 0.04 + Schwern patches - Fixed detection of require() statements in non-trivial BEGIN blocks 0.17 2003-03-2 11:01:55 CET - Added module_info - Fixed a warning when enumerating packages 0.16 2003-01-1 21:21:31 CET - Capture stderr output on MacOS Classic (thanks to Axel Rose for the patch) 0.15 2002-12-23 15:08:14 CET - Added die_on_compilation_error() method. - MacOS classic: fixed methods requiring loading. 0.14 2002-12-8 11:42:11 CET - Don't show modules loaded via $ENV{PERL5OPT} - Fixed the case where an op may be NULL when searching for require 0.13 2002-12-7 10:29:42 CET - pfunc can now distinguish between class and object methods - B::Utils no longer loading Exporter to avoid loading a bunch of modules - B::Utils's fake carp/croak were broken - B::Utils::opgrep() was not finding ops properly - Test made more polite for systems who's path_sep is not : - Fixing case where an op filter may encounter a NULL op when checking for entersubs - Quote filename in the call to B::Module::Info, allows using directories with spaces - Fixed the case where a module does not have any BEGIN blocks - Fixed non-bareword require in a BEGIN block - Fixed require $foo - Fixed BEGIN blocks not containing a require - Scan subroutines when searching for required modules - Fixed various problems with perl 5.6.1 on Win32 (probably due to ithreads) - Use IPC::Open3 under Windows 95/98/ME, since 2>&1 does not work 0.12 2002-02-2 19:41:01 EST - Added pfunc - Now tested back to 5.004 - Fixed a bug where certain modules were being ignored - Fixed a bug in subroutines_called() with EXPR->method() - subroutines_called() now reports properly on function calls with symbolic refs 0.11 2002-02-2 16:54:23 EST - Fixed B::Utils->kids - Added subroutines_called() - Added superclasses() - Added dynamic_method_calls() - Documented that it isn't just for modules. - name() can now be used to set - failures inside B::Module::Info now report their errors instead of failing silently - Added a THANKS section. 0.10 2001-12-12 05:40:14 EST - Windows filenames would cause subroutines() and modules_used() to choke. (Thanks to Alessandro Forghieri for the patch) 0.09 2001-12-10 14:55:09 EST - little bug in modules_used() and "require 5.004" 0.08 2001-12-10 14:24:56 EST - Implemented modules_used() - Fixed a little bug in walkoptree_filtered() and $B::Utils::file/line 0.07 2001-12-10 11:09:40 EST - Implemented subroutines(). Need help getting modules_used() done. - Fixed up $B::Utils::file/line handling in B::Utils. - Fixed a little bug in is_core involving cannonical paths. I forget who gave me the patch! 0.06 2001-11-24 20:45:15 EST - Implemented packages_inside(). Need help getting the rest done. - Distributing a hacked up version of B::Utils until the main distribution gets fixed. 0.05 2001-11-23 18:06:22 EST - Rafael Garcia-Suarez noticed I forgot to deal with code refs in @INC. The plan is to just skip them until someone notices. 0.04 2001-11-23 14:49:21 EST - Tassilo von Parseval noted warnings.pm isn't backwards compat. Replaced with $^W. 0.03 2001-11-23 00:39:11 EST - Testing all_installed() - Abe Timmerman fixed a little portability bug in the test. 0.02 2001-11-22 10:08:00 EST - Added new_from_loaded() 0.01 2001-11-22 09:42:06 EST - First working version - From a discussion on p5p about ExtUtils::MM_Unix->parse_version http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-11/msg01263.html Module-Info-0.39/MANIFEST000644 000765 000024 00000001020 14663552275 015160 0ustar00neilbstaff000000 000000 Changes MANIFEST README Makefile.PL bin/module_info bin/pfunc lib/B/Module/Info.pm lib/Module/Info.pm t/Module-Info.t t/lib/Bar.pm t/lib/Baz.pm t/lib/Boo.pm t/lib/Foo.pm t/lib/Moo.pm t/lib/Roo.pm t/lib/Test/Builder.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/n0_die_on_error.t t/n1_modules_required.t t/n2_safe.t t/n3_version.t t/zy_pod_coverage.t t/zz_pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Module-Info-0.39/t/000755 000765 000024 00000000000 14663552275 014301 5ustar00neilbstaff000000 000000 Module-Info-0.39/README000644 000765 000024 00000001237 12610533572 014706 0ustar00neilbstaff000000 000000 README for Perl module Module::Info Module::Info can be used to get information other Perl modules, without loading them into your process. You can read a nicely formatted version of the documentation for this module online: https://metacpan.org/pod/Module::Info You should be able to install this using your usual method for installing modules from CPAN. If you don't have one, have a look at: http://www.cpan.org/modules/INSTALL.html This module was originally written by Michael G Schwern . It was maintained from 2002 to 2013 by Mattia Barbon . It is currently being maintained by Neil Bowers . Module-Info-0.39/META.yml000644 000765 000024 00000001174 14663552275 015312 0ustar00neilbstaff000000 000000 --- abstract: 'Information about Perl modules' author: - 'Mattia Barbon ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: open_source meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Module-Info no_index: directory: - t - inc requires: B: '0' B::Utils: '0.27' Carp: '0' File::Spec: '0.8' perl: '5.006' strict: '0' version: '0.39' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Module-Info-0.39/lib/000755 000765 000024 00000000000 14663552275 014604 5ustar00neilbstaff000000 000000 Module-Info-0.39/Makefile.PL000644 000765 000024 00000005125 12610531170 015770 0ustar00neilbstaff000000 000000 # A template for Makefile.PL. # - Set the $PACKAGE variable to the name of your module. # - Set $LAST_API_CHANGE to reflect the last version you changed the API # of your module. # - Fill in your dependencies in PREREQ_PM # Alternatively, you can say the hell with this and use h2xs. require 5.004; use strict; use ExtUtils::MakeMaker; my $PACKAGE = 'Module::Info'; (my $PACKAGE_FILE = $PACKAGE) =~ s|::|/|g; my $LAST_API_CHANGE = 0; eval "require $PACKAGE"; unless ($@) { # Make sure we did find the module. no strict 'refs'; print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE; NOTE: There have been API changes between this version and any older than version $LAST_API_CHANGE! Please read the Changes file if you are upgrading from a version older than $LAST_API_CHANGE. CHANGE_WARN } ( my $mmv = ExtUtils::MakeMaker->VERSION ) =~ s/_//g; WriteMakefile( NAME => $PACKAGE, VERSION_FROM => "lib/$PACKAGE_FILE.pm", # finds $VERSION ABSTRACT_FROM => "lib/$PACKAGE_FILE.pm", PREREQ_PM => { 'File::Spec' => 0.8, 'B' => 0, 'B::Utils' => 0.27, 'strict' => 0, 'Carp' => 0, }, 'dist' => { COMPRESS => 'gzip -9', SUFFIX => '.gz', DIST_DEFAULT => 'all tardist', }, EXE_FILES => [qw(bin/pfunc bin/module_info)], PL_FILES => {}, # skip Build.PL ($mmv >= 6.31 ? (LICENSE => 'perl') : ()), ($mmv >= 6.48 ? (MIN_PERL_VERSION => '5.006') : ()), ( $] >= 5.005 ? ( AUTHOR => 'Mattia Barbon ' ) : () ), ($mmv <= 6.45 ? () : (META_MERGE => { resources => { repository => 'https://github.com/mbarbon/module-info' }, }) ), ( $mmv >= 6.47 ? ( META_MERGE => { license => 'perl', dynamic_config => 0, } ) : () ) ); { package MY; sub test_via_harness { my($self, $orig_perl, $tests) = @_; my @perls = ($orig_perl); push @perls, qw(bleadperl perl5.6.1 perl5.6.0 perl5.005_03 perl5.004_05 perl5.004_04 perl5.004 ) if $ENV{PERL_TEST_ALL}; my $out; foreach my $perl (@perls) { $out .= $self->SUPER::test_via_harness($perl, $tests); } return $out; } } Module-Info-0.39/META.json000644 000765 000024 00000002101 14663552275 015451 0ustar00neilbstaff000000 000000 { "abstract" : "Information about Perl modules", "author" : [ "Mattia Barbon " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5", "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Module-Info", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "B" : "0", "B::Utils" : "0.27", "Carp" : "0", "File::Spec" : "0.8", "perl" : "5.006", "strict" : "0" } } }, "release_status" : "stable", "version" : "0.39", "x_serialization_backend" : "JSON::PP version 4.04" } Module-Info-0.39/lib/Module/000755 000765 000024 00000000000 14663552275 016031 5ustar00neilbstaff000000 000000 Module-Info-0.39/lib/B/000755 000765 000024 00000000000 14663552275 014765 5ustar00neilbstaff000000 000000 Module-Info-0.39/lib/B/Module/000755 000765 000024 00000000000 14663552275 016212 5ustar00neilbstaff000000 000000 Module-Info-0.39/lib/B/Module/Info.pm000644 000765 000024 00000031352 14663552131 017436 0ustar00neilbstaff000000 000000 package B::Module::Info; use 5.006; use strict; our $VERSION = '0.39'; use B; use B::Utils 0.27 qw(walkoptree_filtered walkoptree_simple opgrep all_roots); @B::Utils::bad_stashes = qw(); # give us everything. our ($Start, $End, $File, $CurCV); =head1 NAME B::Module::Info - information about Perl modules =cut { # From: Roland Walker # "Syntax OK" may land inside output and render it unusable my $oldfh = select STDERR; $| = 1; # STDERR is unbuffered, but just in case select STDOUT; $| = 1; select $oldfh; } my $the_file = $0; # when walking all subroutines, you need to skip # the ones in other modules sub state_change { return opgrep {name => [qw(nextstate dbstate setstate)]}, @_ } my $cur_pack; sub state_call { my($op) = shift; my $pack = $op->stashpv; print "$pack\n" if !defined($cur_pack) || $pack ne $cur_pack; $cur_pack = $pack; } sub filtered_roots { my %roots = all_roots; my %filtered_roots = (); while( my($name, $op) = each %roots ) { next if $name eq '__MAIN__'; $filtered_roots{$name} = $op; } return %filtered_roots; } =head2 roots_cv_pairs_recursive Returns a list of pairs, each containing a root with the relative B::CV object; this list includes B::main_root/cv and all anonymous subroutines defined therein. =cut sub roots_cv_pairs_recursive { my @queue = roots_cv_pairs(); my @roots; my $anon_sub = sub { B::class($_[0]) ne 'NULL' && $_[0]->name eq 'anoncode'; }; my $anon_check = sub { my $cv = const_sv($_[0]); push @queue, [ $cv->ROOT, $cv ]; }; while( @queue ) { my $p = shift @queue; push @roots, $p; local $CurCV = $p->[1]; walkoptree_filtered($p->[0], $anon_sub, $anon_check ); } return @roots; } =head2 roots_cv_pairs Returns a list of pairs, each containing a root with the relative B::CV object for named subroutines; this list includes B::main_root/cv. =cut sub roots_cv_pairs { my %roots = filtered_roots; my @roots = ( [ B::main_root, B::main_cv ], map { [ $roots{$_}, B::svref_2object(\&{$_}) ] } keys %roots ); } my %modes = ( packages => sub { walkoptree_filtered(B::main_root, \&state_change, \&state_call ); }, subroutines => sub { my %roots = filtered_roots(); while( my($name, $op) = each %roots ) { local($File, $Start, $End); walkoptree_simple($op, \&sub_info); print "$name at \"$File\" from $Start to $End\n"; } }, modules_used => sub { # begin_av is an undocumented B function. # note: if module hasn't any BEGIN block, # begin_av will be a B::SPECIAL my @arr = B::begin_av->isa('B::SPECIAL') ? () : B::begin_av->ARRAY; foreach my $begin_cv (@arr) { my $root = $begin_cv->ROOT; local $CurCV = $begin_cv; next unless $begin_cv->FILE eq $the_file; # cheat otherwise show_require guard prevents display local $B::Utils::file = $begin_cv->FILE; local $B::Utils::line = $begin_cv->START->line; # this is from $ENV{PERL5OPT}, skip it next if $B::Utils::line == 0; my $lineseq = $root->first; next if $lineseq->name ne 'lineseq'; my $req_op = $lineseq->first->sibling; if( $req_op->name eq 'require' ) { my $module; if( $req_op->first->private & B::OPpCONST_BARE ) { $module = const_sv($req_op->first)->PV; $module =~ s[/][::]g; $module =~ s/.pm$//; } else { # if it is not bare it can't be an "use" show_require($req_op); next; } printf "use %s (%s) at \"%s\" line %s\n", $module, get_required_version($req_op, $module), $begin_cv->FILE, $begin_cv->START->line; } # it can't be an use, scan the optree else { walkoptree_filtered($root, \&is_require, \&show_require, ); } } { foreach my $p ( roots_cv_pairs_recursive ) { local $CurCV = $p->[1]; walkoptree_filtered($p->[0], \&is_require, \&show_require, ); } } }, subs_called => sub { foreach my $p ( roots_cv_pairs_recursive ) { local $CurCV = $p->[1]; walkoptree_filtered($p->[0], \&sub_call, \&sub_check ); } } ); sub const_sv { my $op = shift; my $sv; if ($op->name eq 'method_named' && $op->can('meth_sv')) { $sv = $op->meth_sv; } elsif ($op->can('sv')) { $sv = $op->sv; } # the constant could be in the pad (under useithreads) $sv = padval($op->targ) unless ref($sv) && $$sv; return $sv; } # Don't do this for regexes sub unback { my($str) = @_; $str =~ s/\\/\\\\/g; return $str; } sub const { my $sv = shift; if (B::class($sv) eq "SPECIAL") { return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif (B::class($sv) eq "NULL") { return 'undef'; } elsif ($sv->FLAGS & B::SVf_IOK) { return $sv->int_value; } elsif ($sv->FLAGS & B::SVf_NOK) { # try the default stringification my $r = "".$sv->NV; if ($r =~ /e/) { # If it's in scientific notation, we might have lost information return sprintf("%.20e", $sv->NV); } return $r; } elsif ($sv->FLAGS & B::SVf_ROK && $sv->can("RV")) { return "\\(" . B::const($sv->RV) . ")"; # constant folded } elsif ($sv->FLAGS & B::SVf_POK) { my $str = $sv->PV; if ($str =~ /[^ -~]/) { # ASCII for non-printing return single_delim("qq", '"', uninterp escape_str unback $str); } else { return single_delim("q", "'", unback $str); } } else { return "undef"; } } sub single_delim { my($q, $default, $str) = @_; return "$default$str$default" if $default and index($str, $default) == -1; my($succeed, $delim); ($succeed, $str) = balanced_delim($str); return "$q$str" if $succeed; for $delim ('/', '"', '#') { return "$q$delim" . $str . $delim if index($str, $delim) == -1; } if ($default) { $str =~ s/$default/\\$default/g; return "$default$str$default"; } else { $str =~ s[/][\\/]g; return "$q/$str/"; } } sub padval { my $targ = shift; return (($CurCV->PADLIST->ARRAY)[1]->ARRAY)[$targ]; } sub sub_info { $File = undef if $File eq '__none__'; $File ||= $B::Utils::file; $Start = $B::Utils::line if !$Start || $B::Utils::line < $Start; $End = $B::Utils::line if !$End || $B::Utils::line > $End; } sub is_begin { my($op) = shift; my $name = $op->GV; print $name; return $name eq 'BEGIN'; } sub begin_is_use { my($op) = shift; print "Saw begin\n"; } sub grep_magic { my($pvmg, $type) = @_; my $magic = $pvmg->MAGIC; while ($$magic) { return $magic if $magic->TYPE eq $type; } return $magic; # false } sub get_required_version { my($req_op, $module) = (shift, shift); my $version; my $version_op = $req_op->sibling; return if B::class($version_op) eq 'NULL'; if ($version_op->name eq 'lineseq') { # We have a version parameter; skip nextstate & # pushmark my $constop = $version_op->first->next->next; return '' unless const_sv($constop)->PV eq $module; $constop = $constop->sibling; $version = const_sv($constop); my $class = B::class($version); my $magic; $version = $class eq 'IV' ? $version->int_value : $class eq 'NV' ? $version->NV : ($class eq 'PVMG' && ($magic = grep_magic($version, 'V')) && $$magic) ? 'v' . $magic->PTR : ((($class eq 'PVNV' && $] < 5.009) || $class eq 'PVMG') && length($version->PV)) ? 'v' . join('.', map(ord, split(//, $version->PV) )) : $class eq 'PVIV' ? $version->int_value : $version->NV; $constop = $constop->sibling; return '' if $constop->name ne "method_named"; return '' if const_sv($constop)->PV ne "VERSION"; } return $version; } sub is_require { B::class($_[0]) ne 'NULL' && $_[0]->name eq 'require'; } sub show_require { return unless $B::Utils::file eq $the_file; my($op) = shift; my($name, $bare); if( B::class($op) eq "UNOP" and $op->first->name eq 'const' and $op->first->private & B::OPpCONST_BARE ) { $bare = 'bare'; $name = const_sv($op->first)->PV; } else { $bare = 'not bare'; if ($op->flags & B::OPf_KIDS) { my $kid = $op->first; if (defined prototype("CORE::$name") && prototype("CORE::$name") =~ /^;?\*/ && $kid->name eq "rv2gv") { $kid = $kid->first; } my $sv = const_sv($kid); return unless defined $sv && !$sv->isa('B::NULL'); $name = $sv->isa("B::NV") ? $sv->NV : 0; $name ||= $sv->isa("B::PV") ? $sv->PV : ''; $name ||= $sv->IV; } else { $name = ""; } } printf "require %s %s at line %d\n", $bare, $name, $B::Utils::line; } sub compile { my($mode) = shift; return $modes{$mode}; } sub sub_call { B::class($_[0]) ne 'NULL' && $_[0]->name eq 'entersub'; } sub sub_check { my($op) = shift; unless( $op->name eq 'entersub' ) { warn "sub_check only works with entersub ops"; return; } my @kids = $op->kids; # static method call if( my($kid) = grep $_->name eq 'method_named', @kids ) { my $class = _class_or_object_method(@kids); printf "%s method call to %s%s at \"%s\" line %d\n", $class ? "class" : "object", const_sv($kid)->PV, $class ? " via $class" : '', $B::Utils::file, $B::Utils::line; } # dynamic method call elsif( my($kid) = grep $_->name eq 'method', @kids ) { my $class = _class_or_object_method(@kids); printf "dynamic %s method call%s at \"%s\" line %d\n", $class ? "class" : "object", $class ? " via $class" : '', $B::Utils::file, $B::Utils::line; } # function call else { my $gv_op; my ($filename, $line) = ($B::Utils::file, $B::Utils::line); walkoptree_simple($op, sub { my $op = shift; $gv_op = $op if $op->name eq 'gv'; } ); if ($gv_op) { my $gv = gv_or_padgv($gv_op); printf "function call to %s at \"%s\" line %d\n", $gv->NAME, $filename, $line; } else { printf "function call using symbolic ref at \"%s\" line %d\n", $filename, $line; } } } sub gv_or_padgv { # my $self = shift; my $op = shift; if ($op->isa("B::PADOP")) { return padval($op->padix); } else { # class($op) eq "SVOP" return $op->gv; } } sub _class_or_object_method { my @kids = @_; my $class; my($classop) = $kids[1]; if( $classop->name eq 'const' ) { $class = const_sv($classop)->PV; } return $class; } 1; Module-Info-0.39/lib/Module/Info.pm000644 000765 000024 00000051435 14663552123 017262 0ustar00neilbstaff000000 000000 package Module::Info; use 5.006; use strict; use warnings; use Carp; use File::Spec; use Config; my $has_version_pm = eval 'use version; 1'; our $AUTOLOAD; our $VERSION; $VERSION = eval 'use version; 1' ? 'version'->new('0.39') : '0.39'; $VERSION = eval $VERSION; =head1 NAME Module::Info - Information about Perl modules =head1 SYNOPSIS use Module::Info; my $mod = Module::Info->new_from_file('Some/Module.pm'); my $mod = Module::Info->new_from_module('Some::Module'); my $mod = Module::Info->new_from_loaded('Some::Module'); my @mods = Module::Info->all_installed('Some::Module'); my $name = $mod->name; my $version = $mod->version; my $dir = $mod->inc_dir; my $file = $mod->file; my $is_core = $mod->is_core; # Only available in perl 5.6.1 and up. # These do compile the module. my @packages = $mod->packages_inside; my @used = $mod->modules_used; my @subs = $mod->subroutines; my @isa = $mod->superclasses; my @calls = $mod->subroutines_called; # Check for constructs which make perl hard to predict. my @methods = $mod->dynamic_method_calls; my @lines = $mod->eval_string; *UNIMPLEMENTED* my @lines = $mod->gotos; *UNIMPLEMENTED* my @controls = $mod->exit_via_loop_control; *UNIMPLEMENTED* my @unpredictables = $mod->has_unpredictables; *UNIMPLEMENTED* # set/get Module::Info options $self->die_on_compilation_error(1); my $die_on_error = $mod->die_on_compilation_error; $self->safe(1); my $safe = $mod->safe; =head1 DESCRIPTION Module::Info gives you information about Perl modules B. It actually isn't specific to modules and should work on any perl code. =head1 METHODS =head2 Constructors There are a few ways to specify which module you want information for. They all return Module::Info objects. =over 4 =item new_from_file my $module = Module::Info->new_from_file('path/to/Some/Module.pm'); Given a file, it will interpret this as the module you want information about. You can also hand it a perl script. If the file doesn't exist or isn't readable it will return false. =cut sub new_from_file { my($proto, $file) = @_; my($class) = ref $proto || $proto; return unless -r $file; my $self = {}; $self->{file} = File::Spec->rel2abs($file); $self->{dir} = ''; $self->{name} = ''; $self->{safe} = 0; $self->{use_version} = 0; return bless $self, $class; } =item new_from_module my $module = Module::Info->new_from_module('Some::Module'); my $module = Module::Info->new_from_module('Some::Module', @INC); Given a module name, @INC will be searched and the first module found used. This is the same module that would be loaded if you just say C. If you give your own @INC, that will be used to search instead. =cut sub new_from_module { my($class, $module, @inc) = @_; return ($class->_find_all_installed($module, 1, @inc))[0]; } =item new_from_loaded my $module = Module::Info->new_from_loaded('Some::Module'); Gets information about the currently loaded version of Some::Module. If it isn't loaded, returns false. =cut sub new_from_loaded { my($class, $name) = @_; my $mod_file = join('/', split('::', $name)) . '.pm'; my $filepath = $INC{$mod_file} || ''; my $module = Module::Info->new_from_file($filepath) or return; $module->{name} = $name; ($module->{dir} = $filepath) =~ s|/?\Q$mod_file\E$||; $module->{dir} = File::Spec->rel2abs($module->{dir}); $module->{safe} = 0; $module->{use_version} = 0; return $module; } =item all_installed my @modules = Module::Info->all_installed('Some::Module'); my @modules = Module::Info->all_installed('Some::Module', @INC); Like new_from_module(), except I modules in @INC will be returned, in the order they are found. Thus $modules[0] is the one that would be loaded by C. =cut sub all_installed { my($class, $module, @inc) = @_; return $class->_find_all_installed($module, 0, @inc); } # Thieved from Module::InstalledVersion sub _find_all_installed { my($proto, $name, $find_first_one, @inc) = @_; my($class) = ref $proto || $proto; @inc = @INC unless @inc; my $file = File::Spec->catfile(split /::/, $name) . '.pm'; my @modules = (); DIR: foreach my $dir (@inc) { # Skip the new code ref in @INC feature. next if ref $dir; my $filename = File::Spec->catfile($dir, $file); if( -r $filename ) { my $module = $class->new_from_file($filename); $module->{dir} = File::Spec->rel2abs($dir); $module->{name} = $name; push @modules, $module; last DIR if $find_first_one; } } return @modules; } =back =head2 Information without loading The following methods get their information without actually compiling the module. =over 4 =item B my $name = $module->name; $module->name($name); Name of the module (ie. Some::Module). Module loaded using new_from_file() won't have this information in which case you can set it yourself. =cut sub name { my($self) = shift; $self->{name} = shift if @_; return $self->{name}; } =item B my $version = $module->version; Divines the value of $VERSION. This uses the same method as ExtUtils::MakeMaker and all caveats therein apply. =cut # Thieved from ExtUtils::MM_Unix 1.12603 sub version { my($self) = shift; local($_, *MOD); my $parsefile = $self->file; my $safe = $self->safe; open(MOD, $parsefile) or die $!; my $inpod = 0; my $result; while () { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod || /^\s*#/; chomp; # taken from ExtUtils::MM_Unix 6.63_02 next if /^\s*(if|unless|elsif)/; if (m{^\s*package\s+\w[\w\:\']*\s+(v?[0-9._]+)\s*;}) { local $^W = 0; $result = $1; last; } next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = sprintf qq{ package Module::Info::_version; %s local $1$2; \$$2=undef; do { %s }; \$$2 }, ( $safe ? '' : 'no strict;' ), $_; local $^W = 0; $result = $self->_eval($eval); warn "Could not eval '$eval' in $parsefile: $@" if $@ && !$safe; $result = "undef" unless defined $result; last; } close MOD; $result = 'version'->new($result) # quotes for 5.004 if $self->use_version && (!ref($result) || !UNIVERSAL::isa($result, "version")); return $result; } =item B my $dir = $module->inc_dir; Include directory in which this module was found. Module::Info objects created with new_from_file() won't have this info. =cut sub inc_dir { my($self) = shift; return $self->{dir}; } =item B my $file = $module->file; The absolute path to this module. =cut sub file { my($self) = shift; return $self->{file}; } =item B my $is_core = $module->is_core; Checks if this module is the one distributed with Perl. B This goes by what directory it's in. It's possible that the module has been altered or upgraded from CPAN since the original Perl installation. =cut sub is_core { my($self) = shift; return scalar grep $self->{dir} eq File::Spec->canonpath($_), ($Config{installarchlib}, $Config{installprivlib}, $Config{archlib}, $Config{privlib}); } =item B my $has_pod = $module->has_pod; Returns the location of the module's pod, which can be the module file itself, if the POD is inlined, the associated POD file, or nothing if there is no POD at all. =cut sub has_pod { my $self = shift; my $filename = $self->file; open my $file, "<", $filename or return; # the file won't even open while( <$file> ) { return $filename if /^=[a-z]/; } # nothing found? Try a companion POD file $filename =~ s/\.[^.]+$/.pod/ or return; return unless -f $filename; open $file, "<", $filename or return; while( <$file> ) { return $filename if /^=[a-z]/; } return; } =back =head2 Information that requires loading. B From here down reliability drops rapidly! The following methods get their information by compiling the module and examining the opcode tree. The module will be compiled in a separate process so as not to disturb the current program. They will only work on 5.6.1 and up and requires the B::Utils module. =over 4 =item B my @packages = $module->packages_inside; Looks for any explicit C declarations inside the module and returns a list. Useful for finding hidden classes and functionality (like Tie::StdHandle inside Tie::Handle). B Currently doesn't spot package changes inside subroutines. =cut sub packages_inside { my $self = shift; my %packs = map {$_, 1} $self->_call_B('packages'); return keys %packs; } =item B my %versions = $module->package_versions; Returns a hash whose keys are the packages contained in the module (these are the same as what's returned by C), and whose values are the versions of those packages. =cut sub package_versions { my $self = shift; my @packs = $self->packages_inside; # To survive the print(), we translate undef into '~' and then back again. (my $quoted_file = $self->file) =~ s/(['\\])/\\$1/g; my $command = qq{-le "require '$quoted_file';}; foreach (@packs) { $command .= " print defined $_->VERSION ? $_->VERSION : '~';" } $command .= qq{"}; my ($status, @versions) = $self->_call_perl($command); chomp @versions; foreach (@versions) { $_ = undef if $_ eq '~'; } my %map; @map{@packs} = @versions; return %map; } =item B my @used = $module->modules_used; Returns a list of all modules and files which may be C'd or C'd by this module. B These modules may be conditionally loaded, can't tell. Also can't find modules which might be used inside an C. =cut sub modules_used { my($self) = shift; my %used = $self->modules_required; return keys %used; } =item B my %required = $module->modules_required; Returns a list of all modules and files which may be C'd or C'd by this module, together with the minimum required version. The hash is keyed on the module/file name, the corrisponding value is an array reference containing the requied versions, or an empty array if no specific version was required. B These modules may be conditionally loaded, can't tell. Also can't find modules which might be used inside an C. =cut sub modules_required { my($self) = shift; my $mod_file = $self->file; my @mods = $self->_call_B('modules_used'); my @used_mods = (); my %used_mods = (); for (grep /^use \D/ && /at "\Q$mod_file\E" /, @mods) { my($file, $version) = /^use (\S+) \(([^\)]*)\)/; $used_mods{_file2mod($file)} ||= []; next unless defined $version and length $version; push @{$used_mods{_file2mod($file)}}, $version; } push @used_mods, map { my($file) = /^require bare (\S+)/; _file2mod($file) } grep /^require bare \D/ , @mods; push @used_mods, map { /^require not bare (\S+)/; $1 } grep /^require not bare \D/, @mods; foreach ( @used_mods ) { $used_mods{$_} = [] }; return %used_mods; } sub _file2mod { my($mod) = shift; $mod =~ s/\.pm//; $mod =~ s|/|::|g; return $mod; } =item B my %subs = $module->subroutines; Returns a hash of all subroutines defined inside this module and some info about it. The key is the *full* name of the subroutine (ie. $subs{'Some::Module::foo'} rather than just $subs{'foo'}), value is a hash ref with information about the subroutine like so: start => line number of the first statement in the subroutine end => line number of the last statement in the subroutine Note that the line numbers may not be entirely accurate and will change as perl's backend compiler improves. They typically correspond to the first and last I statements in a subroutine. For example: sub foo { package Wibble; $foo = "bar"; return $foo; } Taking C as line 1, Module::Info will report line 3 as the start and line 4 as the end. C is a compile-time statement. Again, this will change as perl changes. Note this only catches simple C subroutine declarations. Anonymous, autoloaded or eval'd subroutines are not listed. =cut sub subroutines { my($self) = shift; my $mod_file = $self->file; my @subs = $self->_call_B('subroutines'); return map { /^(\S+) at "[^"]+" from (\d+) to (\d+)/; ($1 => { start => $2, end => $3 }) } grep /at "\Q$mod_file\E" /, @subs; } sub _get_extra_arguments { '' } sub _call_B { my($self, $arg) = @_; my $mod_file = $self->file; my $extra_args = $self->_get_extra_arguments; my $command = qq{$extra_args "-MO=Module::Info,$arg" "$mod_file"}; my($status, @out) = $self->_call_perl($command); if( $status ) { my $exit = $status >> 8; my $msg = join "\n", "B::Module::Info,$arg use failed with $exit saying:", @out; if( $self->{die_on_compilation_error} ) { die $msg; } else { warn $msg; return; } } @out = grep !/syntax OK$/, @out; chomp @out; return @out; } =item B my @isa = $module->superclasses; Returns the value of @ISA for this $module. Requires that $module->name be set to work. B superclasses() is currently cheating. See L below. =cut sub superclasses { my $self = shift; my $mod_file = $self->file; my $mod_name = $self->name; unless( $mod_name ) { carp 'isa() requires $module->name to be set'; return; } my $extra_args = $self->_get_extra_arguments; my $command = qq{-e "require q{$mod_file}; print join qq{\\n}, \@$mod_name\::ISA"}; my($status, @isa) = $self->_call_perl("$extra_args $command"); chomp @isa; return @isa; } =item B my @calls = $module->subroutines_called; Finds all the methods and functions which are called inside the $module. Returns a list of hashes. Each hash represents a single function or method call and has the keys: line line number where this call originated class class called on if its a class method type function, symbolic function, object method, class method, dynamic object method or dynamic class method. (NOTE This format will probably change) name name of the function/method called if not dynamic =cut sub subroutines_called { my($self) = shift; my @subs = $self->_call_B('subs_called'); my $mod_file = $self->file; @subs = grep /at "\Q$mod_file\E" line/, @subs; my @out = (); foreach (@subs) { my %info = (); ($info{type}) = /^(.+) call/; $info{type} = 'symbolic function' if /using symbolic ref/; ($info{'name'}) = /to (\S+)/; ($info{class})= /via (\S+)/; ($info{line}) = /line (\d+)/; push @out, \%info; } return @out; } =back =head2 Information about Unpredictable Constructs Unpredictable constructs are things that make a Perl program hard to predict what its going to do without actually running it. There's nothing wrong with these constructs, but its nice to know where they are when maintaining a piece of code. =over 4 =item B my @methods = $module->dynamic_method_calls; Returns a list of dynamic method calls (ie. C<$obj->$method()>) used by the $module. @methods has the same format as the return value of subroutines_called(). =cut sub dynamic_method_calls { my($self) = shift; return grep $_->{type} =~ /dynamic/, $self->subroutines_called; } =back =head2 Options The following methods get/set specific option values for the Module::Info object. =over 4 =item B $module->die_on_compilation_error(0); # default $module->die_on_compilation_error(1); my $flag = $module->die_on_compilation_error; Sets/gets the "die on compilation error" flag. When the flag is off (default), and a module fails to compile, Module::Info simply emits a watning and continues. When the flag is on and a module fails to compile, Module::Info Cs with the same error message it would use in the warning. =cut sub die_on_compilation_error { my($self) = shift; $self->{die_on_compilation_error} = $_[0] ? 1 : 0 if @_; return $self->{die_on_compilation_error}; } =item B $module->safe(0); # default $module->safe(1); # be safer my $flag = $module->safe; Sets/gets the "safe" flag. When the flag is enabled all operations requiring module compilation are forbidden and the C method executes its code in a C compartment. =cut sub safe { my($self) = shift; if( @_ ) { $self->{safe} = $_[0] ? 1 : 0; require Safe if $self->{safe}; } return $self->{safe}; } sub AUTOLOAD { my($super) = $_[0]->safe ? 'Module::Info::Safe' : 'Module::Info::Unsafe'; my($method) = $AUTOLOAD; $method =~ s/^.*::([^:]+)$/$1/; return if $method eq 'DESTROY'; my($code) = $super->can($method); die "Can not find method '$method' in Module::Info" unless $code; goto &$code; } =item B $module->use_version(0); # do not use version.pm (default) $module->use_version(1); # use version.pm, die if not present my $flag = $module->use_version; Sets/gets the "use_version" flag. When the flag is enabled the 'version' method always returns a version object. =cut sub use_version { my($self) = shift; if( @_ ) { die "Can not use 'version.pm' as requested" if $_[0] && !$has_version_pm; $self->{use_version} = $_[0] ? 1 : 0; } return $self->{use_version}; } =back =head1 REPOSITORY L =head1 AUTHOR Michael G Schwern with code from ExtUtils::MM_Unix, Module::InstalledVersion and lots of cargo-culting from B::Deparse. Mattia Barbon maintained the module from 2002 to 2013. Neil Bowers is the current maintainer. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 THANKS Many thanks to Simon Cozens and Robin Houston for letting me chew their ears about B. =head1 CAVEATS Code refs in @INC are currently ignored. If this bothers you submit a patch. superclasses() is cheating and just loading the module in a separate process and looking at @ISA. I don't think its worth the trouble to go through and parse the opcode tree as it still requires loading the module and running all the BEGIN blocks. Patches welcome. I originally was going to call superclasses() isa() but then I remembered that would be bad. All the methods that require loading are really inefficient as they're not caching anything. I'll worry about efficiency later. =cut package Module::Info::Safe; my $root = 'Module::Info::Safe::_safe'; sub _create_compartment { my $safe = Safe->new( $root ); $safe->permit_only( qw(:base_orig :base_core) ); return $safe; } sub _eval { my($self, $code) = @_; $self->{compartment} ||= _create_compartment; return $self->{compartment}->reval( $code, 0 ) } sub _call_perl { die "Module::Info attemped an unsafe operation while in 'safe' mode."; } package Module::Info::Unsafe; sub _eval { eval($_[1]) } sub _is_win95() { return $^O eq 'MSWin32' && (Win32::GetOSVersion())[4] == 1; } sub _is_macos_classic() { return $^O eq 'MacOS'; } sub _call_perl { my($self, $args) = @_; my $perl = _is_macos_classic ? 'perl' : $^X; my $command = "$perl $args"; my @out; if( _is_win95 ) { require IPC::Open3; local *OUTFH; my($line, $in); my $out = \*OUTFH; my $pid = IPC::Open3::open3($in, $out, $out, $command); close $in; while( defined($line = ) ) { $line =~ s/\r\n$/\n/; # strip CRs push @out, $line; } waitpid $pid, 0; } elsif( _is_macos_classic ) { @out = `$command \xb7 Dev:Stdout`; } else { @out = `$command 2>&1`; } @out = grep !/^Using.*blib$/, @out; return ($?, @out); } return 'Stepping on toes is what Schwerns do best! *poing poing poing*'; Module-Info-0.39/t/n2_safe.t000644 000765 000024 00000001146 13075164217 015774 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use strict; use lib './t/lib'; use Test::More tests => 7; use lib '.'; use Module::Info; my $moo = Module::Info->new_from_module( 'Moo' ); is( $moo->version, '0.12' ); is( $moo->safe, 0 ); my $safe_moo = Module::Info->new_from_module( 'Moo' ); $safe_moo->safe(1); is( $moo->safe, 0, 'safe attribute is per-object' ); is( $safe_moo->safe, 1 ); eval { $safe_moo->version; }; isnt( $@, undef, '$Moo::VERSION is unsafe' ); my $safe_foo = Module::Info->new_from_module( 'Foo' ); $safe_foo->safe(1); eval { is( $safe_foo->version, '7.254' ); }; is( $@, '', '$Foo::VERSION is safe' ); Module-Info-0.39/t/n0_die_on_error.t000644 000765 000024 00000002056 13075164533 017524 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use strict; use lib './t/lib'; use Test::More tests => 4; use lib '.'; use Module::Info; my $baz = Module::Info->new_from_module( 'Baz' ); my $bar = Module::Info->new_from_module( 'Foo' ); SKIP: { skip "Only works on 5.6.1 and up.", 4 unless $] >= 5.006001; # Bar.pm should compile correctly $bar->die_on_compilation_error(1); eval { $bar->packages_inside; }; ok( !$@, "does not die if compilation is ok" ); diag( $@ ) if $@; { # suppress warning message local $SIG{__WARN__} = sub { }; eval { $baz->packages_inside; }; ok( !$@, "does not die unless die_on_compilation_error is set" ); diag( $@ ) if $@; } { my $did_warn; local $SIG{__WARN__} = sub { $did_warn = 1 }; $baz->die_on_compilation_error(1); eval { $baz->packages_inside; }; ok( $@, "dies if die_on_compilation_error is set" ); ok( !$did_warn, "does not warn if die_on_compilation_error is set" ); } } Module-Info-0.39/t/n1_modules_required.t000644 000765 000024 00000001213 13075164213 020414 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use strict; use lib './t/lib'; use Test::More tests => 3; use lib '.'; use Module::Info; my $bar = Module::Info->new_from_module( 'Bar' ); SKIP: { skip "Only works on 5.6.1 and up.", 3 unless $] >= 5.006001; my %mods = $bar->modules_required; delete $mods{Win32} if $^O eq 'MSWin32'; is_deeply( [ sort keys %mods ], [ sort qw(Cwd strict Carp) ], "Got the correct modules" ); is_deeply( [ sort @{$mods{Cwd}} ], [ sort qw(1 1.00102 v1.1.2) ], "Got the correct versions when specified" ); is_deeply( [], $mods{strict}, "Got no version when not specified" ); } Module-Info-0.39/t/Module-Info.t000644 000765 000024 00000030572 14663552151 016604 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use lib './t/lib'; use Test::More tests => 59; use Config; my $has_version_pm = eval 'use version; 1'; my $version_pm_VERSION = $has_version_pm ? 'version'->VERSION : 0; my $Mod_Info_VERSION = '0.39'; # 0.280 vith version.pm, 0.28 without, except for development versions my $Mod_Info_Pack_VERSION = !$has_version_pm ? '0.39' : # 0.3101 $has_version_pm && $version_pm_VERSION > '0.72' ? '0.39' : # 0.3101 '0.39'; # 0.310001 my @old5lib = defined $ENV{PERL5LIB} ? ($ENV{PERL5LIB}) : (); $ENV{PERL5LIB} = join $Config{path_sep}, 'blib/lib', @old5lib; use lib '.'; use_ok('Module::Info'); my @expected_subs = qw( new_from_file new_from_module new_from_loaded all_installed _find_all_installed name version inc_dir file is_core has_pod packages_inside package_versions modules_required modules_used _file2mod subroutines superclasses die_on_compilation_error _call_B _get_extra_arguments subroutines_called dynamic_method_calls safe AUTOLOAD use_version ); my @unsafe_subs = qw( _eval _call_perl _is_win95 _is_macos_classic ); my @safe_subs = qw( _eval _call_perl _create_compartment ); can_ok('Module::Info', @expected_subs); my $mod_info = Module::Info->new_from_file('lib/Module/Info.pm'); isa_ok($mod_info, 'Module::Info', 'new_from_file'); ok( !$mod_info->name, ' has no name' ); $mod_info->name('Module::Info'); ok( $mod_info->name, ' name set' ); is( $mod_info->version, $Mod_Info_VERSION, ' version()' ); ok( !$mod_info->inc_dir, ' has no inc_dir' ); is( $mod_info->file, File::Spec->rel2abs('lib/Module/Info.pm'), ' file()'); ok( !$mod_info->is_core, ' not a core module' ); SKIP: { skip "Only works on 5.6.1 and up.", 8 unless $] >= 5.006001; @expected_subs = ( ( map "Module::Info::$_", @expected_subs ), ( map "Module::Info::Safe::$_", @safe_subs ), ( map "Module::Info::Unsafe::$_", @unsafe_subs ) ); my @packages = $mod_info->packages_inside; is( @packages, 3, 'Found three packages inside' ); is_deeply( [sort @packages], [sort qw(Module::Info Module::Info::Safe Module::Info::Unsafe)], ' and its what we want' ); my %versions = $mod_info->package_versions; is( keys %versions, 3, '1 package with package_versions()'); is( $versions{Module::Info}, $Mod_Info_Pack_VERSION, 'version is correct'); my %subs = $mod_info->subroutines; is( keys %subs, @expected_subs, 'Found all the subroutines' ); is_deeply( [sort keys %subs], [sort @expected_subs], ' names' ); my @mods = $mod_info->modules_used; my @expected = qw(strict File::Spec Config Carp IPC::Open3 warnings Safe); push @expected, 'Exporter' if grep /^Exporter$/, @mods; # many old versions of these modules loaded the Exporter: is( @mods, @expected, 'Found all modules used' ); is_deeply( [sort @mods], [sort @expected], ' the right ones' ); } $mod_info = Module::Info->new_from_module('Module::Info'); isa_ok($mod_info, 'Module::Info', 'new_from_module'); is( $mod_info->name, 'Module::Info', ' name()' ); is( $mod_info->version, $Mod_Info_VERSION, ' version()' ); is( $mod_info->inc_dir, File::Spec->rel2abs('blib/lib'), ' inc_dir' ); is( $mod_info->file, File::Spec->rel2abs('blib/lib/Module/Info.pm'), ' file()'); ok( !$mod_info->is_core, ' not a core module' ); # Grab the core version of Class::Struct and hope it hasn't been # deleted. @core_inc = map { File::Spec->canonpath($_) } ($Config{installarchlib}, $Config{installprivlib}, $Config{archlib}, $Config{privlib}); $mod_info = Module::Info->new_from_module('Class::Struct', @core_inc); if( $mod_info ) { is( $mod_info->name, 'Class::Struct', ' name()' ); ok( grep($mod_info->inc_dir eq $_, @core_inc), ' inc_dir()' ); is( $mod_info->file, File::Spec->catfile( $mod_info->inc_dir, 'Class', 'Struct.pm' ), ' file()'); ok( $mod_info->is_core, ' core module' ); } else { $mod_info = Module::Info->new_from_module('Class::Struct'); ok( $mod_info, 'could load Class::Struct' ); ok( $mod_info, 'could load Class::Struct' ); ok( $mod_info, 'could load Class::Struct' ); ok( $mod_info, 'could load Class::Struct' ); } $mod_info = Module::Info->new_from_loaded('Module::Info'); isa_ok($mod_info, 'Module::Info', 'new_from_module'); is( $mod_info->name, 'Module::Info', ' name()' ); is( $mod_info->version, $Mod_Info_VERSION, ' version()' ); is( $mod_info->inc_dir, File::Spec->rel2abs('blib/lib'), ' inc_dir' ); is( $mod_info->file, File::Spec->rel2abs('blib/lib/Module/Info.pm'), ' file()'); ok( !$mod_info->is_core, ' not a core module' ); @modules = Module::Info->all_installed('Module::Info'); ok( @modules, 'all_installed() returned something' ); ok( !(grep { !defined $_ || !$_->isa('Module::Info') } @modules), " they're all Module::Info objects" ); # I have no idea how many I'm going to get, so I'll only play with the # first one. It's the current one. $mod_info = $modules[0]; isa_ok($mod_info, 'Module::Info', 'all_installed'); is( $mod_info->name, 'Module::Info', ' name()' ); is( $mod_info->version, $Mod_Info_VERSION, ' version()' ); ok( !$mod_info->is_core, ' not a core module' ); # Ensure that code refs in @INC are skipped. my @mods = Module::Info->all_installed('Module::Info', (@INC, sub { die })); ok( @modules, 'all_installed() returned something' ); ok( !(grep { !defined $_ || !$_->isa('Module::Info') } @modules), " they're all Module::Info objects" ); $mod_info = Module::Info->new_from_loaded('this_module_does_not_exist'); is( $mod_info, undef, 'new_from_loaded' ); SKIP: { skip "Only works on 5.6.1 and up.", 17 unless $] >= 5.006001; my $module = Module::Info->new_from_file('t/lib/Foo.pm'); my @packages = $module->packages_inside; is( @packages, 2, 'Found two packages inside' ); ok( eq_set(\@packages, [qw(Foo Bar)]), " they're right" ); my %versions = $module->package_versions; is( keys %versions, 2, '2 packages with package_versions()'); is( $versions{Foo}, '7.254', 'version is correct'); is( $versions{Bar}, undef, 'no version present'); my %subs = $module->subroutines; is( keys %subs, 2, 'Found two subroutine' ); ok( exists $subs{'Foo::wibble'}, ' its right' ); my($start, $end) = @{$subs{'Foo::wibble'}}{qw(start end)}; print "# start $start, end $end\n"; is( $start, 21, ' start line' ); is( $end, 22, ' end line' ); my @mods = $module->modules_used; is( @mods, 8, 'modules_used' ); is_deeply( [sort @mods], [sort qw(strict vars Carp Exporter t/lib/Bar.pm t/lib/NotHere.pm t/lib/Foo.pm lib)] ); $module->name('Foo'); my @isa = $module->superclasses; is( @isa, 3, 'isa' ); is_deeply( [sort @isa], [sort qw(This That What::Ever)] ); my @calls = sort { $a->{line} <=> $b->{line} } $module->subroutines_called; my $startline = 25; my @expected_calls = ({ line => $startline, class => undef, type => 'function', name => 'wibble' }, { line => $startline + 1, class => undef, type => 'symbolic function', name => undef, }, { line => $startline + 2, class => 'Foo', type => 'class method', name => 'wibble', }, { line => $startline + 3, class => undef, type => 'object method', name => 'wibble', }, { line => $startline + 5, class => undef, type => 'object method', name => 'wibble', }, { line => $startline + 7, class => 'Foo', type => 'dynamic class method', name => undef, }, { line => $startline + 8, class => undef, type => 'dynamic object method', name => undef, }, { line => $startline + 9, class => undef, type => 'dynamic object method', name => undef, }, { line => $startline + 10, class => 'Foo', type => 'dynamic class method', name => undef, }, { line => $startline + 14, class => undef, type => 'object method', name => 'wibble' }, { line => $startline + 17, class => undef, type => 'function', name => 'wibble' }, { line => $startline + 30, class => undef, type => 'function', name => 'croak' }, { line => $startline + 33, class => undef, type => 'function', name => 'wibble' }, ); is_deeply(\@calls, \@expected_calls, 'subroutines_called'); is_deeply([$module->dynamic_method_calls], [grep $_->{type} =~ /dynamic/, @expected_calls]); $module = Module::Info->new_from_file('t/lib/Bar.pm'); @mods = $module->modules_used; @mods = grep { $_ ne 'Win32' } @mods if $^O eq 'MSWin32'; is( @mods, 3, 'modules_used with complex BEGIN block' ); is_deeply( [sort @mods], [sort qw(Cwd Carp strict)] ); } Module-Info-0.39/t/zy_pod_coverage.t000644 000765 000024 00000000600 13075164230 017623 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; plan( tests => 1 ); pod_coverage_ok( 'Module::Info' ); Module-Info-0.39/t/zz_pod.t000644 000765 000024 00000000270 12537635142 015763 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use strict; 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( all_pod_files( '.' ) ); Module-Info-0.39/t/lib/000755 000765 000024 00000000000 14663552275 015047 5ustar00neilbstaff000000 000000 Module-Info-0.39/t/n3_version.t000644 000765 000024 00000002671 13075164224 016546 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w use strict; use lib './t/lib'; use Test::More tests => 15; use lib '.'; use Module::Info; my $has_version_pm = eval 'use version; 1'; my $moo = Module::Info->new_from_module( 'Moo' ); my $boo = Module::Info->new_from_module( 'Boo' ); my $roo = Module::Info->new_from_module( 'Roo' ); my $moo_ver; my $foo_ver; my $roo_ver; if( $has_version_pm ) { $moo_ver = Module::Info->new_from_module( 'Moo' ); $foo_ver = Module::Info->new_from_module( 'Foo' ); $moo_ver->use_version( 1 ); $foo_ver->use_version( 1 ); } is( $moo->use_version, 0 ); is( $moo->version, '0.12' ); is( $boo->version, '1.35', 'proper quoting in complex expression' ); is( $roo->version, '1.25', 'package NAME VERSION' ); SKIP: { skip 'version.pm not found', 5 unless $has_version_pm; is( $moo_ver->use_version, 1 ); isa_ok( $moo_ver->version, 'version' ); is( $moo_ver->version, '0.120' ); isa_ok( $foo_ver->version, 'version' ); is( $foo_ver->version, '7.254' ); } SKIP: { skip 'version.pm found, can not test', 6 if $has_version_pm; my $dummy = Module::Info->new_from_module( 'Moo' ); is( $dummy->use_version, 0 ); # should succeed eval { $dummy->use_version( 0 ); }; ok( !$@ ); is( $dummy->use_version, 0 ); # should fail eval { $dummy->use_version( 1 ); }; ok( $@ ); ok( $@ =~ /^Can not use 'version.pm' as requested/ ); is( $dummy->use_version, 0 ); } Module-Info-0.39/t/lib/Test/000755 000765 000024 00000000000 14663552275 015766 5ustar00neilbstaff000000 000000 Module-Info-0.39/t/lib/Baz.pm000644 000765 000024 00000000130 12537635142 016104 0ustar00neilbstaff000000 000000 package Baz; print "Hello", "World" # the syntax error is intentional! print "\n"; 1; Module-Info-0.39/t/lib/Boo.pm000644 000765 000024 00000000172 12537635142 016115 0ustar00neilbstaff000000 000000 package Boo; use strict; use vars qw($VERSION); $VERSION = sprintf("%d.%02d", q$Revision: 1.35$ =~ /(\d+)\.(\d+)/); 1; Module-Info-0.39/t/lib/Moo.pm000644 000765 000024 00000000221 12615427047 016123 0ustar00neilbstaff000000 000000 package Moo; # potentially unsafe version assignment line use vars; $VERSION = '0.12'; =head1 NAME Moo - Hacking bovines's favorite =cut 1; Module-Info-0.39/t/lib/Bar.pm000644 000765 000024 00000000321 12537635142 016076 0ustar00neilbstaff000000 000000 package Bar; use Cwd; use Cwd 1; use Cwd 1.00102; use Cwd 1.1.2; BEGIN { cwd(); } BEGIN { $x = 1; $x = 2; require strict; } sub my_croak { require Carp; Carp::croak(cwd, @_); } 1; Module-Info-0.39/t/lib/Roo.pm000644 000765 000024 00000000026 12537635142 016133 0ustar00neilbstaff000000 000000 package Roo 1.25; 1; Module-Info-0.39/t/lib/Foo.pm000644 000765 000024 00000002111 12537635142 016114 0ustar00neilbstaff000000 000000 package Foo; use strict; require Exporter; require "t/lib/Foo.pm"; use vars qw(@ISA $VERSION); $VERSION = 7.254; @ISA = qw(This That What::Ever); my $foo = 42; { package Bar; my $bar = 23; } sub wibble { package Wibble; $foo = 42; return 66; } wibble('this is the function call'); { no strict 'refs'; &{'wibble'}('this is a symref function call'); } Foo->wibble(42); { local @ARGV = (bless {}); shift->wibble(42); } my $obj = bless {}; $obj->wibble('bar'); my $method = 'wibble'; Foo->$method; $obj->$method; $obj->$method('bar'); Foo->$method('bar'); { no strict 'subs'; $Foo::obj = bless {}; $Foo::obj->wibble(main::STDOUT); } my $_private = sub { wibble('call inside anonymous subroutine'); }; require 5.004; use 5.004; require 5; use 5; use lib qw(blahbityblahblah); eval "require Text::Soundex"; sub croak { require Carp; Carp::croak(@_); return sub { main::wibble('call insde anon sub inside sub'); require 't/lib/NotHere.pm'; } } BEGIN { require 't/lib/Bar.pm'; } my $mod = 't/lib/Bar.pm'; require $mod; Module-Info-0.39/t/lib/Test/More.pm000644 000765 000024 00000074500 14663546760 017236 0ustar00neilbstaff000000 000000 package Test::More; use 5.004; use strict; use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.45'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag ); my $Test = Test::Builder->new; # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($this, qr/that/, $test_name); unlike($this, qr/that/, $test_name); cmp_ok($this, '==', $that, $test_name); is_deeply($complex_structure1, $complex_structure2, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; goto &plan; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut sub ok ($;$) { my($test, $name) = @_; $Test->ok($test, $name); } =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 1 (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } # *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { $Test->like(@_); } =item B unlike( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike { $Test->unlike(@_); } =item B cmp_ok( $this, $op, $that, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $this eq $that ); cmp_ok( $this, 'eq', $that, 'this eq that' ); # ok( $this == $that ); cmp_ok( $this, '==', $that, 'this == that' ); # ok( $this && $that ); cmp_ok( $this, '&&', $that, 'this || that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 # Failed test (foo.t at line 12) # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); $Test->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $Test->ok( !@nok, $name ); $Test->diag(map " $class->can('$_') failed\n", @nok); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $Test->ok( 0, $name ); $Test->diag(" $diag\n"); } else { $ok = $Test->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { $Test->ok(1, @_); } sub fail (;$) { $Test->ok(0, @_); } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test (foo.t at line 52) # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { $Test->diag(@_); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; local($@,$!); # eval sometimes interferes with $! eval <import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $Test->diag(< require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; local($!, $@); # eval sometimes interferes with $! eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; ok( $lint, "Created object" ); $lint->parse( $html ); is( scalar $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->skip($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->todo_skip($why); } local $^W = 0; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Comparison functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B is_deeply( $this, $that, $test_name ); Similar to is(), except that if $this and $that are hash or array references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. Barrie Slaymaker's Test::Differences module provides more in-depth functionality along these lines, and it plays well with Test::More. B Display of scalar refs is not quite 100% =cut use vars qw(@Data_Stack); my $DNE = bless [], 'Does::Not::Exist'; sub is_deeply { my($this, $that, $name) = @_; my $ok; if( !ref $this || !ref $that ) { $ok = $Test->is_eq($this, $that, $name); } else { local @Data_Stack = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); $ok = $Test->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); } else { push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =cut sub builder { return Test::Builder->new; } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. Test::More is thread-safe for perl 5.8.0 and up. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() If you are trying to extend Test::More, don't. Use Test::Builder instead. =item The eq_* family has some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. And it plays well with Test::More. L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, chromatic and the perl-qa gang. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Module-Info-0.39/t/lib/Test/Builder.pm000644 000765 000024 00000065177 12537635142 017723 0ustar00neilbstaff000000 000000 package Test::Builder; use 5.004; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use vars qw($VERSION $CLASS); $VERSION = '0.15'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; use vars qw($Level); my @Test_Results = (); my @Test_Details = (); my($Test_Died) = 0; my($Have_Plan) = 0; my $Curr_Test = 0; # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads; require threads::shared; threads::shared->import; share(\$Curr_Test); share(\@Test_Details); share(\@Test_Results); } else { *lock = sub { 0 }; } } =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program, there is B Test::Builder object. No matter how many times you call new(), you're getting the same object. (This is called a singleton). =cut my $Test; sub new { my($class) = shift; $Test ||= bless ['Move along, nothing to see here'], $class; return $Test; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut my $Exported_To; sub exported_to { my($self, $pack) = @_; if( defined $pack ) { $Exported_To = $pack; } return $Exported_To; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my($self, $cmd, $arg) = @_; return unless $cmd; if( $Have_Plan ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } if( $cmd eq 'no_plan' ) { $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { if( $arg ) { return $self->expected_tests($arg); } elsif( !defined $arg ) { die "Got an undefined number of tests. Looks like you tried to ". "say how many tests you plan to run but made a mistake.\n"; } elsif( !$arg ) { die "You said to run 0 tests! You've got to run something.\n"; } } else { require Carp; my @args = grep { defined } ($cmd, $arg); Carp::croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut my $Expected_Tests = 0; sub expected_tests { my($self, $max) = @_; if( defined $max ) { $Expected_Tests = $max; $Have_Plan = 1; $self->_print("1..$max\n") unless $self->no_header; } return $Expected_Tests; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut my($No_Plan) = 0; sub no_plan { $No_Plan = 1; $Have_Plan = 1; } =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $Skip_All = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my($self, $test, $name) = @_; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } lock $Curr_Test; $Curr_Test++; $self->diag(<caller; my $todo = $self->todo($pack); my $out; unless( $test ) { $out .= "not "; $Test_Results[$Curr_Test-1] = $todo ? 1 : 0; } else { $Test_Results[$Curr_Test-1] = 1; } $out .= "ok"; $out .= " $Curr_Test" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; } if( $todo ) { my $what_todo = $todo; $out .= " # TODO $what_todo"; } $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->diag(" $msg test ($file at line $line)\n"); } return $test ? 1 : 0; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, 'eq', $expect) unless $test; return $test; } return $self->cmp_ok($got, 'eq', $expect, $name); } sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, '==', $expect) unless $test; return $test; } return $self->cmp_ok($got, '==', $expect, $name); } sub _is_diag { my($self, $got, $type, $expect) = @_; foreach my $val (\$got, \$expect) { if( defined $$val ) { if( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'" } else { # force numeric context $$val = $$val+0; } } else { $$val = 'undef'; } } return $self->diag(sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->is_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('ne', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, 'ne', $dont_expect, $name); } sub isnt_num { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('!=', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, '!=', $dont_expect, $name); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '=~', $name); } sub unlike { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '!~', $name); } =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ($self, $regex) = @_; my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; }; return($usable_regex) }; sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; local $Level = $Level + 1; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { local $^W = 0; my $test = $this =~ /$usable_regex/ ? 1 : 0; $test = !$test if $cmp eq '!~'; $ok = $self->ok( $test, $name ); } unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag(sprintf < $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; my $test; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { $self->_is_diag($got, $type, $expect); } else { $self->_cmp_diag($got, $type, $expect); } } return $ok; } sub _cmp_diag { my($self, $got, $type, $expect) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag(sprintf < $Test->BAILOUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAILOUT { my($self, $reason) = @_; $self->_print("Bail out! $reason"); exit 255; } =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; $Test_Results[$Curr_Test-1] = 1; my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # skip $why\n"; $Test->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; $Test_Results[$Curr_Test-1] = 1; my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $Test->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting $Test::Builder::Level overrides. This is typically useful localized: { local $Test::Builder::Level = 2; $Test->ok($test); } =cut sub level { my($self, $level) = @_; if( defined $level ) { $Level = $level; } return $Level; } $CLASS->level(1); =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Test::Harness will accept either, but avoid mixing the two styles. Defaults to on. =cut my $Use_Nums = 1; sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { $Use_Nums = $use_nums; } return $Use_Nums; } =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described in Test::Simple. If this is true, none of that will be done. =cut my($No_Header, $No_Ending) = (0,0); sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { $No_Header = $no_header; } return $No_Header; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { $No_Ending = $no_ending; } return $No_Ending; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given $message. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; s/^/# /gms; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; local $Level = $Level + 1; my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my($self, @msgs) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. foreach (@msgs) { s/\n(.)/\n# $1/sg; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; print $fh @msgs; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { $Out_FH = _new_fh($fh); } return $Out_FH; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { $Fail_FH = _new_fh($fh); } return $Fail_FH; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { $Todo_FH = _new_fh($fh); } return $Todo_FH; } sub _new_fh { my($file_or_fh) = shift; my $fh; unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } else { $fh = $file_or_fh; } return $fh; } unless( $^C ) { # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush(\*TESTOUT); _autoflush(\*STDOUT); _autoflush(\*TESTERR); _autoflush(\*STDERR); $CLASS->output(\*TESTOUT); $CLASS->failure_output(\*TESTERR); $CLASS->todo_output(\*TESTOUT); } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test # we're on. You usually shouldn't have to set this. =cut sub current_test { my($self, $num) = @_; lock($Curr_Test); if( defined $num ) { unless( $Have_Plan ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } $Curr_Test = $num; if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results : 0; for ($start..$num-1) { $Test_Results[$_] = 1; } } } return $Curr_Test; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my($self) = shift; return @Test_Results; } =item B
I my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { ok => is the test considered ok? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => 'skip' or 'todo' (if any) reason => reason for the above (if any) }; =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is pretty part about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my($self, $pack) = @_; $pack = $pack || $self->exported_to || $self->caller(1); no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my($self, $height) = @_; $height ||= 0; my @caller = CORE::caller($self->level + $height + 1); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Curr_Test, 'Somehow your tests ran without a plan!'); _whoa($Curr_Test != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; sub _ending { my $self = shift; _sanity_check(); # Bailout if plan() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan; # Figure out if we passed or failed and print helpful messages. if( @Test_Results ) { # The plan? We have no plan. if( $No_Plan ) { $self->_print("1..$Curr_Test\n") unless $self->no_header; $Expected_Tests = $Curr_Test; } # 5.8.0 threads bug. Shared arrays will not be auto-extended # by a slice. $Test_Results[$Expected_Tests-1] = undef unless defined $Test_Results[$Expected_Tests-1]; my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1]; $num_failed += abs($Expected_Tests - @Test_Results); if( $Curr_Test < $Expected_Tests ) { $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but only ran $Curr_Test. FAIL } elsif( $Curr_Test > $Expected_Tests ) { my $num_extra = $Curr_Test - $Expected_Tests; $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { $self->diag(<<"FAIL"); Looks like you failed $num_failed tests of $Expected_Tests. FAIL } if( $Test_Died ) { $self->diag(<<"FAIL"); Looks like your test died just after $Curr_Test. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Skip_All ) { _my_exit( 0 ) && return; } else { $self->diag("No tests run!\n"); _my_exit( 255 ) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 THREADS In perl 5.8.0 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2001 by chromatic Echromatic@wgz.orgE, Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Module-Info-0.39/t/lib/Test/Simple.pm000644 000765 000024 00000014565 12537635142 017561 0ustar00neilbstaff000000 000000 package Test::Simple; use 5.004; use strict 'vars'; use vars qw($VERSION); $VERSION = '0.45'; use Test::Builder; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; *{$caller.'::ok'} = \&ok; $Test->exported_to($caller); $Test->plan(@_); } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $Test->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Module-Info-0.39/bin/pfunc000644 000765 000024 00000004207 12537635142 015640 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w =head1 NAME pfunc - grep for perl functions =head1 SYNOPSIS pfunc subroutine FILES... =head1 DESCRIPTION B searches the named FILES for all calls to the given subroutine. It will report back the file and line number each call is found on along with what sort of call it is function foo() class method Class->foo() object method $obj->foo() =head1 EXAMPLE $ pfunc isa /usr/share/perl/5.6.1/*.pm Called as function in /usr/share/perl/5.6.1/CGI.pm at line 316 Called as function in /usr/share/perl/5.6.1/CGI.pm at line 327 Called as function in /usr/share/perl/5.6.1/CGI.pm at line 397 Called as function in /usr/share/perl/5.6.1/CGI.pm at line 494 Called as function in /usr/share/perl/5.6.1/CGI.pm at line 495 Called as object method in /usr/share/perl/5.6.1/CPAN.pm at line 4957 Called as function in /usr/share/perl/5.6.1/Dumpvalue.pm at line 191 Called as function in /usr/share/perl/5.6.1/Dumpvalue.pm at line 218 Called as function in /usr/share/perl/5.6.1/Dumpvalue.pm at line 248 Called as function in /usr/share/perl/5.6.1/Dumpvalue.pm at line 251 Called as function in /usr/share/perl/5.6.1/Dumpvalue.pm at line 254 Called as object method in /usr/share/perl/5.6.1/Shell.pm at line 28 Called as object method in /usr/share/perl/5.6.1/base.pm at line 12 =head1 NOTES Its not fast, but its accurate. =head1 AUTHOR Michael G Schwern =head1 SEE ALSO L =cut $| = 1; use Module::Info; my $func = shift; foreach my $file (@ARGV) { my $mod = Module::Info->new_from_file($file); unless( $mod ) { warn "Can't find $file\n"; next; } my @calls = sort { $a->{line} <=> $b->{line} } grep { defined $_->{name} and $_->{name} eq $func } $mod->subroutines_called; foreach my $call (@calls) { my $as = $call->{type} =~ /class method/ ? "$call->{type} via $call->{class}" : $call->{type}; printf "Called as %s in %s at line %d\n", $as, $file, $call->{line} } } Module-Info-0.39/bin/module_info000644 000765 000024 00000011314 12537635142 017022 0ustar00neilbstaff000000 000000 #!/usr/bin/perl -w =head1 NAME module_info - find information about modules =head1 SYNOPSIS module_info [B<-a>] [B<-s>] [B<-p>] [B<-m>] MODULE|FILE... =head1 DESCRIPTION List information about the arguments (either module names in the form C or paths in the form C or C). By default only shows module name, version, directory, absolute path and a flag indicating if it is a core module. Additional information can be requested through command line switches. =over 4 =item B<-s> Show subroutines created by the module. =item B<-p> Show packages created by the module. =item B<-m> Show modules Cd by the module. =item B<-a> Equivalent to C<-s -p -m>. =back =head1 AUTHOR Mattia Barbon =head1 SEE ALSO L =cut use strict; use Module::Info; use Getopt::Long; my( $show_subroutines, $show_modules, $show_packages, $show_all, $help ); GetOptions( 's' => \$show_subroutines, 'p' => \$show_packages, 'm' => \$show_modules, 'a' => \$show_all, 'h' => \$help, ); if( $help || !@ARGV ) { print <new_from_file($module); } else { $info = Module::Info->new_from_module($module); } unless( $info ) { warn "Can't create Module::Info object for module '$module'"; $some_error = 1; next; } $info->die_on_compilation_error(1); my $name = $info->name || $module; my $version = $info->version || '(unknown)'; my $dir = $info->inc_dir; my $file = $info->file; my $is_core = $info->is_core ? "yes" : "no"; print <modules_used if $show_modules; %packages_created = $info->package_versions if $show_packages; %subroutines = $info->subroutines if $show_subroutines; }; if( $@ ) { warn "Compilation failed for module '$module'"; $some_error = 1; next; } ########################################################################### # Modules used ########################################################################### if( $show_modules ) { print "\nModules used:\n"; foreach my $m (sort @modules_used) { print " $m\n"; } print " (none)\n" unless @modules_used; } ########################################################################### # Packages defined ########################################################################### if( $show_packages ) { print "\nPackages created:\n"; foreach my $p (sort keys %packages_created) { print " $p\t"; print +( defined( $packages_created{$p} ) ? $packages_created{$p} : '(no version)' ); print "\n"; } print " (none)\n" unless keys %packages_created; } ########################################################################### # Subroutines ########################################################################### if( $show_subroutines ) { print "\nSubroutines defined:\n"; { my @subroutines = sort { ( $a->[0] cmp $b->[0] ) || ( $a->[1] cmp $b->[1] ) } map { my($package, $subname) = ($_ =~ m/^(.*)?::(\w+)$/); warn "Strange subroutine '$_'" unless $package || $subname; $package ||= '(unknown)'; $subname ||= '(unknown)'; [ $package, $subname ]; } keys %subroutines; my $prev_package = ':'; # impossible foreach my $s (@subroutines) { my($package, $subname) = @$s; if($prev_package ne $package) { $prev_package = $package; print " $package\n"; } print " $subname\n"; } } print " (none)\n" unless %subroutines; } } exit $some_error;