Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Graph your Perl inheritance structure

by bikeNomad (Priest)
on Jun 10, 2001 at 22:16 UTC ( #87329=sourcecode: print w/ replies, xml ) Need Help??

Category: Programming Tools
Author/Contact Info by bikeNomad, Ned Konz <ned@bike-nomad.com>. POD and multi-line @ISA handling by ZZamboni. Fixes by Hofmator
Description: Graphs the inheritance (@ISA) structure of given files or directories using GraphViz. Can produce ps,hpgl,pcl,mif,pic,gd,gd2,gif,jpeg, png,wbmp,vrml,vtx,mp,fig,svg or dot/neato outputs. Also can produce client- or server-side image maps.
#!/usr/bin/perl -w
# Graphs the ISA structure of given files or directories using GraphVi
+z
# Can produce ps,hpgl,pcl,mif,pic,gd,gd2,gif,jpeg, png,wbmp,vrml,vtx,m
+p,fig,svg
# or dot/neato outputs.
# Also can produce client- or server-side image maps.
#
# Ned Konz <ned@bike-nomad.com>
# $Revision: 1.5 $

use strict;
use IO::File;
use File::Find;
use Getopt::Std;
use GraphViz;

sub usage
{
    print <<EOF;
$0 -- Graphs the inheritance structure of Perl files
By Ned Konz, <ned\@bike-nomad.com>

usage: $0 [-r] [-R] [-f outfile] [-l listfile] [-h] [-v] [-u URLtempl]
+ [file|dir [...]] [>mapfile]
-r           recurse into dirs
-R           layout left to right (default: up-down)
-f outfile   specify output file (default=graphisa.png)
-l listfile  get filenames/options from listfile
-h           get this help message
-v           list filenames to STDERR
-u URLtempl  set image map URL to URLtempl (\\N replaced by pkg, \\F r
+eplaced by file)
             image map will be written to STDOUT
-s           make server side image map rather than client side
-i fmt       set image format to fmt (default=png)
             also available: canon,text,ps,hpgl,pcl,mif,pic,gd,gd2,gif
+,jpeg,
             png,wbmp,vrml,vtx,mp,fig,svg,plain
If directory names are given, all the *.p[lm] files in the directory w
+ill
be processed. The default is to do all the Perl files in the current d
+irectory.
EOF
    exit shift;
}

# process cmdline options
my $opts = 'Rrf:l:hvu:si:';
my %opts;
getopts($opts, \%opts) || usage(1);
usage(0) if defined($opts{h});
while (defined($opts{l}))
{
    my $lFile = IO::File->new($opts{l}) or die "can't open -l file $op
+ts{l} : $!\n";
    my @largs = <$lFile>;
    chomp(@largs);
    splice(@ARGV, 0, 0, @largs);
    delete($opts{l});
    getopts($opts, \%opts) || usage(1);
    $lFile->close();
}

$opts{i} = 'png' if !exists($opts{i});
my $outfile = defined($opts{f}) ? $opts{f} : "graphisa.$opts{i}";

# now filenames are in @ARGV
push(@ARGV, '.') if !@ARGV;

my @files;
my $top;
my $nDirs;

sub findPerlFiles
{
    -f _ && /^.*\.p[lm]\z/si && push(@files, $File::Find::name);
    $File::Find::prune = !defined($opts{r}) && $nDirs > 1;
    -d _ && $nDirs++;
}

# process directories
foreach $top (@ARGV)
{
    $nDirs = 0;
    File::Find::find({wanted => \&findPerlFiles}, $top);
}

my $g = GraphViz->new(rankdir => $opts{R} || 0);

foreach my $file (@files)
{
    $file =~ s#^./##;
    STDERR->print("processing $file\n") if $opts{v};
    my $f = IO::File->new($file) or warn "can't open $file: $!\n", nex
+t;
    my ($package, @isa);
    my $pod = 0;
    while (<$f>)
    {
        if (/^=cut/)
        {
            $pod=0;
            next;
        }
        if (/^=[a-zA-Z]+/)
        {
            $pod=1;
            next;
        }
        next if $pod;
        if (/^\s*package\s+([[:word:]:]+)\s*;/)
        {
            $package = $1;
            next;
        }
        if (/(?<!\\)@(?:([[:word:]:]+)::)?ISA\s*=\s*(.*)/) 
        {
            $package = $1 if defined($1);
            my $tmp = $2;
            while (!/;/)    # accumulate ISA value for multiple lines
            {
                $_ = <$f>;
                $tmp .= $_;
            }
            @isa = eval $tmp;
            if ($@) { warn "Unparseable \@ISA line: $tmp"; next }
            STDERR->print("package=$package, \@ISA=", join(',', @isa),
+ "\n") if $opts{v};
            (my $url = $opts{u} || '\\F') =~ s/\\F/$file/g;
            $g->add_node($package, shape => 'box', URL => $url);
            foreach (@isa)
            {
                $g->add_node($_, shape => 'box', URL => $url);
                $g->add_edge($package, $_);
            };
        }
    }
    $f->close();
}

my $output = IO::File->new($outfile, 'w') or die "can't open $outfile:
+ $!\n";
$output->print(eval "\$g->as_$opts{i}()");
$output->close();

if (exists($opts{u}))
{
    STDOUT->print(exists($opts{s}) ? $g->as_imap : $g->as_ismap())
}

Comment on Graph your Perl inheritance structure
Download Code
Re: Graph your Perl inheritance structure
by Beatnik (Parson) on Jun 11, 2001 at 01:47 UTC
    AutoDia does something similar, altho I doubt Dia exports to various formats :)

    Greetz
    Beatnik
    ... Quidquid perl dictum sit, altum viditur.
Re: Graph your Perl inheritance structure
by ZZamboni (Curate) on Jun 11, 2001 at 02:02 UTC
    This is very neat. I have made a patch (see below) that:
    • Makes it ignore POD lines.
    • Makes it deal with multi-line @ISA declarations such as:
      @ISA=qw(class1
              class2);
      
      Of course, the only foolproof way to get @ISA would be to load the package and examine its value, but this seems to work OK.
    For an example of a graph generated by this program, see this graph, which corresponds to the implementation of this project. :-)

    --ZZamboni

    Here's the patch:

    --- ingraph.pl.orig Sun Jun 10 16:52:08 2001 +++ ingraph.pl Sun Jun 10 17:00:00 2001 @@ -86,16 +86,31 @@ STDERR->print("processing $file\n") if $opts{v}; my $f = IO::File->new($file) or warn "can't open $file: $!\n", next; my ($package, @isa); + my $pod=0; while (<$f>) { + if (/^=cut/) { + $pod=0; + next; + } + if (/^=[a-zA-Z]+/) { + $pod=1; + next; + } + next if $pod; if (/^\s*package\s+([[:word:]:]+)\s*;/) { $package = $1; next; } - if (/@(?:([[:word:]:]+)::)?ISA\s*=\s*(.*)\s*;/) + if (/@(?:([[:word:]:]+)::)?ISA\s*=\s*(.*)\s*/) { - @isa = eval $2; + my $tmp=$2; + while (!/;/) { + $_=<$f>; + $tmp.=$_; + } + @isa = eval $tmp; if ($@) { warn "Unparseable \@ISA line: $_"; next } $package = $1 if defined($1); STDERR->print("package=$package, \@ISA=", join(',', @isa), "\n") i +f $opts{v};
Re: Graph your Perl inheritance structure
by Hofmator (Curate) on Jun 14, 2001 at 13:58 UTC

    Very neat program bikeNomad. I spotted some minor bugs/optimisations ... I must remark that that was no thorough testing, so I have probably left some more things to discover for other ;-)

    delete($opts{l}); ## was: delete($opts{L});

    typo ... otherwise there is an infinite loop with the l-option

    # was: if (/@(?:([[:word:]:]+)::)?ISA\s*=\s*(.*)\s*/) if (/(?<!\\)@(?:([[:word:]:]+)::)?ISA\s*=\s*(.*)/)

    I added a negative look-behind at the beginning to not allow a backslashed '@' in front of the ISA - so now even if run on the sourcecode itself (not that this is very sensible :) it produces no errors. Furthermore I removed the '\s*' at the end, this was unnecessary as everything is ate up anyway by the (greedy) '.*' .

    while (!/;/) # accumulate ISA value for multiple lines { $_ = <$f>; $tmp .= $_; } @isa = eval $tmp; # was: if ($@) { warn "Unparseable \@ISA line: $_"; next }; if ($@) { warn "Unparseable \@ISA line: $tmp"; next };

    The reason for creating the eval-error can be in any of the lines read in, not only in the last. Apart from that the error handling prints now always only the part after the equal sign.

    -- Hofmator

Re: Graph your Perl inheritance structure
by Anonymous Monk on Jun 02, 2011 at 18:58 UTC

    Nice and useful. I've a big code base which does inheritance via use base qw(blah blah), so I tweaked the regexp to handle use base and use parent like so:

    ... if (/(?:(?<!\\)@(?:([[:word:]:]+)::)?ISA\s*=|(?:use\s+(?:base|parent)) +)\s*(.*)/) { $package = $1 if defined($1); ...

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (11)
As of 2014-07-22 21:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (128 votes), past polls