#!/usr/bin/perl
#BEGIN {unshift@INC,('../../..');}
use strict;

use Pod::Usage;
use W3C::Util::Scriptopt;
use W3C::Util::Exception qw(&throw &DieHandler);

use vars qw($VERSION);
$VERSION = 1.0;

# Tree hierarchy data:
my $Parents = {};
my $Nodes = {};

# Getopt flags:
my ($help, $man, $version) = (0, 0, 0);
my $Orientation = 'TB';
my $MultiInheritance = 'allow'; # first, last, error
my $NodeStyle = 'node [fontname=arial,fontsize=10,color=Black,fontcolor=Blue]';
my $ArcStyle = 'edge [fontname=arial,fontsize=10,color=Darkgreen,fontcolor=Red]';
my $DefaultFilters = [['.*::', '', 'ignore']];
my $Filters = $DefaultFilters;
my $ArgsProcessed = 0;

# Use Getopt.
my $res = &GetOptionsScript('o=s' => \&setOrientation, 
			    'n=s' => \$NodeStyle, 
			    'a=s' => \$ArcStyle, 
			    'f=s' => \&addFilter, 
			    'm=s' => \&setMultiInhertiance, 
			    'help|?' => \$help, 
			    'man' => \$man, 
			    'version' => \$version, 
			    '<>' => \&processFile);

&pod2usage(-exitstatus => 0, -verbose => 1) if $help;
&pod2usage(-exitstatus => 0, -verbose => 2) if $man;
if ($version) {
    my $revstr = '$Revision: 1.3 $ $Date: 2004/06/08 06:51:01 $ ';
    print "$0 version: $VERSION\n$revstr\n";
    exit (0);
}
&pod2usage(-exitstatus => 1, -verbose => 1, 
	   -message => "No files processed.") if ($ArgsProcessed == 0);

&dumpResults;

# Getopt callbacks:
sub setOrientation {
    my ($flag, $value) = @_;
    pod2usage(-exitstatus => 1, 
	      -verbose => 1, 
	      -message => "\"$value\" is an invalid orientation.")
	if ($value !~ m/^(LR|TB)$/);
    $Orientation = $value;
}


sub addFilter {
    my ($flag, $value) = @_;
    if ($Filters == $DefaultFilters) {
	$Filters = [];
    }
    if ($value =~ m|s/([^/]+)/([^/]*)/(ignore)?|) {
	push (@$Filters, [$1, $2, $3]);
    } elsif ($value =~ m|([\w\d\:]+)|) {
	push (@$Filters, [$1, '', undef]);
    } else {
	pod2usage(-exitstatus => 1, 
		  -verbose => 1, 
		  -message => "\"$value\" must be simple string or s/<foo>/<bar>/ or s/<foo>/<bar>/ignore.");
    }
}


sub setMultiInhertiance {
    my ($flag, $value) = @_;
    pod2usage(-exitstatus => 1, 
	      -verbose => 1, 
	      -message => "\"$value\" is an invalid multi-inheritance value (must be allow|first|last|error).")
	if ($value !~ m/^(first|last|allow|error)$/);
    $MultiInheritance = $value;
}


sub processFile () {
    my ($name) = @_;
    eval {
	local($SIG{"__DIE__"}) = \&DieHandler;
	&processFile1($name);
    }; if (%W3C::Util::Exception::currentExceptions) {
	my $exStr = (keys %W3C::Util::Exception::currentExceptions)[0];
	my $ex = $W3C::Util::Exception::currentExceptions{$exStr};
	die $ex->toString;
    }
}

sub processFile1 () {
    my ($name) = @_;
    eval {
	$ArgsProcessed++;

	if (!-f $name) {
	    eval {
		local $SIG{__DIE__} = 'DEFAULT';
		eval "require $name"; if ($@) {die;}
		$name =~ s/::/\//g;
		$name = $INC{"$name.pm"};
	    }; if ($@) {}
	}
	open (INP, $name) || &throw(new W3C::Util::FileNotFoundException(-filename => $name));
	foreach my $line (<INP>) {
	    if ($line =~ m/@(.*?)::ISA = ([^;]+);/) {
		my ($child, $parentLine) = ($1, $2);
		my $parents = [];
		if ($parentLine =~ m/qw\(([^\)]*)\)/) {
		    foreach my $parent (split(/ /, $1)) {
			&processPair($child, $parent);
		    }
		} else {
		    &throw(new W3C::Util::Exception(-message => "write more code to deal with Rvalue \"$parentLine\""));
		}
	    }
	}
    }
}

sub processPair {
    my ($child, $parent) = @_;
    foreach my $filterSpec (@$Filters) {
	my ($from, $to, $ignore) = @$filterSpec;
	if ($child =~ m/$from/) {
	    $child =~ s/$from/$to/g;
	} elsif (!$ignore) {
	    &throw(new W3C::Util::Exception(-message => "expected child \"$child\" to match \"$from\""));
	}
	if ($parent =~ m/$from/) {
	    $parent =~ s/$from/$to/g;
	} elsif (!$ignore) {
	    &throw(new W3C::Util::Exception(-message => "expected parent \"$parent\" to match \"$from\""));
	}
    }
    if (exists $Parents->{$child}) {
	if ($MultiInheritance eq 'first') {
	} elsif ($MultiInheritance eq 'last') {
	    $Parents->{$child} = [$parent];
	    $Nodes->{$child} = undef;
	} elsif ($MultiInheritance eq 'allow') {
	    push (@{$Parents->{$child}}, $parent);
	    $Nodes->{$child} = undef;
	} elsif ($MultiInheritance eq 'error') {
	    &throw(new W3C::Util::Exception(-message => "multi-inheritance not allowed and $child has parents $Parents->{$child}[0] and $parent"));
	} else {
	    &throw(new W3C::Util::ProgramFlowException());
	}
    } else {
	push (@{$Parents->{$child}}, $parent);
	$Nodes->{$child} = $Nodes->{$parent} = undef;
    }
}

sub dumpResults {
    print "digraph dotfile{ 
$NodeStyle;
$ArcStyle;
rankdir=$Orientation;

";
    foreach my $node (keys %$Nodes) {
    }
    foreach my $child (keys %$Parents) {
	foreach my $parent (@{$Parents->{$child}}) {
	    print "\"$parent\" -> \"$child\"  [];\n";
	}
    }
    print "}

";
}

__END__

=head1 NAME

isa2dot - Show perl class hierarchy in dot format.

=head1 SYNOPSIS

isa2dot [options] [class or file ...]

=head1 OPTIONS

=over 8

=item B<-m>

Mulitiple inheritance policy: must be one of first | last | allow | error. B<first> is the default.

=item B<-o>

Graph orientation: mut be one of LR | TB. B<LR> is the default.

=item B<-n>

Node style: must be valid dot directive. B<node [fontname=arial,fontsize=10,color=Black,fontcolor=Blue]> is the default.

=item B<-a>

Arc style: must be valid dot directive. B<edge [fontname=arial,fontsize=10,color=Darkgreen,fontcolor=Red]> is the default.

=item B<-f>

Filter(s) for package names. B<s/.*:://ignore> is the default.

=item B<-help>

Print a brief help message and exit.

=item B<-man>

Send the manual page to the $PAGER and exit.

=item B<file>

Parse B<file> as a perl module.

=back

=head1 DESCRIPTION

B<isa2dot> scans a set of perl modules for class hierarchy info (B<ISA> assignments) and ouputs the data in a dot file. The perl modules may be specifed by class name or by file path. B<filters> are applied to the names in the hierarchy, the B<multi-inheritance> policy is enforced, and the resulting tree is output in dot according to B<orientation>, B<node style> and B<arc style>.

=cut

