#!/usr/bin/perl -w 
use strict;
use Getopt::Long;

my %hash;    # initialise local variables
$hash{HELP}     = 0;
$hash{MODCOUNT} = 0;
$hash{SUBCOUNT} = 0;
$hash{EXPCOUNT} = 0;
$hash{DEBUG}    = 0;
$hash{INFO}     = 0;
my ( @moduleDirs, $dir );

GetOptions(    ## process options
  "-help"  => \$hash{HELP},
  "-debug" => \$hash{DEBUG},
  "-info"  => \$hash{INFO},
  "-dir=s" => \@moduleDirs,
);

processModulesInDirectories( \%hash, \@moduleDirs );    # get sub and exported subs! Check exported subs exist!

processModulesAgainstSubRoutines( \%hash, \@moduleDirs );    # find all calls of exported subroutines

printInfo( \%hash ) if $hash{INFO};                          # print the function usage!

print_hash_contents( \%hash, *STDOUT ) if $hash{DEBUG};      # Print to STDOUT

##----------------------------- Subroutines!
sub printInfo {
  my ($hash) = @_;

  foreach my $module ( keys( %{ $$hash{MODULE} } ) ) {       # get each module
    print "--- $module\n";
    foreach my $subroutine ( keys( %{ $$hash{MODULE}{$module}{EXP} } ) ) {    # then get it subroutines
      print "------ $$hash{MODULE}{$module}{EXP}{$subroutine} $subroutine {";
      foreach my $called ( keys( %{ $$hash{MODULE}{$module}{SUB}{USED}{$subroutine} } ) ) {
        print "$called ";
      }
      print "}\n";
    }
  }
}

sub getDirContents {
  my ($dir) = @_;
  my @files;
  if ( -e $dir ) {
    my $status = opendir( BASEDIR, $dir ) or die "Cannot open directory $dir\n";
    @files = readdir(BASEDIR);
    close(BASEDIR);
  }
  return @files;
}

sub processModule {
  my ($file) = @_;
  my $string = "";
  open( FILE, "$file" ) or warn "Could not open $file, in getFileCOntents\n";
  my $ignore = 0;
  while (<FILE>) {
    if (m/^=cut/) {
      $ignore = 0;
    } elsif (m/^=/) {
      $ignore = 1;
    }
    if ( !$ignore ) {
      s/\#.*$//g;                      ## remove all the s**t!
      s/^\s*sub\s+/ subSUBsubSub /;    ## ease sub detection
      chomp;
      $string = $string . " " . $_;    # breathing space
    }
  }
  close(FILE);

  return $string;
}

sub processModulesInDirectories {
  my ( $hash, $moduleDirs ) = @_;
  ## Get a list of all the subroutines from each perl module, keep a track of the exported subs as well!
  print "--Processing modules in subdirectories!\n";
  my $dir;
  foreach $dir (@moduleDirs) {
    if ( -e $dir ) {

      foreach my $file ( getDirContents($dir) ) {
        if ( $file =~ /pm$/ ) {
          $$hash{MODCOUNT}++;
          my $contents = processModule("$dir/$file");                                  # get module contents!
          my @subs = ( $contents =~ m/subSUBsubSub\s+([a-zA-Z\-_0-9]+)(?:{|\s)/g );    # get subroutines
          foreach (@subs) {

            #            print "MODULE}{$file}{SUB}{$_\n";
            $$hash{MODULE}{$file}{SUB}{$_} = 0;
            $$hash{SUBCOUNT}++;
          }

          my $match = $contents =~ m/\@EXPORT\s+=\s+qw\s*\(\s*([^\)]+)/;               # get export list
          if ($match) {
            my @exported = split /\s+/, $1;
            foreach (@exported) {

              #            print "MODULE}{$file}{EXP}{$_\n";
              $$hash{EXPCOUNT}++;
              $$hash{MODULE}{$file}{EXP}{$_} = 0;
              if ( !exists $$hash{MODULE}{$file}{SUB}{$_} ) {
                print("Warning - $_ is exported from $file but is not defined as a subroutine!\n");
              }
            }
          }
        }
      }
    }
  }
  print "\n--Found $$hash{MODCOUNT} modules, $$hash{SUBCOUNT} subroutines with $$hash{EXPCOUNT} exported.\n\n";
}

sub processModulesAgainstSubRoutines {
  my ( $hash, $moduleDirs ) = @_;
  print "--Re reading each module searching for subroutines!\n";

  foreach my $module ( keys( %{ $$hash{MODULE} } ) ) {    # get each module
    foreach my $subroutine ( keys( %{ $$hash{MODULE}{$module}{SUB} } ) ) {    # then get it subroutines
      foreach my $dir (@moduleDirs) {
        if ( -e $dir ) {
          foreach my $file ( getDirContents($dir) ) {    # now we iterate back through every file, looking for this subroutine
            if ( ( $file =~ /pm$/ ) and ( $file ne $module ) ) {    # did we find the subroutine
              my $contents = processModule("$dir/$file");           # get module contents!
              my @array    = ( $contents =~ m/$subroutine/g );
              my $count    = @array;
              if ( $count > 0 ) {
                $$hash{MODULE}{$module}{SUB}{USED}{$subroutine}{$file} = $count;    # store calls in that module
                if ( !exists( $$hash{MODULE}{$module}{EXP}{$subroutine} ) ) {
                  print "--Warning $subroutine used in $file but not exported by $module\n";
                } else {
                  $$hash{MODULE}{$module}{EXP}{$subroutine} += $count;              # track total calls of subroutine
                }
              }
            }
          }
        }
      }
    }
  }
}

##------------------------------------------------------------------------------
## recursive hash print...You must pass references to this function, its easy
## just the \
## print_hash_contents(\%hash,\"out.txt"); # Print to a file called out.txt
## print_hash_contents(\%hash,*STDOUT   ); # Print to STDOUT
##------------------------------------------------------------------------------
sub print_hash_contents {
  my ( $hash, $ofile ) = @_;
  my $write_to_file = 0;
  if ( $ofile !~ /STDOUT/ ) {
    open( OUTFILE, ">$$ofile" ) or die "Cannot open $$ofile\n";
    print("print_hash_contents redirected to \"$$ofile\"\n");
    $write_to_file = 1;
    $ofile         = *OUTFILE;
  } else {
    print("##-------------------------------------------------------------\n");
  }
  my @array = ();
  while ( ( my $key, my $value ) = each %{$hash} ) {
    push @array, $key;
    tunnel_hash( $$hash{$key}, 1, \@array, $ofile );
    pop @array;
  }
  close(OUTFILE) if $write_to_file;
}

sub tunnel_hash {
  use strict;
  my ( $match, $depth, $array, $ofile ) = @_;
  return unless ref $match eq 'HASH';
  foreach my $key2 ( keys %{$match} ) {
    push @$array, $key2;
    tunnel_hash( $match->{$key2}, $depth + 1, $array, $ofile );
    if ( $match->{$key2} !~ /HASH/ ) {
      print( $ofile "\$\$hash" );
      print( $ofile "{$_}" ) foreach (@$array);
      if ( $match->{$key2} =~ /[a-zA-Z]/ ) {
        print $ofile " = \"$match->{$key2}\";\n";
      } else {
        print $ofile " = $match->{$key2};\n";
      }
    }
    pop @$array;
  }
}