#!/usr/bin/perl -wT
use strict;
use vars qw($opt_v $opt_c $opt_r $debug $opt_h $opt_H $opt_e $opt_x);
use Tree::MultiNode;
use Getopt::Std;
use HTML::Embperl;

getopts('vc:rhHe:');
$debug         = $opt_v || undef;
$|=1;
$Main::AsHTML  = $opt_H;
my $cache_file = $opt_c || $ENV{'HOME'} . '/.hier';
if($opt_r) { system('/bin/rm','-f',$cache_file); }
if($opt_h) {
  print <<"EOH";
$0 [-v] [-c file] [-r] [-h]
  -v       be verbose
  -c file  specify the cache file
  -r       remove the cache file [reload the input]
  -h       display this help
  -H       dump as HTML
  -e file  specify the embperl template to use
  -x       produce the UML diagrams in Dia XML
EOH
  exit 0;
}

my $template = $opt_e || 'from_pm.exml';
my $tree     = Tree::MultiNode->new();
my $handle   = Tree::MultiNode::Handle->new($tree);
my $r_pkgs   = &process_data(&read_data());

if($opt_x) {
  my $ctr = 0;
  foreach my $name (keys %$r_pkgs) {
    my $info = $r_pkgs->{$name};
  print "package:  ",$info->name(),"\n";
  print "embpkg:   ",'foo_'.$ctr,"\n";
  print "template: ",$template,"\n";
  print "outfile:  ",$name.'.dia',"\n";
  print "fields:   ",join(',',@{$info->fields()}),"\n";
  print "methods:  ",join(',',@{$info->methods()}),"\n";
  print "\n";
  my$data;
  open FILE, "<$template" or die "error opening $template $!\n";
  {local$/=undef,$data=<FILE>;}
  close FILE;
  my$outdata = '';
    HTML::Embperl::Execute({
      #'outputfile' => $name.'.dia',
      'output'    => \$outdata,
      #'inputfile' => $template,
      'input'     => \$data,
      'mtime'     => undef,
      'package'   => 'foo_'.$ctr++,
      'param'     => [{
        'obj_name'  => $info->name(),
        'fields'    => [@{$info->fields()}],
        'methods'   => [@{$info->methods()}],
      }]
    });
    open OUT,">$name.dia" or die "error opening $name.dia $!\n";
    print OUT $outdata;
    close OUT;
  }
  
  exit 0;
}

&build_tree($handle,$r_pkgs);

#$handle->top();
#$handle->down(0);
#print "Tree: \n";
#&dump_tree($handle);

$handle->top();
$handle->down(0);
print '<PRE>',"\n" if $Main::AsHTML;
print "Table Of Contents:\n";
print "------------------\n";
&dump_toc($handle,$r_pkgs);
print "\n\n";
print "Object Tree:\n";
print "------------\n";
&dump_document($handle,$r_pkgs);
print '<PRE>',"\n" if $Main::AsHTML;

exit 0;
################################################################################
{ my $depth = -1;
  sub dump_document
  {
    ++$depth;
    my $handle = shift;
    my $r_pkgs = shift;
    my $lead = ' ' x ($depth*2);
    my($k,$v) = $handle->get_data();
    return unless defined $k && defined $v;
    print '<A NAME="',$v->name(),'">';
    print $lead,'Package: ',$v->package(),"\n";
    print $lead,'  files:    ',scalar(@{$v->files()}),' ',
      join(',',@{$v->files()}),"\n\n";
    my @hier = &build_inheritence_hierarchy(
      Tree::MultiNode::Handle->new($handle)
    );
    if(1 < @hier) {
      print $lead,'  inheritence hierarchy:',"\n";
      my $max = 0;
      foreach (@hier) { $max = $max > length($_) ? $max : length($_); }
      my $wid = int($max/2)+2;
      while(@hier) {
        my $h = shift @hier;
        my $co = $r_pkgs->{$h};
        my $ident = $wid - (length($co->name())/2);
        print $lead,'     ',' 'x$ident,'-'x (length($co->name())+2),"\n";
        print $lead,'    ',' 'x$ident,'| ',$co->package(),' |',"\n";
        print $lead,'     ',' 'x$ident,'-'x (length($co->name())+2),"\n";
        print $lead,'    ',' 'x$wid,'|',"\n" if @hier;
      }
      print "\n";
    }
    print $lead,'  parents:  ',scalar(@{$v->parents()}),"\n";
    foreach my $parent (@{$v->parents()}) {
      unless(defined $r_pkgs->{$parent}) {
        print $lead,'    ',$parent,"\n";
        next;
      }
      my $co = $r_pkgs->{$parent};
      print $lead,'    ',$co->package(),"\n";
    }
    print "\n";

    print $lead,'  children: ',scalar(@{$v->children()}),"\n";
    foreach my $child (@{$v->children()}) {
      unless(defined $r_pkgs->{$child}) {
        print $lead,'    ',$child,"\n";
        next;
      }
      my $co = $r_pkgs->{$child};
      print $lead,'    ',$co->package(),"\n";
    }
    print "\n";

    print $lead,'  methods:         ',scalar(@{$v->methods()}),"\n";
    print $lead,'  public methods:  ',scalar($v->public_methods()),"\n";
    foreach my $meth ($v->public_methods()) {
      print $lead,'    ',$meth,"\n";
      my $h2 = Tree::MultiNode::Handle->new($handle);
      my @overrides = &overrides($meth,$h2);
      if(@overrides) {
        print $lead,'      overrides: ',join(', ',@overrides),"\n";
      }
    }
    print "\n";

    print $lead,'  private methods: ',scalar($v->private_methods()),"\n" ;
    foreach my $meth ($v->private_methods()) {
      print $lead,'    ',$meth,"\n";
      my $h2 = Tree::MultiNode::Handle->new($handle);
      my @overrides = &overrides($meth,$h2);
      if(@overrides) {
        print $lead,'      overrides: ',join(', ',@overrides),"\n";
      }
    }
    print "\n";
    print "\n";

    foreach (0 .. (scalar($handle->children())-1)) {
      $handle->down($_);
      &dump_document($handle,$r_pkgs);
      $handle->up();
    }
    --$depth;
  }
}

{ my $depth = -1;
  sub dump_toc
  {
    ++$depth;
    my $handle = shift;
    my $r_pkgs = shift;
    my $lead = ' ' x ($depth*2);
    my($k,$v) = $handle->get_data();
    #return unless defined $k && defined $v;

    print $lead,'<A HREF="#',$v->name(),'">',$v->name(),"</A>\n";

    foreach (0 .. (scalar($handle->children())-1)) {
      $handle->down($_);
      &dump_toc($handle,$r_pkgs);
      $handle->up();
    }
    --$depth;
  }
}

sub build_inheritence_hierarchy
{
  my $handle = shift;
  my @hier;
  while($handle->depth()) {
    my($k,$v) = $handle->get_data();
    push @hier,$v->name();
    $handle->up();
  }
  return reverse @hier;
}

sub overrides
{
  my $meth   = shift;
  my $handle = shift;

  # step by step, walk back to the top, and return an array
  # of any parent packages that also have the named method...
  my @overrides;
  $handle->up();
  while(0 != $handle->depth()) {
    my($k,$v) = $handle->get_data();
    #print 'looking for overrides in: ',$k,"\n";
    push @overrides, $k.'->'.$meth if grep /^$meth$/,@{$v->methods()};
    $handle->up();
  }
  return @overrides;
}

{ my $depth = -1;
  sub dump_tree
  {
    ++$depth;
    my $handle = shift;
    my $lead = ' ' x ($depth*2);
    my($k,$v) = $handle->get_data();
    return unless defined $k && defined $v;
    print $lead,'k: ',$k||'<undef>',"\n";
    foreach (0 .. (scalar($handle->children())-1)) {
      $handle->down($_);
      &dump_tree($handle);
      $handle->up();
    }
    --$depth;
  }
}
################################################################################
package PkgInfo;
use strict;
use fields qw(name parents files methods children fields);
sub new
{
  my $this  = shift;
  my $class = ref($this) || $this;
  my $self  = {};
  bless $self,$class;
  return $self;
}

sub name     { my $s = shift; $s->{name}     = shift if @_; $s->{name};     }
sub files    { my $s = shift; $s->{files}    = shift if @_; $s->{files};    }
sub fields   { my $s = shift; $s->{fields}   = shift if @_; $s->{fields};   }
sub methods  { my $s = shift; $s->{methods}  = shift if @_; $s->{methods};  }
sub parents  { my $s = shift; $s->{parents}  = shift if @_; $s->{parents};  }
sub children { my $s = shift; $s->{children} = shift if @_; $s->{children}; }

sub public_methods
{
  my $self = shift;
  my %m;
  foreach my $m (@{$self->methods()}) {
    ++$m{$m} if '_' ne substr($m,0,1);
  }
  return keys %m;
}

sub private_methods
{
  my $self = shift;
  my %m;
  foreach my $m (@{$self->methods()}) {
    ++$m{$m} if '_' eq substr($m,0,1);
  }
  return keys %m;
}

sub has_parents
{
  my $self = shift;
  my %p = ();
  foreach my $e (@{$self->parents()}) {
    ++$p{$e};
  }
  delete $p{'Exporter'};   # ignore Eporter
  delete $p{'AutoLoader'}; # ignore AutoLoader
  delete $p{'DynaLoader'}; # ignore DynaLoader
  return scalar(keys %p);
}

sub package
{
  my $self = shift;
  if($Main::AsHTML) {
    return sprintf('<A HREF="%s.html">%s</A>',$self->name(),$self->name());
  }
  else {
    return $self->name();
  }
}

################################################################################

package main;
sub build_tree
{
  my $handle = shift;
  my $r_pkgs = shift;

  foreach my $pkg (&get_top_level_pkgs($r_pkgs)) {
    print 'adding top: ',$pkg->name(),',',$pkg,"\n" if $debug;
    $handle->add_child($pkg->name(),$pkg);
  }

  for(my $i = 0; $i < scalar($handle->children()); ++$i) {
    $handle->down($i);
    my($name,$pkg) = $handle->get_data();
    print 'Recursing into: ',$pkg->name(),"\n" if $debug;
    &build_tree_recursive($handle,$r_pkgs);
    $handle->up();
  }
}

sub build_tree_recursive
{
  my $handle = shift;
  my $r_pkgs = shift;
  my $prefix = shift||'  ';

  my($n,$pkg) = $handle->get_data();
  print $prefix,'Visiting: Key/Val: ',$n||'undef',',',$pkg||'undef',"\n" if $debug;

  foreach my $child (@{$pkg->children()}) {
    my $p = $r_pkgs->{$child};
    print $prefix,'adding child: ',$child,',',$p||'undef',"\n" if $debug;
    $handle->add_child($child,$p);
  }

  for(my $i = 0; $i < scalar($handle->children()); ++$i) {
    next unless ref($pkg) && UNIVERSAL::isa($pkg,'PkgInfo');
    $handle->down($i);
    &build_tree_recursive($handle,$r_pkgs,$prefix.'  ');
    $handle->up();
  }
}

sub get_top_level_pkgs
{
  my $r_pkgs = shift;
  my @top;
  foreach my $pkg (keys %$r_pkgs) {
    push @top, $r_pkgs->{$pkg} if !$r_pkgs->{$pkg}->has_parents();
  }
  return @top;
}

sub read_data
{
  my $cache = shift;
  my $data; { local $/ = undef; $data = <STDIN>; };
  return $data;
}

sub process_data
{
  my $data   = shift;

  my @pkgs = split(/\n{3,}/,$data);
  print 'num pkgs: ',scalar(@pkgs),"\n" if $debug;
  
  my $r_pkgs = {};
  foreach my $pkg (@pkgs) {
    my @sub_sections = split /\n{2,}/ms,$pkg;
    my $name        = shift @sub_sections;
    my $parents     = shift @sub_sections;
    my $files       = shift @sub_sections;
    my $methods     = shift @sub_sections;
    my $fields      = shift @sub_sections;
    my $children    = shift @sub_sections;
  
    $name =~ s/Package Name: //;
    $pkg = PkgInfo->new();
    $pkg->name($name);
  
    my @lines;
    @lines = split /\n+/,$parents;
    shift @lines;
    $pkg->parents([@lines]);
  
    @lines = split /\n+/,$files;
    shift @lines;
    $pkg->files([@lines]);
  
    @lines = split /\n+/,$methods;
    shift @lines;
    $pkg->methods([@lines]);
  
    @lines = split /\n+/,$fields;
    shift @lines;
    $pkg->fields([@lines]);
  
    @lines = split /\n+/,$children;
    shift @lines;
    $pkg->children([@lines]);
  
    $r_pkgs->{$name} = $pkg;
    print 'processed: ',$name,',',$r_pkgs->{$name},"\n" if $debug;
    if($debug) {
      print 'name:       ',$name,"\n";
      print 'parents:    ',join(',',@{$r_pkgs->{$name}->parents()}),"\n";
      print 'files:      ',join(',',@{$r_pkgs->{$name}->files()}),"\n";
      print 'methods:    ',join(',',@{$r_pkgs->{$name}->methods()}),"\n";
      print 'children:   ',join(',',@{$r_pkgs->{$name}->children()}),"\n";
      print "\n";
    }
  }
  return $r_pkgs;
}

__END__
=head1 NAME

hier.pl - generate hierarchical inheritence tree from lineage.pl's output

=head1 SYNOPSIS

  lineage.pl | ./hier.pl -H > docs/modules/doc.html

=head1 DESCRIPTION

hier.pl takes the [text] output generated by lineage.pl and produces
a list of the modules, including methods, the file name, the classes
parents and the classes children.  What hier.pl adds above and beyond
what lineage.pl offerrs is that it additionaly displays the inheritence
hierarchy for the object in question.

=head1 AUTHOR

Kyle R. Burton, kburton@quarterleaf.com

=head1 SEE ALSO

perl(1).

=cut