Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

sub_graph.pl: perl call graph generator

by ferrency (Deacon)
on Aug 02, 2000 at 22:20 UTC ( #25807=sourcecode: print w/ replies, xml ) Need Help??

Category: Debugging
Author/Contact Info Alan Ferrency alan@ferrency.com
Description: sub_graph.pl generates a subroutine call graph in .dot format for the specified perl files. Command line options can be used to include and exclude certain graph edges, and to define a "special" set of subroutines you're specifically interested in. Use AT&T's GraphViz package to turn the .dot file into a .gif or .ps.

I'd like to complete this enough to contribute it to CPAN, but I figured I'd run it past my fellow Monks first, for commentary.

Update: This code can also be found on my open source site if you prefer .tgz format to trying to cut and paste this stuff out of Perl Monks.

#!/usr/bin/perl -w
#

=head1 NAME
sub_graph.pl - perl subroutine call graph generator

=head1 SYNOPSIS

sub_graph.pl <options> my_perl_files
sub_graph.pl -help

=head1 VERSION 0.2

July, 2000 by Alan Ferrency (alan@ferrency.com)

=head1 DESCRIPTION

sub_graph.pl Analyzes a list of (perl) files specified on the command
line using B::Xref, and outputs a .dot format calling graph, with
nodes corresponding to perl subs, and edges corresponding to
subroutine calls from one subroutine to another.  The .dot file
format is used by AT&T's free GraphViz software to draw the specified
graph.  dot, part of GraphViz, can be used to create .ps or .gif
format representations of the calling graph.

=cut


use strict;

# Make some options.  Too bad this is as long as the rest of the code.
use Getopt::Simple qw($switch);
my $options = {
    'help|h|?' => {
        'type' => '',
        'env' => '',
        'default' => '',
        'order' => 1,
        'verbose' => 'This message'
        },
    'output_file' => {
        'type' => '=s',
        'default' => '-',
        'verbose' => 'Output filename',
        'order' => 2,
        'env' => ''
        },
    'header_file' => {
        'type' => ':s',
        'env' => '',
        'default' => 'graph.head',
        'order' => 2,
        'verbose' => 'File to prepend to .dot output'
        },
    'skips_file' => {
        'type' => ':s',
        'env' => '',
        'default' => 'graph.skips',
        'order' => 2,
        'verbose' => "File with a list of files we shouldn't parse"
        },   'skip_nonperl_files' => {
        'type' => '!',
        'env' => '',
        'default' => 1,
        'order' => 6,
        'verbose' => "Skip files whose first line doesn't m|^\#\!.*/pe
+rl|"
    },
    'graph_name' => {
        'type' => '=s',
        'env' => '',
        'default' => 'mygraph',
        'order' => 3,
        'verbose' => 'name of dot graph'
        },
    'special_nodes_fn' => {
        'type' => '=s',
        'env' => '',
        'default' => 'graph.special',
        'order' => 4,
        'verbose' => 'file containing a list of "special" nodes (subro
+utines).'
        },
    'special_node_attr' => {
        'type' => '=s',
        'env' => '',
        'default' => '[color=grey,style=filled]',
        'order' => 5,
        'verbose' => 'dot attributes to use on every "special" node'
        },
    'perl' => {
        'type' => '=s',
        'env' => 'PERL',
        'default' => '/usr/bin/perl',
        'order' => 3,
        'verbose' => 'where does perl live?  (used as $PERL -B::Xref <
+fname>)'
        },
    'verbose' => {
        'type' => '+',
        'env' => '',
        'default' => 0,
        'order' => 3,
        'verbose' => 'Talk a lot, but say very little.'
    },
    'special_edges_only' => {
        'type' => '!',
        'env' => '',
        'default' => 0,
        'order' => 7,
        'verbose' => "Display only edges to and from nodes in the spec
+ial node list.\n\tThis takes priority over from_special_no
ds_only and to_special_nodes_only."
    },
    'from_special_nodes_only' => {
        'type' => '!',
        'env' => '',
        'default' => 0,
        'order' => 8,
        'verbose' => 'Display only edges from a node in the special no
+de list'
    },
    'to_special_nodes_only' => {
        'type' => '!',
        'env' => '',
        'default' => 0,
        'order' => 9,
        'verbose' => 'Display only edges to a node in the special node
+ list'
    },    'no_internal_edges' => {
        'type' => '!',
        'env' => '',
        'default' => 0,
        'order' => 10,
        'verbose' => 'Use this to suppress drawing of edges between tw
+o special nodes\n\t(edges internal to the special node sub
graph)'
    },
    'special_subgraph' => {
        'type' => '!',
        'env' => '',
        'default' => 0,
        'order' => 7,
        'verbose' => "Build special nodes into a subgraph, with option
+al attributes as specified"
        },
    'subgraph_attributes' => {
        'type' => '=s',
        'env' => '',
        'default' => 0,
        'order' => 7,
        'verbose' => "Attribute codes for special subgraph"
        }

};

my $o = new Getopt::Simple;
exit (-1) if (! $o->getOptions($options, "Usage: $0 [options]"));

# Everything else is a list of perl files to parse.

my @files = @ARGV;

# If we are told, skip all nonperl files

if ($switch->{'skip_nonperl_files'}) {
    @files = grep {
        # implicitly and silently skip files we can't open.
        open F, "$_" and <F> =~ m|^\#\!.*/perl|;
    } @files;
}

# Implicitly skip tilde and hash files

@files = grep {!/~$|^#.*#$/} @files;

# read in a list of files to skip, and skip them.

if (-f $switch->{'skips_file'}) {
    my %skip;
    open F, "$switch->{'skips_file'}" or die "Can't open $switch->{'sk
+ips_file'} for reading";
    while (<F>) {
        chomp;
        foreach (split /\s+/) {
            $skip{$_}++;
        }
    }
    @files = grep { !$skip{$_} } @files;
}

print "I will analyze the following files:\n". join ("\n", @files) if 
+$switch->{'verbose'};


# Read in "special" nodes list

my %want;
if (-f $switch->{'special_nodes_fn'}) {
    open F, "$switch->{'special_nodes_fn'}" or die "Can't open $switch
+->{'special_nodes_fn'} for reading";
    while (<F>) {
        chomp;
        foreach (split /\s+/) {
            $want{$_}++;
        }
    }
}

# Next, analyze Xref output for each file specified.

my $cur_sub;  # name of the sub we're currently "in"
# HoH, where exists($edges{A}->{B}) means we have an edge from A to B
my %edges;

# Build a HoH with edge counts.
for my $f (@files) {
    # Xref will print "syntax OK" or errors to STDERR; we don't mind.
    open X, "$switch->{'perl'} -MO=Xref $f|";
    while (<X>) {
        chomp;
        print "--Xref: $_\n" if $switch->{'verbose'} > 2;
        if (/Subroutine \(?([^()]*)/) {
            $cur_sub = $1;
            $cur_sub = "${f}_MAIN" if $cur_sub eq "main";
            $cur_sub =~ tr/.:/__/; # dot doesn't like punctuation.
        } elsif (/^\s*\&(\w\S+)\s*/) {
            next if $cur_sub eq "definitions"; # seemed like a good id
+ea at the time
            my $s = $1;
            $s =~ s/:/_/g;
            $edges{$cur_sub}->{$s}++;
        }
    }
}


# Output a .dot file

open DOT, ">$switch->{'output_file'}"
    or die "Can't open $switch->{'output_file'} for writing";

# First, start the graph
print DOT "digraph $switch->{'graph_name'} {\n";

# If we have a header file, stick it in
if (-f $switch->{'header_file'}) {
    open HEAD, "$switch->{'header_file'}"
        or die "Can't open $switch->{'header_file'} for read";
    while (<HEAD>) { print DOT; }
    close HEAD;
}


# Next, give Wanted Nodes special treatment.  As a side effect, these
# nodes will always show up on the graph even if no edges touch them.

map { print DOT "$_$switch->{'special_node_attr'};\n" } keys %want;

# Build a special subgraph if we request it
if ($switch->{'special_subgraph'}) {
    print DOT "{$switch->{'subgraph_attributes'};";
    map { print DOT " $_" } keys %want;
    print DOT "}\n";
}
# set up some temporary variables for brevity and speed

# we want all the edges unless specified otherwise

my $want_all = !$switch->{'special_edges_only'} &&
    !$switch->{'from_special_nodes_only'} &&
        !$switch->{'to_special_nodes_only'};

my $want_from = $switch->{'special_edges_only'} ||
    $switch->{'from_special_nodes_only'};

my $want_to = $switch->{'special_edges_only'} ||
    $switch->{'to_special_nodes_only'};

my $want_int = !$switch->{'no_internal_edges'};

if ($switch->{'verbose'}) {
    print "I am" . (!$want_all && " not") ." printing all edges\n";
    print "I am" . (!$want_to && " not") ." printing edges to special 
+nodes.\n";
    print "I am" . (!$want_from && " not") ." printing edges from spec
+ial nodes.\n";
    print "I am" . (!$want_int && " not") ." printing edges between sp
+ecial nodes.\n";
}

for my $n1 (sort keys %edges) {
    foreach my $n2 (sort keys %{$edges{$n1}}) {
        print DOT "   $n1 -> $n2;\n" if
            $want_all ||
                ($want{$n1} && $want_from && ($want_int || !$want{$n2}
+)) ||
                        ($want{$n2} && $want_to && ($want_int || !$wan
+t{$n1}));
        # Announce large edge counts if we're talking too much
        if ((my $n = $edges{$n1}->{$n2}) > 1) {
            print "There are $n edges between $n1 and $n2\n" if $switc
+h->{'verbose'} > 1;
        }
    }
}


print DOT "}";
close DOT;
__END__

Comment on sub_graph.pl: perl call graph generator
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://25807]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (4)
As of 2015-07-05 14:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (67 votes), past polls