Re: Perl call tree utility

[mjd-perl-pm@plover.com (Mark Dominus)]

Mark Dominus:
> I'm looking for a utility which will take a program and produce a
> table of which functions can call which other functions.  It should do
> this by static analysis of the source code.  I don't want just a table
> of which functions *have* called which functions in the course of some
> particular run.
> 
> I wasn't able to find anything on CPAN, and I suspect I just haven't
> thought of the right keyword.

I gave up on CPAN and wrote one.  It requires the B::Utils module.

To use, do

        perl -MCalltree yourprogram.pl

It then prints out a report like this:


        __MAIN__: 
          Getopt::Long::config
          HTML::Parse::parse_html
          LWP::Debug::level
          LWP::Version
          main::GetOptions
          main::printResponseChain
          main::str2time
          main::time2str
          main::uf_uri
          main::usage

        main::GetOptions: 
          Getopt::Long::FindOption
          Getopt::Long::OptCtl
          Getopt::Long::ParseOptionSpec

        main::printResponseChain: 
          main::printResponseChain

        main::status_message: 

        main::str2time: 
          HTTP::Date::parse_date
          Time::Local::timegm
          Time::Local::timelocal
          Time::Zone::tz_offset

        main::time2str: 

        main::uf_uri: 
          URI::Heuristic::uf_uristr

        main::usage: 


Actually the default output includes the report for all the other
modules too.  There's an option to suppress this, but since there's no
documentation you'll have to read the code to find it.  If there are
any wizards-in-training on the list, I think a good exercise for them
would be to read and understand this code.


Share and enjoy!

----------------------------------------------------------------
package Calltree;
use B::Utils qw(all_roots walkoptree_simple);

my %legal_options 
  = (INCLUDE_PACKAGES => undef,
     EXCLUDE_PACKAGES => [__PACKAGE__],
     CALLBACK =>  \&print_report,
     CALLBACK_DATA => undef,
    );

our %OPT;

sub import {
  my ($class, %opts) = @_;
  my @BAD;
  for my $k (keys %opts) {
    if (exists $legal_option{uc $k}) {
      $OPT{uc $k} = $opts{$k};
    } else {
      push @BAD, $k ;
    }
  }
  if (@BAD) {
    my $options = @BAD == 1 ? 'option' : 'options';
    require Carp;
    Carp::croak "$class: unrecognized $options @BAD";
  }
  for my $k (keys %legal_options) {
    $OPT{$k} = $legal_options{$k} unless defined $OPT{$k};
  }
}

sub array_to_hash {
  my %h;
  for (@_) { $h{$_} = 1 }
  \%h;
}

sub adjust_options {
  my $opt = shift;
  if (! defined $opt->{INCLUDE_PACKAGES}) {
    $opt->{INCLUDE_PACKAGES} = array_to_hash(walk_stashes(), 'main');
  }

  for my $k (qw(INCLUDE_PACKAGES EXCLUDE_PACKAGES)) {
    if (! ref $opt->{$k}) {
      $opt->{$k} = array_to_hash(split /,\s*/, $opt->{$k});
    } elsif (ref $opt->{$k} eq 'ARRAY') {
      $opt->{$k} = array_to_hash(@{$opt->{$k}});
    }
  }
}

sub walk_stashes {
  my $top = shift || '';
  return if $top eq '::main';
#  print "* $top\n";
  my @packages = $top;
  while (my $name = each %{"$top\::"}) {
    next unless $name =~ s/::$//;
    push @packages, walk_stashes("$top\::$name");
  }
#  print "=> @packages\n";
  map /^(?:::)?(.*)/, @packages;
}

sub trim_stashname {
  my $sn = shift;
  $sn =~ s/::$//;
  return $sn;
}

sub INIT {
  adjust_options(\%OPT);

  my %root = all_roots();
  my %CALLS;
  while (my ($name, $root) = each %root) {
    my ($pkg) = $name =~ /(.*)::/; 
    next unless $OPT{INCLUDE_PACKAGES}{$pkg};
    next if $OPT{EXCLUDE_PACKAGES}{$pkg};
    my @CALLS;
    $CALLS{$name} = {};
    walkoptree_simple($root, \&find_subcall, \@CALLS);
    for my $call (@CALLS) {
      $CALLS{$name}{$call} = 1;
    }
  } 
  $OPT{CALLBACK}->(\%CALLS, $OPT{CALLBACK_DATA});
  exit;
}

sub find_subcall {
  my ($op, $dest) = @_;
  if ($op->name eq 'gv' && $op->next && $op->next->name eq 'entersub') {
    my $cur_gv = $op->gv;
    push @$dest, join '::', $cur_gv->STASH->NAME, $cur_gv->NAME; 
  }
}

sub print_report {
  my $C = shift;
  for my $caller (sort keys %$C) {
    print "\n$caller: \n";
    for my $callee (sort keys %{$C->{$caller}}) {
      print "  $callee\n";
    }
  }
}

"Cogito, ergo sum";
-
**Majordomo list services provided by PANIX <URL:http://www.panix.com>**
**To Unsubscribe, send "unsubscribe phl" to majordomo@lists.pm.org**