#!/usr/bin/perl
#Time-stamp: "2005-08-19 01:24:20 ADT"    sburke@cpan.org
#desc{    a class inspector in Perl    }
#
#   Just say spect -h for usage instructions.
#
# See also Devel::Symdump in CPAN

$::class_inspector = sub {
  use strict;
  
  my $Debug = 0;
  my @classes_to_see;
  my $Cols = 73;
  my $usage = sub {
    my $self = $0;
    $self = $1 if $self =~ m<([^/]+)$>s;
    print "Usage:\n$self [switches and specs]", <<'EOU';
Switches:
  -a        inspect all classes with code/@ISA, not just ones loaded
  -A        inspect all clasess, not just ones loaded
  -M123     set output column size to 123 (default: 73)
  -h        this message
  -e CODE   eval code
Specs
  Foo::Bar  load and inspect that class (and ancestors)
  Foo.pm    load and inspect all packages (and ancestors) defined by Foo.pm

Switches and Specs may be mixed together.

EOU
  };
  
  my($mode_a, $mode_A);
  my @Args = @_;
  @Args = ('-h') if !@Args
   and !defined %DB:: and !defined *DB::OUT{IO} # running under the debugger
  ;
  
  for(my $j = 0; $j < @Args; ++$j) {
    my $i;
    next unless defined($i = $Args[$j]);
    
    if($i eq '-e') {
      die "No code to eval?" if $j == $#Args;
      #print "Evalling $Args[$j + 1]\n";
      eval(" no strict; " . $Args[$j + 1]);
      die "Error in evalling -e code: $@\n" if $@;
      $Args[$j + 1] = undef;
    } elsif($i eq '-a') { # Inspect all classes an ISA, or with code in them
      $mode_a = 1;
    } elsif($i eq '-A') {
      $mode_A = 1;
    } elsif($i =~ m/-M(\d+)$/s) { # -M128 set margin to 128
      $Cols = $1;
      if($Cols < 5) {
        die "$Cols is too few cols\n";
      }
    } elsif($i eq '-h' or $i eq '-?') {
      &$usage; exit;
    } elsif('-' eq substr($i,0,1)) {
      print "Unknown switch $i\n";
      &$usage; exit;
    } elsif(-e $i and -f _) {
      local $/;
      # package; # yes, null package
      my $data;
      open(main::CSINS, "< $i") or die "Can't read-open $i: $!\n";
      $data = <main::CSINS>;
      print length($data), "b read from $i\n" if $Debug;
      close(main::CSINS);
      if($data =~ m<^\s*package\s+(\w+(?:::\w+)*)>m) {
        print ">>> $i > $1\n";
        push @classes_to_see, $1;
      } else {
        die "Can't tell what package $i defines.\n";
        # Or just ignore and catch later?
      }
      print "Evalling $i\n" if $Debug;
      my $rv = do {no strict; eval $data};
      die $@ if $@;
      die "$i didn't return a true value\n" unless $rv;
    } elsif($i =~ m<^\w+(?:\:\:\w+)*$>s) {
      print "Using $i\n" if $Debug;
      push @classes_to_see, $i;
      eval "use $i ();";
      die "Can't require $i: @!\n" if @!;
    } else {
      die "What is \"$i\"?\n";
    }
  }
  
  my %coderef2names;
  my %package_has_code;
  my %packageref_seen;
  
  my @packages; # ...minus aliases
  
  # Traverse the packages
  my(@stack) = ('main::');
  while(@stack) {
    no strict 'refs';
    my $pkg = shift @stack;
    print "Hitting $pkg...\n" if $Debug;
    
    my $pr = \%{$pkg};
    if($packageref_seen{$pr}) {
      print "$pkg is an alias to ",
        join (' = ', @{$packageref_seen{$pr}}), "\n" if $Debug;
      push @{$packageref_seen{$pr}}, $pkg;
      next;
    } else {
      $packageref_seen{$pr} = [$pkg];
      print "Knowing $pr = $pkg\n" if $Debug;
      push @packages, $pkg;
    }
    
    
    print "Symbol-considering package $pkg\n" if $Debug;
    if(@{$pkg . 'ISA'}) {
      $package_has_code{$pkg} = 1;
    }
    
    my $cr;
    foreach my $symbol (sort keys %{$pkg}) {
      # If it's a subpackage, consider it for traversal
      if($symbol =~ m<::$>s) {
        print "Seeing package symbol $symbol in $pkg\n" if $Debug;
        if($pkg eq 'main::') {
          unless($symbol eq 'main::') {
            push @stack, $symbol;
             # Call package Foo as "Foo::", not "main::Foo::".
            print "To traverse $symbol\n" if $Debug;
          } else {
            # And don't call main:: at all (anymore).
            print "Ignoring main::main\n" if $Debug;
          }
        } else {
          print "To traverse $pkg$symbol\n" if $Debug;
          push @stack, $pkg . $symbol;
        }
        print "Stack: @stack\n" if $Debug;
        next;
      }
      
      next unless defined($cr = *{$pkg . $symbol}{CODE});
      print "Seeing \&$pkg$symbol < $cr\n" if $Debug;
      $package_has_code{$pkg} = 1;
      push
        @{
          $coderef2names{ $cr } ||= []
        },
        $pkg . $symbol
      ;
    } # end foreach my $symbol
  } # end while @stack
  
  
  # Now output things...
  
  if($mode_a) {
    @classes_to_see = keys %package_has_code;
    print "-a mode\n" if $Debug;
  } elsif($mode_A) {
    @classes_to_see = @packages;
    print "-A mode\n" if $Debug;
  } else {
    foreach my $c (@classes_to_see) {
      $c .= '::' unless $c =~ m<::$>s;
    }
    my %to_see;
    @to_see{@classes_to_see} = ();
    
    my @ancestors;
    foreach my $c (@classes_to_see) {
      no strict 'refs';
      my $this;
      foreach my $anc (@{$c . 'ISA'}) {
        next unless defined $anc and length $anc;
        $this = $anc;
        $this .= '::' unless $this =~ m<::$>s;
        push @ancestors, $this unless $to_see{$this};
      }
    }
    push @classes_to_see, @ancestors;
    push @classes_to_see, 'UNIVERSAL::'
     if $package_has_code{'UNIVERSAL::'}
     and not grep $_ eq 'UNIVERSAL::', @classes_to_see;
  }
  
  
  my %dumped_pr;
  foreach my $pkg (@classes_to_see) {
    print "Mentioning $pkg...\n" if $Debug;
    no strict 'refs';
    my $p_aliases = $packageref_seen{ \%{$pkg} } || die "$pkg " . \%{$pkg} . " unknown??";
    
    next if $dumped_pr{$p_aliases}++;
    
    if(@$p_aliases == 1) {
      print substr($pkg,0,-2); # strip final ::
    } else {
      print join(' = ', map substr($_,0,-2),
        $pkg, # put it first
        grep {; $_ ne $pkg} @$p_aliases
        
      );
    }
    
    print ' v', ${$pkg . 'VERSION'} if defined ${$pkg . 'VERSION'};
    if(@{$pkg . 'ISA'}) {
      print " ISA (", join(', ', @{$pkg . 'ISA'}), ")"
    }
    
    my($cr, $c_aliases);
    my @items;
    foreach my $symbol (sort {lc($a) cmp lc($b) or $a cmp $b} keys %{$pkg}) {
      print "Noting $pkg$symbol\n" if $Debug;
      next unless defined($cr = *{$pkg . $symbol}{CODE});
      $c_aliases = $coderef2names{ $cr };
      my $suffix;
      my $proto = prototype($pkg . $symbol);
      if(defined($proto)) {
        $suffix = '(' . $proto . ')';
      } else {
        $suffix = '';
      }
      if(@$c_aliases == 1) {
        push @items, $symbol . "$suffix,"
      } else {
        push @items,
          join(' = \&' ,
            # move it to front of alias list
            "$symbol$suffix",
            grep
              {; $_ ne ($pkg . $symbol)}
              @$c_aliases
          )
          . ','
        ;
      }
    }
    
    # very simple wrapping logic
    if(@items) {
      my $col = $Cols + 1;
      foreach my $i (@items) {
        #print "<$i>\n";
        if($i =~ m/=/) { # an alias is always its own line
          print "\n    " . $i . " ";
          $col = $Cols + 1;
        } elsif($Cols < ($col += (1 + length($i)))) {
          print "\n    " . $i . " ";
          $col = 4 + length($i);
        } else {
          print $i . " ";
        }
      }
      print "\n"; # always the right thing to do
    } else {
      print "\n";
    }
    
    print "\n";
    
  }
};
$::class_inspector->(@ARGV);
# But leaves it around as a defined symbol, so we can use it
# from the debugger, if we like.