File Coverage

blib/lib/Devel/TraceUse.pm

Criterion	Covered	Total	%
statement	41	117	35.0
branch	13	74	17.5
condition	3	10	30.0
subroutine	8	16	50.0
pod	0	7	0.0
total	65	224	29.0

package Devel::TraceUse;
$Devel::TraceUse::VERSION = '2.096';
# detect being loaded via -d:TraceUse and disable the debugger features we
# don't need. better names for evals (0x100) and anon subs (0x200).
BEGIN {
    if (!defined &DB::DB && $^P & 0x02) {
        $^P = 0x100 | 0x200;
    }
}

BEGIN {
    unshift @INC, \&trace_use;
    *CORE::GLOBAL::require = sub {
        my ($arg) = @_;

        # ensure our hook remains first in @INC
        @INC = ( \&trace_use, grep "$_" ne \&trace_use . '', @INC )
          if $INC[0] ne \&trace_use;

        # let require do the heavy lifting
        CORE::require($arg);
    };
}

# initialize the tree of require calls
my $root = (caller)[1];

# keys in %TRACE:
# - ranked:    modules load attemps in chronological order
# - loaded_by: track "filename"s loaded by "filepath" (value from %INC)
# - used:      track loaded modules by "filename" (parameter to require)
# - loader:    track potential proxy modules
#
# %TRACE is built incrementally by trace_use, and augmented by post_process
my %TRACE;

my %reported;    # track reported "filename"
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 @caller_info = qw( package filepath line );

### %TRACE CONSTRUCTION

# Keys used in the data structure:
# - filename: parameter passed to use/require
# - module:   module, computed from filename
# - rank:     rank of loading
# - eval:     was this use/require done in an eval?
# - loaded:   list of files loaded from this one
# - filepath: file that was actually loaded from disk (obtained from %INC)
# - caller:   information on the caller (same keys + everything from caller())

sub trace_use
{
    my ( $code, $filename ) = @_;

    # $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$//;

    # chronological list of modules we tried to load
    push @{ $TRACE{ranked} }, my $info = {
        filename => $filename,
        module   => $module,
        rank     => ++$rank,
        eval     => '',
    };

    # info about the loading module
    # (our require override adds one frame)
    my $caller = $info->{caller} = {};
    @{$caller}{@caller_info} = caller(1);

    # try to compute a "filename" (as received by require)
    $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 (and store our index)
    push @{ $TRACE{loaded_by}{ $caller->{filepath} } }, $info->{rank} - 1;

    # record potential proxies
    if ( $caller->{filename} ) {
        my $level = 1;    # our require override adds one frame
        my $subroutine;
        while ( $subroutine = ( caller ++$level )[3] || '' ) {
            last if $subroutine =~ /::/;
        }
        $TRACE{loader}{ join "\0", @{$caller}{qw( filename line )}, $subroutine }++;
    }

    # let Perl ultimately find the required file
    return;
}

# some post-processing that requires the modules to have been actually loaded
sub post_process {

    # process the list of loading attempts in reverse order:
    # if a module shows up more than once, then all occurences
    # are failures to load, except maybe the last one
    for my $module ( reverse @{ $TRACE{ranked} || [] } ) {
        my $filename = $module->{filename};

        # module was successfully loaded
        if ( exists $INC{$filename} ) {
            $TRACE{used}{$filename} ||= $module;
        }
    }

    # map "filename" to "filepath" for everything that was loaded
    while ( my ( $filename, $filepath ) = each %INC ) {
        if ( exists $TRACE{used}{$filename} ) {
            $TRACE{used}{$filename}{loaded} = delete $TRACE{loaded_by}{$filepath} || [];
            $TRACE{used}{$filename}{filepath} = $filepath;
        }
    }

    # extract version
    for my $mod ( @{ $TRACE{ranked} } ) {
        $mod->{version} = ${"$mod->{module}\::VERSION"};
    }
}

### UTILITY FUNCTIONS

# we don't want to use version.pm on old Perls
sub numify {
    my ($version) = @_;
    $version =~ y/_//d;
    my @parts = split /\./, $version;

    # %Module::CoreList::version's keys are x.yyyzzz *numbers*
    return 0+ join '', shift @parts, '.', map sprintf( '%03s', $_ ), @parts;
}

### OUTPUT FORMATTERS

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}";
    $message .= defined $mod->{version} ? " $mod->{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 $mod->{filepath};

    $output_cb->($message, @args);
}

sub visit_trace
{
    my ( $visitor, $mod, $pos, @args ) = @_;

    my $hide = 0;

    if ( ref $mod ) {
        if($hide_core) {
            $hide = exists $Module::CoreList::version{$hide_core}{$mod->{module}};
        }
        $visitor->( $mod, $pos, @args ) unless $hide;
        $reported{$mod->{filename}}++;
    }
    else {
        $mod = { loaded => delete $TRACE{loaded_by}{$mod} };
    }

    visit_trace( $visitor, $_, $hide ? $pos : $pos + 1, @args )
        for map $TRACE{ranked}[$_], @{ $mod->{loaded} };
}

sub dump_proxies
{
    my $output = shift;

    my @hot_loaders =
      sort { $TRACE{loader}{$b} <=> $TRACE{loader}{$a} }
      grep { $TRACE{loader}{$_} > 1 }
      keys %{ $TRACE{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",
                $TRACE{loader}{$loader},
                $filename, $line,
                    (length($subroutine) ? ", sub $subroutine" : '')));
    }
}

sub dump_result
{
    return if $quiet;

    post_process();

    # 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
        local *trace_use = sub {};
        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 ( %{ $TRACE{loaded_by} } ) {
        visit_trace( \&show_trace_visitor, $_, 0, $output )
          for sort keys %{ $TRACE{loaded_by} };
    }

    # 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;
}

### HOOK INSTALLATION

# If perl runs with -c we want to dump
CHECK {
    # "perl -c" ?
    dump_result() if $^C;
}

END { dump_result() }

1;

__END__