perl.req

#!/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 to all non provided by the file
  foreach my $moduler (sort keys %require) {
    if (exists $provide{$moduler} && length($require{$moduler}) == 0) {
      $require = delete $require{$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;
    }
  }
# remove all local requires and provides
  undef %require;
  undef %provide;
}

sub add_perlreq {
  my ($newver) = @_;

  if (%perlreq) {
    my ($oldver) = keys %perlreq;
    if (eval "v$oldver" lt eval "v$newver") {
      delete $perlreq{$oldver};
      $perlreq{$newver} = 1;
    }
  } else {
    $perlreq{$newver} = 1;
  }
}

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 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
         (?:BEGIN\s*\{\s*)? # but we accept an optional BEGIN { as used in Module::Loaded
         (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.
      # BEGIN {require './t/lifecycles/utils.pl'};

      ($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/\//::/g && $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) {
          add_perlreq("$rpm_ver");
          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" || $module eq "aliased")) {
        add_require($module, $version);
        if (defined($list) && $list ne "") {
          add_require($_, undef) for split(' ', $list);
        }
        next;
      }
      # use parent -norequire, 'No::Version'; # $params == "-norequire,"
      # use parent qw/-norequire XML::XPath::Node/; # $list == "-norequire XML::XPath::Node"
      if ($statement eq "use" && $module eq "parent") {
        add_require($module, $version);
        if (defined($list) && $list ne "" && $list !~ /-norequire/ && $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);

  $file =~ s/'/'"'"'/g;
  my @result = readpipe( "$prov_script '$file'" );
  foreach my $prov (@result) {
    $provide{$1} = undef if $prov =~ /perl\(([_:a-zA-Z0-9]+)\)/;
  }

}