#!/usr/bin/perl

# This is free software.  You may redistribute copies of it under the terms of

# the GNU General Public License <http://www.gnu.org/licenses/gpl.html>.

# There is NO WARRANTY, to the extent permitted by law.

# This script was originally written by Ken Estes Mail.com

# kestes@staff.mail.com

# a simple script used to generate dependencies of Perl modules and scripts.

# It does not parse the perl grammar but instead just lex it looking for

# what we want. It takes special care to ignore comments and pod's.

# The filenames to scan are either passed on the command line or if

# that is empty they are passed via stdin.

# If there are strings in the file which match the pattern

#     m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i

# then these are treated as additional names which are required by the

# file and are printed as well.

my $perl_ns = "__PERL_NS__";

$HAVE_VERSION = 0;

eval { require version; $HAVE_VERSION = 1; };

use Fedora::VSP ();

use File::Basename;

my $dir = dirname($0);

$HAVE_PROV = 0;

if ( -e "$dir/perl.prov" ) {

  $HAVE_PROV = 1;

  $prov_script = "$dir/perl.prov";

}

if ("@ARGV") {

  foreach my $file (@ARGV) {

    process_file($file);

    process_file_provides($file);

    compute_global_requires();

  }

} else {

  # notice we are passed a list of filenames NOT as common in unix the

  # contents of the file.

  foreach my $file (<>) {

    process_file($file);

    process_file_provides($file);

    compute_global_requires();

  }

}

foreach $perlver (sort keys %perlreq) {

  print "$perl_ns(:VERSION) >= $perlver\n";

}

foreach my $module (sort keys %global_require) {

  if (length($global_require{$module}) == 0) {

    print "$perl_ns($module)\n";

  } else {

    # I am not using rpm3.0 so I do not want spaces around my

    # operators. Also I will need to change the processing of the

    # $RPM_* variable when I upgrade.

    print "$perl_ns($module) >= $global_require{$module}\n";

  }

}

exit 0;

sub compute_global_requires {

# restrict require_removable to all non provided by the file

  foreach my $moduler (sort keys %require_removable) {

    if (exists $provide{$moduler} && length($require_removable{$moduler}) == 0) {

      $require_removable = delete $require_removable{$moduler};

    } 

  }

# store requires to global_requires

  foreach my $module (sort keys %require) {

    my $oldver = $global_require{$module};

    my $newver = $require{$module};

    if ($oldver) {

      $global_require{$module} = $newver

        if ($HAVE_VERSION && $newver && version->new($oldver) < $newver);

    } else {

      $global_require{$module} = $newver;

    }

  }

# store requires_removable to global_requires

  foreach my $module (sort keys %require_removable) {

    my $oldver = $global_require{$module};

    my $newver = $require_removable{$module};

    if ($oldver) {

      $global_require{$module} = $newver

        if ($HAVE_VERSION && $newver && version->new($oldver) < $newver);

    } else {

      $global_require{$module} = $newver;

    }

  }

# remove all local requires and provides

  undef %require;

  undef %require_removable;

  undef %provide;

}

sub add_require {

  my ($module, $newver) = @_;

  # __EXAMPLE__ is not valid requirement

  return if ($module =~ m/^__[A-Z]+__$/o);

  # To prevent that module does not end with '::'

  # Example:  use base Object::Event::;

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

  my $oldver = $require{$module};

  if ($oldver) {

    $require{$module} = $newver

      if ($HAVE_VERSION && $newver && version->new($oldver) < $newver);

  }

  else {

    $require{$module} = $newver;

  }

}

sub add_require_removable {

  my ($module, $newver) = @_;

  # __EXAMPLE__ is not valid requirement

  return if ($module =~ m/^__[A-Z]+__$/o);

  # To prevent that module does not end with '::'

  # Example:  use base Object::Event::;

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

  my $oldver = $require_removable{$module};

  if ($oldver) {

    $require_removable{$module} = $newver

      if ($HAVE_VERSION && $newver && version->new($oldver) < $newver);

  }

  else {

    $require_removable{$module} = $newver;

  }

}

sub process_file {

  my ($file) = @_;

  chomp $file;

  if (!open(FILE, $file)) {

    warn("$0: Warning: Could not open file '$file' for reading: $!\n");

    return;

  }

  while (<FILE>) {

    # skip the here-docs "<<" blocks

    # assume that <<12 means bitwise operation

    if (((m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<[\\]?(\w+)\s*/ &&

          ($1 !~ m/^\d+$/)) ||

         m/^\s*(?:'[^']*?'|"[^"]*?"|[^"'#]*?)*?[^"'#<@]<<\s*('[^']*?'|"[^"]*?"|`[^`]*?`)\s*/

        ) &&

         ! m/q[qxwr]?\s*[{([#|!\/][^})\]#|!\/]*?<<[^<]/

       ) {

      $tag = $1;

      $tag =~ s/['"`]//g;

      if ($_ =~ m/^\s*use\s(constant)\s/) { add_require($1, undef) }

      while (<FILE>) {

        chomp;

        ( $_ eq $tag ) && last;

      }

      $_ = <FILE>;

    }

    # skip q{} quoted sections - just hope we don't have curly brackets

    # within the quote, nor an escaped hash mark that isn't a comment

    # marker, such as occurs right here. Draw the line somewhere.

    if ( m/^.*\Wq[qxwr]?\s*([{([#|!\/])[^})\]#|!\/]*$/ && ! m/^\s*(require|use)\s/ ) {

      $tag = $1;

      $tag =~ tr/{\(\[\#|!\//})]#|!\//;

      $tag = quotemeta($tag);

      while (<FILE>) {

        ( $_ =~ m/$tag/ ) && last;

      }

    }

    # skip the documentation

    # we should not need to have item in this if statement (it

    # properly belongs in the over/back section) but people do not

    # read the perldoc.

    if (/^=(head[1-4]|pod|for|item)/) {

      /^=cut/ && next while <FILE>;

    }

    if (/^=over/) {

      /^=back/ && next while <FILE>;

    }

    # skip the data section

    if (m/^__(DATA|END)__$/) {

      last;

    }

    # Each keyword can appear multiple times.  Don't

    #  bother with datastructures to store these strings,

    #  if we need to print it print it now.

    #

        # Again allow for "our".

    if (m/^\s*(our\s+)?\$RPM_Requires\s*=\s*["'](.*)['"]/i) {

      foreach $_ (split(/\s+/, $2)) {

        print "$_\n";

      }

    }

    my $modver_re = qr/[.0-9]+/;

    my $begin_re = qr#qw\s*[(\/'"!|{\[]\s*|qq?\s*[(\/'"!|{\[]\s*|['"]#;

    my $end_re   = qr#[)\/"'!|}\]]#;

    # Skip multiline print and assign statements

    if ( m/\$\S+\s*=\s*(")([^"\\]|(\\.))*$/ ||

         m/\$\S+\s*=\s*(')([^'\\]|(\\.))*$/ ||

         m/print\s+(")([^"\\]|(\\.))*$/ ||

         m/print\s+(')([^'\\]|(\\.))*$/ ) {

        my $quote = $1;

        while (<FILE>) {

          m/^([^\\$quote]|(\\.))*$quote/ && last;

        }

        $_ = <FILE>;

    }

    if (

# ouch could be in a eval, perhaps we do not want these since we catch

# an exception they must not be required

#   eval { require Term::ReadLine } or die $@;

#   eval "require Term::Rendezvous;" or die $@;

#   eval { require Carp } if defined $^S; # If error/warning during compilation,

        (m/^(\s*)         # we hope the inclusion starts the line

         (require|use)\s+(?!\{)     # do not want 'do {' loops

         # quotes around name are always legal

         (?:$begin_re?\s*([\w:\/\.]+?)\s*$end_re?|

            ([\w:\.]+?))[^\w]*?

         [\t; \n]

         # the syntax for 'use' allows version requirements

         \s*($modver_re)?\s*

         # catch parameter like '-norequire,'

         (-[\w,]+)?\s*

         # the latter part is for "use base qw(Foo)" and friends special case

         (?:$begin_re\s*

          ([^)\/"'\$!|}]*?)

          \s*$end_re|

          (?:qw<|qq?<)([^>]*?)>|([\w\:]+)|)\s*(.*)

         /x)

       ) {

      my ($whitespace, $statement, $module, $version, $params, $list, $rest) = ($1, $2, $3, $5, $6, $7 || $8 || $9, $10);

      $version = undef if ($version eq '');

      # Ignore line which contains direct method calls

      # use base __PACKAGE__->subroutine(...);

      $list = "" if ($list =~ /^[^;#]*?->/ || $rest =~ /^[^;#]*?->/);

      #

      # Executed in case that multiline q{} quoted sections is used for

      # list of modules

      if (defined($list) && $list =~ /^q[qxwr]?$/) {

        $list = "";

        if ($rest =~ m/^\s*([{([#|!\/])\s*([^})\]#|!\/]*)$/) {

          $tag  = $1;

          $list = $2;

          chomp($list);

          $tag  =~ tr/{\(\[\#|!\//})]#|!\//;

          $tag  = quotemeta($tag);

          while (<FILE>) {

            my $line = $_;

            chomp($line);

            if ($line =~ m/^\s*(.*?)$tag/) {

              $list .= ' ' . $1 if ($1 ne '');

              last;

            } else { $list .= ' ' . $line; }

          }

        }

      }

      # we only consider require statements that are flushed against

      # the left edge. any other require statements give too many

      # false positives, as they are usually inside of an if statement

      # as a fallback module or a rarely used option

      ($whitespace ne "" && $statement eq "require") && next;

      # if there is some interpolation of variables just skip this

      # dependency, we do not want

      #        do "$ENV{LOGDIR}/$rcfile";

      ($module =~ m/\$/) && next;

      # ignore variables

      ($module =~ m/^\s*[\$%@\*]/) && next;

      # skip if the phrase was "use of" -- shows up in gimp-perl, et al.

      next if $module eq 'of';

      # if the module ends in a comma we probably caught some

      # documentation of the form 'check stuff,\n do stuff, clean

      # stuff.' there are several of these in the perl distribution

      ($module  =~ m/[,>]$/) && next;

      # if the module name starts in a dot it is not a module name.

      # Is this necessary?  Please give me an example if you turn this

      # back on.

      #      ($module =~ m/^\./) && next;

      # if the module starts with /, it is an absolute path to a file

      if ($module =~ m(^/)) {

        print "$module\n";

        next;

      }

      # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc.

      # we can strip qw.*$, as well as (.*$:

      $module =~ s/qw.*$//;

      $module =~ s/\(.*$//;

      # if the module ends with .pm, strip it to leave only basename.

      # .pm files are not accepted by 'use'

      ($module =~ s/\.pm$// && $statement eq 'use' ) && next;

      # some perl programmers write 'require URI/URL;' when

      # they mean 'require URI::URL;'

      ($module =~ s/\//::/ && $statement eq 'use' ) && next;

      # trim off trailing parentheses if any.  Sometimes people pass

      # the module an empty list.

      $module =~ s/\(\s*\)$//;

      if ( $module =~ m/^(v?[0-9._]+)$/ ) {

        # if module is a number then both require and use interpret that

        # to mean that a particular version of perl is specified

        my $rpm_ver = Fedora::VSP::vsp($1);

        if (defined $rpm_ver) {

          $perlreq{"$rpm_ver"} = 1;

          next;

        }

      };

      # ph files do not use the package name inside the file.

      # perlmodlib documentation says:

      #       the .ph files made by h2ph will probably end up as

      #       extension modules made by h2xs.

      # so do not expend much effort on these.

      # there is no easy way to find out if a file named systeminfo.ph

      # will be included with the name sys/systeminfo.ph so only use the

      # basename of *.ph files

      ($module =~ m/\.ph$/) && next;

      # use base|parent qw(Foo) dependencies

      # use aliased qw(Foo::Bar) dependencies

      if ($statement eq "use" && $module eq "base") {

        add_require($module, $version);

        if (defined($list) && $list ne "") {

          add_require_removable($_, undef) for split(' ', $list);

        }

        next;

      }

      if ($statement eq "use" && $module eq "aliased") {

        add_require($module, $version);

        if (defined($list) && $list ne "") {

          add_require($_, undef) for split(' ', $list);

        }

        next;

      }

      if ($statement eq "use" && $module eq "parent") {

        add_require($module, $version);

        if (defined($list) && $list ne "" && $params !~ /-norequire/) {

          add_require($_, undef) for split(' ', $list);

        }

        next;

      }

      # use Any::Moose dependencies

      # Mouse or Mouse::Role will be added

      if ($statement eq "use" && $module eq "Any::Moose") {

        add_require($module, $version);

        if (defined($list) && $list ne "") {

          if (grep { !/^Role$/ } split(' ', $list)) {

            add_require('Mouse::Role', undef);

          } else {

            add_require('Mouse', undef);

          }

        } else {

          add_require('Mouse', undef);

        }

        next;

      }

      add_require($module, $version);

    } # use|require regex

  } # while (<FILE>)

  close(FILE) ||

    die("$0: Could not close file: '$file' : $!\n");

  return;

}

sub process_file_provides {

  my ($file) = @_;

  chomp $file;

  return if (! $HAVE_PROV);

  my @result = readpipe( "$prov_script $file" );

  foreach my $prov (@result) {

    $provide{$1} = undef if $prov =~ /perl\(([_:a-zA-Z0-9]+)\)/;

  }

}