File Coverage

blib/lib/Devel/TraceDeps.pm

Criterion	Covered	Total	%
statement	56	88	63.6
branch	16	40	40.0
condition	5	14	35.7
subroutine	6	8	75.0
pod			n/a
total	83	150	55.3

package Devel::TraceDeps;
$VERSION = v0.0.3;

=head1 NAME

Devel::TraceDeps - track loaded modules and objects

=head1 SYNOPSIS

  $ perl -MDevel::TraceDeps your_program.pl

And the real fun is to pull a tree of dependencies off of your test
suite.

  $ perl -MDevel::eps=tree -S prove -l -r t
  $ ls tracedeps/

And of course no Devel:: module would be complete without an obligatory
cute little shortcut which needlessly involves the DB backend:

  $ perl -d:eps whatever.pl

TODO:  a cute little shortcut which needlessly claims an otherwise
very funny-looking toplevel namespace.

  $ perl -MapDeps whatever.pl

=head1 About

Devel::TraceDeps delivers a comprehensive report of everything which was
loaded into your perl process via the C, C, or
C mechanisms.

Unlike Devel::TraceLoad, this does not load any modules itself and is
intended to be very unintrusive.  Unlike Module::ScanDeps, it is
designed to run alongside your test suite.

For access to the resultant data, see the API in
L.

In tree mode, forking processes and various other runtime effects
*should* be supported but surprises abound in this realm -- tests and
patches welcome.

TODO reports on shared objects loaded by DynaLoader/XSLoader.

TODO somehow catching the 'use foo 1.2' VERSION assertions.  This is
handled by use() and is therefore outside of our reach (without some
tricks involving $SIG{__DIE__} or such.)

=cut

=begin note

Depth can be inferred, though it is really meaningless because it is an
accident of chronology -- the second level never appears if something is
already loaded.

Types are:

  'do',      $what, $package, $line, $file
  'req',     $what, $package, $line, $file
  'ver',     $version

TODO:
  'loaded',  $module, $return, $version||'undef', $modfile
  'dlmod',   $module
  'failed',  $module, $message
  'done',    $what, $return

Does anything appear in %INC without our knowing?

Dynaloader: @DynaLoader::dl_shared_objects or @DynaLoader::dl_modules ?

=head1 Naming

By $0, but need to address -e and maybe subprocesses.  Perhaps the
import option takes care of that?  There's also this issue of cleaning.

  -MDevel::TraceDeps=tree
    cleans the .tracedeps/ dir
    sets PERL5OPT to =child,$PWD/.tracedeps
    does no tracing?

=head1 After

Which modules were successfully loaded:

  $module, $version

Other data would be

  foreach $module (@loaded) {
    push(@{$something{$module}{wanters}}, $wanter);
  }

=end note

=cut

my %store;

# tracking the steps in the tree
my @trace;
my $tracemark = 0;

my $debugging = 0; # for -d:... usage
BEGIN {
  if(defined(%DB::)) {
    $debugging = 1;
    *DB::DB = sub {};
  }
  *CORE::GLOBAL::do = sub {
    my $target = shift;

    my ($p, $f, $l) = CORE::caller;
    my $list = $store{$p} ||= [];

    push(@trace, ++$tracemark); $tracemark = 0;
    push(@$list, my $req = {file => $f, line => $l, did => $target,
      trace => join('-', @trace),
    });
    #warn "$p does $target ($f, $l)\n";
    my $x = bless({mod => $target, req => $req, by => \@caller},
      'Devel::TraceDeps::Watch');

    my $ret = CORE::do($target);
    return($ret) if($ret);
    #$x->{err} = $@ if($@);
    if(defined($ret)) {
      $req->{err} = "returned '$ret'" unless($ret);
    }
    else {
      $req->{err} = $!;
    }

    return($ret);
  };
  *CORE::GLOBAL::require = sub {
    my ($required) = @_;
    my $module = $required; # don't touch the $required value

    my @caller = CORE::caller(0);
    my ($p, $f, $l) = @caller;

    # remember it
    my $list = $store{$p} ||= [];
    #warn "$p wants $module ($f, $l)\n";

    # do data-gathering

    # pass through version numbers
    # XXX require("0.4") edge cases :-/
    # bah! this is version 5something dude
    if(($module =~ m/^5(?:\.|$)/) or (ord(substr($module, 0, 1)) == 5)) {
      # using it as a string breaks the versiony magic
      # but an untouched value works fine
      # ok, if it has literal dots it is a number
      my $version =
        $module eq '5' ? '5.000' :
        $module =~ m/^5(?:\.|$)/ ? $module : sprintf("%vd", $module);
      push(@$list, {file => $f, line => $l, ver => $version,
        trace => join('-', @trace, ++$tracemark),
      });
      return CORE::require $required;
    }

    push(@trace, ++$tracemark); $tracemark = 0;

    push(@$list, my $req = {
      file => $f, line => $l, req => $module,
      trace => join('-', @trace),
    });

    if(exists($INC{$module})) {
      $tracemark = pop(@trace);
      return(1);
    }

    # delicious and necessary evil: the object goes out of scope in that
    # moment between the here and the there, thus: after the
    # CORE::require completes, even if we're in eval.

    #warn join("|", 'caller =', @caller), "\n";
    my $x = bless({mod => $module, req => $req, by => \@caller},
      'Devel::TraceDeps::Watch');

    # apparently goto doesn't work here,
    # so we need to tweak the caller stack?
    return scalar(CORE::require($module));
  };
}
{
  package Devel::TraceDeps::Watch;
  sub DESTROY {
    my $self = shift;
    my $req = $self->{req};
    unless($INC{$self->{mod}}) {
      $req->{fail} = 1;
    }
    $tracemark = pop(@trace);

    # hmm, can we tell if this is global cleanup time?

    my $caller = delete($self->{by});

    if(my $err = $@) {
      # XXX ugh. eval("require foo") vs eval {require foo}!
      # thanks base.pm
      if($err =~ m/^(Can't locate .*\)) at /) {
        my $fix_err = $1;
        my @from = @$caller;
        # emulate the builtin eval error here (eek)
        my $at_file =
          ($from[6] or $from[3] =~ m/::BEGIN$/) ? "(eval 424242)" :
          $from[1];
        my $at_line = $from[2];
        $fix_err .= " at $at_file line $at_line.\n";
        $@ = $fix_err; # YES I REALLY MEAN THAT
      }
      # the @INC bits are not important
      $err =~ s/\(\@INC contains: .*/.../;
      $err =~ s/\n$//;
      $err =~ s/\n/\\n/g;
      $req->{err} = $err;
    }
    return;
  }
}

sub _output {
  my (%args) = @_;
  return if($args{is_root});

  my $fh;
  if(my $dir = $args{in_tree}) {
    my $program = $args{program};
    $program =~ s#^/+##;
    $program =~ s#/+#---#g;
    $outfile = $dir . '/' . $program;
    if($$ != $args{init_pid}) {
      $outfile .= '.' . $$;
    }
    open($fh, '>', $outfile) or die "cannot save $outfile $!";
  }
  else {
    $fh = \*STDOUT;
  }
  foreach my $key (keys(%store)) {
    print $fh $key, "\n";
    foreach my $item (@{$store{$key}}) {
      print $fh join("\n", '  -----',
        map({"  $_: $item->{$_}"} keys %$item)), "\n";
    }
  }
}

########################################################################
{ # closure
my %self;

END { _output(%self); }

sub import {
  my $class = shift;
  my (@args) = @_;
  #warn "my pid is $$";
  if(@args) {
    if($args[0] eq 'tree') {
      $self{is_root} = 1;
      my $dir = $args[1] || 'tracedeps';
      if(-e $dir) {
        die "$dir exists!";
      }
      else {
        mkdir($dir);
      }

      # just setup the subprocesses
      $ENV{PERL5OPT} = join(' ',
        split(/ /, $ENV{PERL5OPT}||''), "-MDevel::TraceDeps=tree=$dir"
      );
    }
    elsif($args[0] =~ s/^tree=//) {
      # subprocess
      $self{in_tree} = $args[0];
      $self{program} = $0;
      $self{init_pid} = $$;
    }
    else {
      die "unknown import args @args";
    }
  }
}
}
########################################################################

=head1 Possible Issues

I think these are going to be very pathological cases since I've already
run a fair body of code through this without any visible hitches.

=head2 Version Number Ambiguity

If you try to require("5.whatever.pm"), it might fail.

=head2 Caller

If a required module expects to do something with caller() at BEGIN time
(e.g. outside of import()), we have problems.  If I could think of a
good reason to rewrite the results of caller(), I would.

=head2 Tree

The tree setting goes all the way down into any perl subprocesses by
setting ourselves in PERL5OPT.  This is probably what you want if you're
trying to package or bundle some code, but needs a knob if you're trying
to do something else with it.

The PERL5OPT variable gets dropped if you use taint.  Patches welcome!

=head1 AUTHOR

Eric Wilhelm @

http://scratchcomputing.com/

=head1 BUGS

If you found this module on CPAN, please report any bugs or feature
requests through the web interface at L.  I will be
notified, and then you'll automatically be notified of progress on your
bug as I make changes.

If you pulled this development version from my /svn/, please contact me
directly.

=head1 COPYRIGHT

Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved.

=head1 NO WARRANTY

Absolutely, positively NO WARRANTY, neither express or implied, is
offered with this software.  You use this software at your own risk.  In
case of loss, no person or entity owes you anything whatsoever.  You
have been warned.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

my $fakery = 'kwalitee police look the other way now please
use strict;
'; # we cannot use modules here, not even strict.pm


# vi:ts=2:sw=2:et:sta
1;