#!/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())
}