@@ -1,5 +1,18 @@
Revision history for Devel-TraceUse
+2.092 Thu Apr 3 2014
+ - auto-dereferencing only works since 5.14
+ - move the xt/ tests back in t/, guarded by RELEASE_TESTING
+
+2.091 Sat Mar 29 2014
+ - documentation fixes (thanks to Ioan Rogers (IOANR))
+ - test fixes (related to Module::CoreList)
+
+2.09 Sat Feb 16 2013
+ - added a proxy-reporting feature, that lists modules/subroutines
+ found to load other modules --but no change to the tree output yet--
+ (thanks to Olivier Mengué (DOLMEN))
+
2.08 Thu Sep 13 2012
- fixed the module's encoding to match the =encoding POD directive
@@ -23,6 +23,6 @@ t/lib2/M12.pm
t/lib2/M8.pm
t/numify.t
t/traceuse.t
-xt/pod-coverage.t
-xt/pod.t
+t/pod-coverage.t
+t/pod.t
META.json
@@ -4,7 +4,7 @@
"Philippe Bruhat (BooK) <book@cpan.org>"
],
"dynamic_config" : 1,
- "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.112621",
+ "generated_by" : "Module::Build version 0.4204",
"license" : [
"perl_5"
],
@@ -21,21 +21,15 @@
"prereqs" : {
"build" : {
"requires" : {
- "Test::More" : 0
+ "Test::More" : "0"
}
},
"configure" : {
"requires" : {
- "Module::Build" : "0.38"
+ "Module::Build" : "0.42"
}
}
},
- "provides" : {
- "Devel::TraceUse" : {
- "file" : "lib/Devel/TraceUse.pm",
- "version" : "2.08"
- }
- },
"release_status" : "stable",
"resources" : {
"license" : [
@@ -45,5 +39,5 @@
"url" : "http://github.com/book/Devel-TraceUse"
}
},
- "version" : "2.08"
+ "version" : "2.092"
}
@@ -5,9 +5,9 @@ author:
build_requires:
Test::More: 0
configure_requires:
- Module::Build: 0.38
+ Module::Build: 0.42
dynamic_config: 1
-generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.112621'
+generated_by: 'Module::Build version 0.4204, CPAN::Meta::Converter version 2.133380'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -16,11 +16,7 @@ name: Devel-TraceUse
no_index:
package:
- Foo::Bar
-provides:
- Devel::TraceUse:
- file: lib/Devel/TraceUse.pm
- version: 2.08
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/book/Devel-TraceUse
-version: 2.08
+version: 2.092
@@ -6,45 +6,46 @@ sub DB {}
package Devel::TraceUse;
-our $VERSION = '2.08';
+our $VERSION = '2.092';
BEGIN
{
- unshift @INC, \&trace_use unless grep { "$_" eq \&trace_use . '' } @INC;
+ unshift @INC, \&trace_use unless grep { "$_" eq \&trace_use . '' } @INC;
}
# initialize the tree of require calls
my $root = (caller)[1];
-my %used;
-my %loaded;
-my %reported;
-my $rank = 0;
-my $quiet = 1;
-my $output_fh;
+my %used; # track loaded modules by "filename" (parameter to require)
+my %loaded; # track "filename"s loaded by "filepath" (value from %INC)
+my %reported; # track reported "filename"
+my %loader; # track potential proxy modules
+my $rank = 0; # record the loading order of modules
+my $quiet = 1; # no output until decided otherwise
+my $output_fh; # optional write filehandle where results will be output
# Hide core modules (for the specified version)?
my $hide_core = 0;
sub import {
- my $class = shift;
-
- # ensure "use Devel::TraceUse ();" will produce no output
- $quiet = 0;
-
- # process options
- for(@_) {
- if(/^hidecore(?::(.*))?/) {
- $hide_core = numify( $1 ? $1 : $] );
- } elsif (/^output:(.*)$/) {
- open $output_fh, '>', $1 or die "can't open $1: $!";
- } else {
- die "Unknown argument to $class: $_\n";
- }
- }
+ my $class = shift;
+
+ # ensure "use Devel::TraceUse ();" will produce no output
+ $quiet = 0;
+
+ # process options
+ for(@_) {
+ if(/^hidecore(?::(.*))?/) {
+ $hide_core = numify( $1 ? $1 : $] );
+ } elsif (/^output:(.*)$/) {
+ open $output_fh, '>', $1 or die "can't open $1: $!";
+ } else {
+ die "Unknown argument to $class: $_\n";
+ }
+ }
}
my @caller_info = qw( package filepath line subroutine hasargs
- wantarray evaltext is_require hints bitmask hinthash );
+ wantarray evaltext is_require hints bitmask hinthash );
# Keys used in the data structure:
# - filename: parameter given to use/require
@@ -57,166 +58,199 @@ my @caller_info = qw( package filepath line subroutine hasargs
sub trace_use
{
- my ( $code, $filename ) = @_;
-
- # ensure our hook remains first in @INC
- @INC = ( $code, grep { $_ ne $code } @INC )
- if $INC[0] ne $code;
-
- # $filename may be an actual filename, e.g. with do()
- # try to compute a module name from it
- my $module = $filename;
- $module =~ s{/}{::}g
- if $module =~ s/\.pm$//;
-
- # info about the module being loaded
- push @{ $used{$filename} }, my $info = {
- filename => $filename,
- module => $module,
- rank => ++$rank,
- eval => '',
- };
-
- # info about the loading module
- my $caller = $info->{caller} = {};
- @{$caller}{@caller_info} = caller(0);
-
- # try to compute a "filename" (as received by require)
- $caller->{filestring} = $caller->{filename} = $caller->{filepath};
-
- # some values seen in the wild:
- # - "(eval $num)[$path:$line]" (debugger)
- # - "$filename (autosplit into $path)" (AutoLoader)
- if ( $caller->{filename} =~ /^(\(eval \d+\))(?:\[(.*):(\d+)\])?$/ ) {
- $info->{eval} = $1;
- $caller->{filename} = $caller->{filepath} = $2;
- $caller->{line} = $3;
- }
-
- # clean up path
- $caller->{filename}
- =~ s{^(?:@{[ join '|', map quotemeta, reverse sort @INC]})/?}{};
-
- # try to compute the package associated with the file
- $caller->{filepackage} = $caller->{filename};
- $caller->{filepackage} =~ s/\.(pm|al)\s.*$/.$1/;
- $caller->{filepackage} =~ s{/}{::}g
- if $caller->{filepackage} =~ s/\.pm$//;
-
- # record who tried to load us
- push @{ $loaded{ $caller->{filepath} } }, $info->{filename};
-
- # let Perl ultimately find the required file
- return;
+ my ( $code, $filename ) = @_;
+
+ # ensure our hook remains first in @INC
+ @INC = ( $code, grep { $_ ne $code } @INC )
+ if $INC[0] ne $code;
+
+ # $filename may be an actual filename, e.g. with do()
+ # try to compute a module name from it
+ my $module = $filename;
+ $module =~ s{/}{::}g
+ if $module =~ s/\.pm$//;
+
+ # info about the module being loaded
+ push @{ $used{$filename} }, my $info = {
+ filename => $filename,
+ module => $module,
+ rank => ++$rank,
+ eval => '',
+ };
+
+ # info about the loading module
+ my $caller = $info->{caller} = {};
+ @{$caller}{@caller_info} = caller(0);
+
+ # try to compute a "filename" (as received by require)
+ $caller->{filestring} = $caller->{filename} = $caller->{filepath};
+
+ # some values seen in the wild:
+ # - "(eval $num)[$path:$line]" (debugger)
+ # - "$filename (autosplit into $path)" (AutoLoader)
+ if ( $caller->{filename} =~ /^(\(eval \d+\))(?:\[(.*):(\d+)\])?$/ ) {
+ $info->{eval} = $1;
+ $caller->{filename} = $caller->{filepath} = $2;
+ $caller->{line} = $3;
+ }
+
+ # clean up path
+ $caller->{filename}
+ =~ s!^(?:@{[ join '|', map quotemeta, reverse sort @INC ]})/?!!;
+
+ # try to compute the package associated with the file
+ $caller->{filepackage} = $caller->{filename};
+ $caller->{filepackage} =~ s/\.(pm|al)\s.*$/.$1/;
+ $caller->{filepackage} =~ s{/}{::}g
+ if $caller->{filepackage} =~ s/\.pm$//;
+
+ # record who tried to load us
+ push @{ $loaded{ $caller->{filepath} } }, $info->{filename};
+
+ # record potential proxies
+ if ( $caller->{filename} ) {
+ my($subroutine, $level);
+ while ( $subroutine = ( caller ++$level )[3] || '' ) {
+ last if $subroutine =~ /::/;
+ }
+ $loader{ join "\0", @{$caller}{qw( filename line )}, $subroutine }++;
+ }
+
+ # let Perl ultimately find the required file
+ return;
}
sub show_trace_visitor
{
- my ( $mod, $pos, $output_cb, @args ) = @_;
-
- my $caller = $mod->{caller};
- my $message = sprintf( '%4s.', $mod->{rank} ) . ' ' x $pos;
- $message .= "$mod->{module}";
- my $version = ${"$mod->{module}\::VERSION"};
- $message .= defined $version ? " $version," : ',';
- $message .= " $caller->{filename}"
- if defined $caller->{filename};
- $message .= " line $caller->{line}"
- if defined $caller->{line};
- $message .= " $mod->{eval}"
- if $mod->{eval};
- $message .= " [$caller->{package}]"
- if $caller->{package} ne $caller->{filepackage};
- $message .= " (FAILED)"
- if !exists $INC{$mod->{filename}};
-
- $output_cb->($message, @args);
+ my ( $mod, $pos, $output_cb, @args ) = @_;
+
+ my $caller = $mod->{caller};
+ my $message = sprintf( '%4s.', $mod->{rank} ) . ' ' x $pos;
+ $message .= "$mod->{module}";
+ my $version = ${"$mod->{module}\::VERSION"};
+ $message .= defined $version ? " $version," : ',';
+ $message .= " $caller->{filename}"
+ if defined $caller->{filename};
+ $message .= " line $caller->{line}"
+ if defined $caller->{line};
+ $message .= " $mod->{eval}"
+ if $mod->{eval};
+ $message .= " [$caller->{package}]"
+ if $caller->{package} ne $caller->{filepackage};
+ $message .= " (FAILED)"
+ if !exists $INC{$mod->{filename}};
+
+ $output_cb->($message, @args);
}
sub visit_trace
{
- my ( $visitor, $mod, $pos, @args ) = @_;
+ my ( $visitor, $mod, $pos, @args ) = @_;
- my $hide = 0;
+ my $hide = 0;
- if ( ref $mod ) {
- $mod = shift @$mod;
+ if ( ref $mod ) {
+ $mod = shift @$mod;
- if($hide_core) {
- $hide = exists $Module::CoreList::version{$hide_core}{$mod->{module}};
- }
+ if($hide_core) {
+ $hide = exists $Module::CoreList::version{$hide_core}{$mod->{module}};
+ }
- $visitor->( $mod, $pos, @args ) unless $hide;
+ $visitor->( $mod, $pos, @args ) unless $hide;
- $reported{$mod->{filename}}++;
- }
- else {
- $mod = { loaded => delete $loaded{$mod} };
- }
+ $reported{$mod->{filename}}++;
+ }
+ else {
+ $mod = { loaded => delete $loaded{$mod} };
+ }
- visit_trace( $visitor, $used{$_}, $hide ? $pos : $pos + 1, @args )
- for map { $INC{$_} || $_ } @{ $mod->{loaded} };
+ visit_trace( $visitor, $used{$_}, $hide ? $pos : $pos + 1, @args )
+ for map { $INC{$_} || $_ } @{ $mod->{loaded} };
}
# we don't want to use version.pm on old Perls
sub numify {
- my ($version) = @_;
- $version =~ y/_//d;
- my @parts = split /\./, $version;
+ my ($version) = @_;
+ $version =~ y/_//d;
+ my @parts = split /\./, $version;
- # %Module::CoreList::version's keys are x.yyyzzz *numbers*
- return 0+ ((shift @parts).'.'.join('', map { (length) < 3 ? (sprintf "%03d", $_) : $_ } @parts));
+ # %Module::CoreList::version's keys are x.yyyzzz *numbers*
+ return 0+ join '', shift @parts, '.', map sprintf( '%03s', $_ ), @parts;
+}
+
+sub dump_proxies
+{
+ my $output = shift;
+
+ my @hot_loaders =
+ sort { $loader{$b} <=> $loader{$a} }
+ grep { $loader{$_} > 1 }
+ keys %loader;
+
+ return unless @hot_loaders;
+
+ $output->("Possible proxies:");
+
+ for my $loader (@hot_loaders) {
+ my ( $filename, $line, $subroutine ) = split /\0/, $loader;
+ $output->(sprintf("%4d %s line %d%s",
+ $loader{$loader},
+ $filename, $line,
+ (defined($subroutine) ? ", sub $subroutine" : '')));
+ }
}
sub dump_result
{
- return if $quiet;
+ return if $quiet;
- # map "filename" to "filepath" for everything that was loaded
- while ( my ( $filename, $filepath ) = each %INC ) {
- if ( exists $used{$filename} ) {
- $used{$filename}[0]{loaded} = delete $loaded{$filepath} || [];
- $used{$filepath} = delete $used{$filename};
- }
- }
+ # map "filename" to "filepath" for everything that was loaded
+ while ( my ( $filename, $filepath ) = each %INC ) {
+ if ( exists $used{$filename} ) {
+ $used{$filename}[0]{loaded} = delete $loaded{$filepath} || [];
+ $used{$filepath} = delete $used{$filename};
+ }
+ }
# let people know more accurate information is available
warn "Use -d:TraceUse for more accurate information.\n" if !$^P;
- # load Module::CoreList if needed
- if ($hide_core) {
- local @INC = grep { $_ ne \&trace_use } @INC;
- local %INC = %INC; # don't report it loaded
- require Module::CoreList;
- warn sprintf "Module::CoreList %s doesn't know about Perl %s\n",
- $Module::CoreList::VERSION, $hide_core
- if !exists $Module::CoreList::version{$hide_core};
- }
-
- my $output = defined $output_fh
- ? sub { print $output_fh "$_[0]\n" }
- : sub { warn "$_[0]\n" };
-
- # output the diagnostic
- $output->("Modules used from $root:");
- visit_trace( \&show_trace_visitor, $root, 0, $output );
-
- # anything left?
- if (%loaded) {
- visit_trace( \&show_trace_visitor, $_, 0, $output ) for sort keys %loaded;
- }
-
- # did we miss some modules?
- if (my @missed
- = sort grep { !exists $reported{$_} && $_ ne 'Devel/TraceUse.pm' }
- keys %INC
- )
- {
- $output->("Modules used, but not reported:") if @missed;
- $output->(" $_") for @missed;
- }
-
- close $output_fh if defined $output_fh;
+ # load Module::CoreList if needed
+ if ($hide_core) {
+ local @INC = grep { $_ ne \&trace_use } @INC;
+ local %INC = %INC; # don't report it loaded
+ require Module::CoreList;
+ warn sprintf "Module::CoreList %s doesn't know about Perl %s\n",
+ $Module::CoreList::VERSION, $hide_core
+ if !exists $Module::CoreList::version{$hide_core};
+ }
+
+ my $output = defined $output_fh
+ ? sub { print $output_fh "$_[0]\n" }
+ : sub { warn "$_[0]\n" };
+
+ # output the diagnostic
+ $output->("Modules used from $root:");
+ visit_trace( \&show_trace_visitor, $root, 0, $output );
+
+ # anything left?
+ if (%loaded) {
+ visit_trace( \&show_trace_visitor, $_, 0, $output ) for sort keys %loaded;
+ }
+
+ # did we miss some modules?
+ if (my @missed
+ = sort grep { !exists $reported{$_} && $_ ne 'Devel/TraceUse.pm' }
+ keys %INC
+ )
+ {
+ $output->("Modules used, but not reported:") if @missed;
+ $output->(" $_") for @missed;
+ }
+
+ dump_proxies($output);
+
+ close $output_fh if defined $output_fh;
}
# Install the final hook
@@ -274,6 +308,21 @@ under the modules that tried to load them.
In the very rare case when C<Devel::TraceUse> is not able to attach
a loaded module to the tree, it will be reported at the end.
+If a particular line of code is used at least 2 times to load modules,
+it is considered as part of a "module loading proxy subroutine", or just "proxy".
+C<L<base>::import>, C<L<parent>::import>,
+C<L<Module::Runtime>::require_module> are such subroutines, among others.
+If proxies are found, the list is reported like this:
+
+ <occurences> <filename> line <line>[, sub <subname>]
+
+Example:
+
+ Possible proxies:
+ 59 Module/Runtime.pm, line 317, sub require_module
+ 13 base.pm line 90, sub import
+ 3 Module/Pluggable/Object.pm line 311, sub _require
+
Even though using C<-MDevel::TraceUse> is possible, it is preferable to
use C<-d:TraceUse>, as the debugger will provide more accurate information.
You will be reminded in the output.
@@ -312,7 +361,7 @@ and C<5.5.30>, C<5.005_03> will all represent Perl version 5.005_03.
=item C<output>
- $ perl -d:TraceUse=output=out.txt your_program.pl
+ $ perl -d:TraceUse=output:out.txt your_program.pl
This will output the TraceUse result to the given file instead of warn.
@@ -326,9 +375,9 @@ the current directory.
=head1 AUTHORS
-chromatic, C<< <chromatic at wgz.org> >>
+chromatic, C<< <chromatic@wgz.org> >>
-Philippe Bruhat, C<< <book at cpan.org> >>
+Philippe Bruhat, C<< <book@cpan.org> >>
=head2 Contributors
@@ -338,6 +387,9 @@ C<output> option contributed by Olivier Mengu
C<perl -c> support contributed by Olivier Mengué (C<< <dolmen@cpan.org> >>).
+Proxy detection owes a lot to Olivier Mengué (C<< <dolmen@cpan.org> >>),
+who submitted several patches and discussed the topic with me on IRC.
+
=head1 BUGS
Please report any bugs or feature requests to
@@ -23,7 +23,6 @@ my @versions = (
5.60 5.06
5.600 5.6
9.1 9.001
- 9.0a 9
9 9
1.9 1.009
1.2.3.4.5 1.002003004005
@@ -0,0 +1,13 @@
+#!perl -T
+
+use Test::More;
+
+plan skip_all => "These tests are for release candidate testing"
+ if !$ENV{RELEASE_TESTING};
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
+ if $@;
+plan skip_all => "No user servicable parts inside. This Kwalitee metric is a bit silly.";
+
+all_pod_coverage_ok();
@@ -0,0 +1,11 @@
+#!perl -T
+
+use Test::More;
+
+plan skip_all => "These tests are for release candidate testing"
+ if !$ENV{RELEASE_TESTING};
+
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+
+all_pod_files_ok();
@@ -72,6 +72,8 @@ Modules used from -e:
4. M1, -e line 0 [main]
5. M2, M1.pm line 3
6. M3, M2.pm line 3
+Possible proxies:
+ 2 -e line 0, sub main::BEGIN
OUT
[ << 'OUT', qw(-d:TraceUse -e), 'eval { use M1 }' ],
Modules used from -e:
@@ -92,12 +94,16 @@ Modules used from -e:
0. M2, M1.pm line 3
0. M3, M2.pm line 3
0. M8, -e line 0 [main]
+Possible proxies:
+ 3 -e line 0, sub main::BEGIN
OUT
[ << "OUT", '-d:TraceUse', "-Mlib=$tlib2", '-MM7', '-MM8', '-e1' ],
Modules used from -e:
0. lib$vlib, -e line 0 [main]
0. M7 0, -e line 0 [main]
0. M8, -e line 0 [main]
+Possible proxies:
+ 3 -e line 0, sub main::BEGIN
OUT
[ << 'OUT', qw(-d:TraceUse -e), 'eval { require M10 }' ],
Modules used from -e:
@@ -116,6 +122,8 @@ Modules used from -e:
0. M2, M1.pm line 3
0. M3, M2.pm line 3
0. M8, -e line 0 [main]
+Possible proxies:
+ 4 -e line 0, sub main::BEGIN
OUT
[ << 'OUT', '-d:TraceUse', "-I$tlib2", qw( -MM4 -MM1 -MM8 -MM10 -e M5->load) ],
Modules used from -e:
@@ -130,6 +138,8 @@ Modules used from -e:
8. M10, -e line 0 [main]
9. M11 1.01, M10.pm line 3 [M8]
10. M12 1.12, M10.pm line 4 [M8]
+Possible proxies:
+ 4 -e line 0, sub main::BEGIN
OUT
[ << 'OUT', qw(-d:TraceUse -c -MM1 -e), 'require M4' ],
Modules used from -e:
@@ -159,19 +169,24 @@ OUT
Modules used from -e:
OUT
- # does Module::CoreList know about this Perl?
+ # test hiding a well-known core module
my $this_perl = Devel::TraceUse::numify($]);
- my @warns
- = exists $Module::CoreList::version{$this_perl}
- ? ()
- : ([ "Module::CoreList $Module::CoreList::VERSION doesn't know about Perl $this_perl" ]);
- push @tests, [ @warns,
- << "OUT", '-d:TraceUse=hidecore', '-Mstrict', '-e1' ];
+ push @tests, [ << "OUT", '-d:TraceUse=hidecore', '-Mstrict', '-e1' ];
Modules used from -e:
OUT
+ # does Module::CoreList know about this Perl?
+ if ( !exists $Module::CoreList::version{$this_perl} ) {
+ $tests[-1][0] .= << 'OUT'; # update the output
+ 1. strict %%%, -e line 0 [main]
+OUT
+ unshift @{ $tests[-1] }, [ # add a warning
+ "Module::CoreList $Module::CoreList::VERSION doesn't know about Perl $this_perl"
+ ];
+ }
+
# convert Module::CoreList devel version numbers to a number
- my $corelist_version = '2.49_01';#$Module::CoreList::VERSION;
+ my $corelist_version = $Module::CoreList::VERSION;
$corelist_version =~ tr/_//d;
# Module::CoreList didn't know about 5.001 until its version 2.00
@@ -1,9 +0,0 @@
-#!perl -T
-
-use Test::More;
-eval "use Test::Pod::Coverage 1.04";
-plan skip_all =>
- "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
-plan skip_all =>
- "No user servicable parts inside. This Kwalitee metric is a bit silly.";
-all_pod_coverage_ok();
@@ -1,6 +0,0 @@
-#!perl -T
-
-use Test::More;
-eval "use Test::Pod 1.14";
-plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
-all_pod_files_ok();