#!/usr/bin/perl -w
#
# getdep.pl -- iterates through perl programs looking for perl module and
#              program dependencies.
#

use strict;

######################
# global variables
######################

# for pretty output
my $level = 0;

# paths to look for bianries
my @path = ();

# list of ignored perl modules
my @ignpm = qw(
   Class::Struct
   constant
   integer
   Math::BigInt
   Math::BigFloat
   Math::Complex
   Math::Trig
   overload
   Symbol
   Time::Local
   Search::Dict
   Text::Abbrev
   Text::ParseWords
   Text::Soundex
   Text::Tabs
   Text::Wrap
   Getopt::Long
   Getopt::Std
   Cwd
   File::Basename
   File::CheckTree
   File::Compare
   File::Copy
   File::Copy
   File::DosGlob
   File::Find
   File::Path
   File::Spec
   File::Spec::Functions
   File::Spec::Mac
   File::Spec::OS2
   File::Spec::Unix
   File::Spec::VMS
   File::Spec::Win32
   File::stat
   DirHandle
   FileCache
   FileHandle
   IO
   IO::Dir
   IO::File
   IO::Handle
   IO::Pipe
   IO::Poll
   IO::Seekable
   IO::Select
   SelectSaver
   bytes
   charnames
   I18N::Collate
   local
   utf8
   Fcntl
   filetest
   open
   POSIX
   Shell
   sigtrap
   Sys::Syslog
   Time::gntime
   Time::tm
   User::grent
   User::pwent
   IO::Socket
   IO::Socket::INET
   IO::Socket::UNIX
   IPC::Msg
   IPC::Open2
   IPC::Open3
   IPC::Semaphore
   IPC::SysV
   Net::hostent
   Net::netent
   Net::Ping
   Net::protoent
   Net::servent
   Socket
   CGI
   CGI::Apache
   CGI::Carp
   CGI::Cookie
   CGI::Fast
   CGI::Pretty
   CGI::Push
   AnyDBM_File
   DB_File
   GDBM_File
   NDBM_File
   SDBM_File
   Term::Cap
   Term::Complete
   Term::ReadLine
   Opcode
   ops
   Safe
   attributes
   attrs
   base
   Data::Dumper
   DB
   Devel::DProf
   Devel::Peek
   diagnostics
   Dumpvalue
   English
   Env
   Errno
   Fatal
   fields
   less
   re
   strict
   subs
   vars
   Tie::Aray
   Tie::Handle
   Tie::Hash
   Tie::ReHash
   Tie::Scalar
   Tie::SubstrHash
   UNIVERSAL
   Carp
   warnings
   Pod::Checker
   Pod::Functions
   Pod::Html
   Pod::Input::Objects
   Pod::Man
   Pod::Parser
   Pod::Select
   Pod::Text
   Pod::Text::Color
   Pod::Text::Termcap
   Pod::Usage
   AutoLoader
   AutoSplit
   autouse
   blib
   Config
   CPAN
   Devel::SelfStubber
   DynaLoader
   Exporter
   ExtUtils::Command
   ExtUtils::Ember
   ExtUtils::Install
   ExtUtils::Installed
   ExtUtils::Liblist
   ExtUtils::MakeMaker
   ExtUtils::Manifest
   ExtUtils::Miniperl
   ExtUtils::Mkbootstrap
   ExtUtils::Mksymlists
   ExtUtils::MM_Cygwin
   ExtUtils::MM_OS2
   ExtUtils::MM_Unix
   ExtUtils::MM_VMS
   ExtUtils::MM_Win32
   ExtUtils::Packlist
   ExtUtils::testlib
   FindBind
   lib
   SelfLoader
   XSLoader
   Benchmark
   Test
   Test::Harness
   B
   B::Asmdata
   B::Assembler
   B::Bblock
   B::C
   B::CC
   B::Debug
   B::Deparse
   B::Disassembler
   B::Lint
   B::Showlex
   B::Stash
   B::Terse
   B::Xref
   ByteLoader
   O
);

############################
# subroutines
############################

# displays output with proper spacing 
sub _output {
   my $msg = shift;
   print ' 'x$level.$msg."\n";
}

# increment spacing
sub _incLevel {
   $level += 2;
}

# decrement spacing
sub _decLevel {
   $level -=2 unless $level < 2;
}

# appends additional perl module include dirs
sub _buildINC {
   my @argv = ();

   foreach (@ARGV)
   {
      # add stuff to @INC?
      unless(/^-M(.*)$/)
      {
         # not an include, add to new arg list
         push @argv, $_;
         next;
      }

      # skip empty -I
      next if($1 eq '');

      # check if already in @INC
      next if(grep(/^$1$/, @INC));

      # nope, add it
      push @INC, $1;
   }

   # replace @ARGV 
   @ARGV = @argv;
}

# builds a set of paths to look through for binaries on disk
sub _buildPATH {
   my @argv = ();

   my $env = $ENV{PATH};

   # find @path elements
   foreach (@ARGV)
   {
      # add stuff to @path?
      unless(/^-P(.*)$/)
      {
         # not a path include, add to new arg list
         push @argv, $_;
         next;
      }

      # skip empty -P
      next if($1 eq '');

      # append to our envpath
      $env .= ":$1";
   }

   # replace @ARGV
   @ARGV = @argv;

   # create @path
   my @env = split(/:/, $env);

   foreach my $env (@env)
   {
      # check if already in @path
      next if grep(/^$env$/, @path);

      push @path, $env;
   }
}

# given a module name, returns the full path to the module.  undef if not fnd
sub _searchPM {
   my $module = shift;
   my $path;

   $module =~ s/::/\//;

   foreach my $dir (@INC)
   {
      #print "using pm dir: $dir ($dir/$module.pm)\n";
      if(-e "$dir/$module.pm")
      {
         $path = "$dir/$module.pm";
         last;
      }
   }

   return $path;
}

# parses through a perl module looking for dependencies
sub _getdepPM {
   my $module = shift;
   my $pm = _searchPM($module);

   return undef unless defined $pm;

   #print "getting dep for pm $pm\n";
   _getdep($pm);
}

sub _searchBin {
   my $exe = shift;

   # check if local dir
   if($exe =~ m/^\.\//)
   {
      return 1 if -e $exe;
      return undef;
   }
   # full path
   elsif($exe =~ m/^\//)
   {
      return 1 if -e $exe;
      return undef;
   }
   # search for exe in path
   else
   {
      foreach my $dir (@path)
      {
         next unless -e "$dir/$exe";
         return 1;
      }
   }

   return undef;
}

# parses through script looking for dependencies
sub _getdepPL {
   my $fh = shift;
   my $perldoc = 0;

   #print "INC: '@INC'\n";
   _incLevel();

   while(<$fh>)
   {
      chomp;

      #_output("!$_");

      # inside perldoc, skip or end?
      if($perldoc)
      {
         # end of perldoc
         $perldoc = 0 if /^=cut/;
         next;
      }

      # check if we're starting a perldoc (considered comment)
      if(/^=head/) {
         $perldoc = 1;
         next;
      }

      # skip comments
      next if(/^\s*#/);

      # check if line is a Perl module
      if(/^\s*(use|require)\s+([\w\d:\.]+)\s*.*/)
      {
         my $module = $2;
         #print "Found include: $module\n";

         # requiring perl version?
         next if($module =~ /^\d+\./);

         # rip off quotes
         $module =~ s/['"]//g;

         # standard perl module?
         next if(grep(/^$module$/, @ignpm));

         # in @INC?
         my $pm = _searchPM($module);

         if(defined($pm))
         {
            _output("M $module");
            _getdepPM($module);
         }
         else
         {
            _output("m $module");
         }
      }
      # check if line is a system call
      elsif(/system\s*\({0,1}.*\){0,1}/)
      {
         #print "Found system call: $_\n";

         my $fnd = _searchBin($1);

         if(defined($fnd))
         {
            _output("E $1");
         }
         else
         {
            _output("e $1");
         }
      }
      # other type of system call
      elsif(/\`(.*)\`/)
      {
         #print "Found system call (\`): $_\n";

         my $fnd = _searchBin($1);

         if(defined($fnd))
         {
            _output("E $1");
         }
         else
         {
            _output("e $1");
         }
      }
      # open system binary or file
      elsif(/(^|\(|\s+)(open.*)/)
      {
         my ($regex, $flag, $fnd);

         $regex = $2;

         # check if encapsulated in commas
         $flag = $regex =~ m/open\s*\(.*\)(\s*|\;)/ ? 1 : 0;

         if($flag)
         {
            if($regex =~ m/(\,\s*['"][+-><]+['"])*\,\s*(.*)\s*\)/)
            {
               $regex = $2;
#               print "flag: $regex\n";
            }
            else
            {
               print "Unknown open: $2\n";
               last;
            }
         }
         else
         {
            if($regex =~ m/(\,\s*['"][+-><]+['"])*\,\s*(.*)[ ;]/)
            {
               $regex = $2;
#               print "noflag: $regex\n";
            }
            else
            {
               print "Unknown open: $2\n";
               last;
            }
         }

         # test for executable pipe
         $flag = $regex =~ m/\|/ ? 1 : 0;

         # rip off ', "
         $regex =~ s/['"]//g;
         # rip off | and |-
         $regex =~ s/\|\-{0,1}//g;
         # <, >, +>, +<, and <<
         $regex =~ s/^\+{0,1}[><]+//g;

         if($flag)
         {
            $fnd = _searchBin($regex);
            if($fnd)
            {
               _output("E $regex");
            }
            else
            {
               _output("e $regex");
            }
         }
         else
         {
            if(-e $regex)
            {
               _output("F $regex");
            }
            else
            {
               _output("f $regex");
            }
         }
      }
      # open system file
      elsif(/(^|\(|\s+)sysopen\(\w+\,\s*(.*)\s*\,.*\)/)
      {
         if(-e $2)
         {
            _output("F $2");
         }
         else
         {
            _output("f $2");
         }
      }
      else
      {
         #_output("!$_");
      }

   } # end while

   _decLevel();
}

# subroutines
sub _getdep {
   my $file = shift;
   my %dep;
   my $fh;

   unless(open($fh, '<', $file))
   {
      _output("Error: Couldn't open $file: $!");
      return undef;
   }

   _getdepPL($fh);

   close($fh);

   return \%dep;
}

##########################################################################
# main
##########################################################################

sub usage {
   print <<EOU

Usage: getdep.pl [-M dir]... [-P dir]... arg1.pl arg2.pl ... argN.pl
Looks through a list of perl scripts builds a dependency list

Optional arguements
   -M <directory>       Additional perl module directory
   -P <directory>       Additional paths of executables

Note: This is still under developement and will likely never be perfect.  It
      is however, a good starting place.

EOU
}

sub main {
   my $count=0;

   _buildINC();
   _buildPATH();

   if($#ARGV < 0) {
      usage();
      exit 0;
   }

   foreach (@ARGV) {
      _output("$count $_");
      next unless(_getdep($_));
      $count++;
   }

   exit 0;
}

# start the search
main();