#!/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 to print the proper name for Perl libraries.

# 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 lines in the file which match the pattern

#      (m/^\s*\$VERSION\s*=\s+/)

# then these are taken to be the version numbers of the modules.

# Special care is taken with a few known idioms for specifying version

# numbers of files under rcs/cvs control.

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

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

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

# file and are printed as well.

my $perl_prov ="__SCL_NAME__";

if ("@ARGV") {

  foreach (@ARGV) {

    process_file($_);

  }

} else {

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

  # contents of the file.

  foreach (<>) {

    process_file($_);

  }

}

foreach $module (sort keys %require) {

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

    print "$perl_prov($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_prov($module) = $require{$module}\n";

  }

}

exit 0;

sub process_file {

  my ($file) = @_;

  chomp $file;

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

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

    return;

  }

  my ($package, $version, $incomment, $inover) = ();

  while (<FILE>) {

    # 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 (m/^=(head[1-4]|pod|for|item)/) {

      $incomment = 1;

    }

    if (m/^=(cut)/) {

      $incomment = 0;

      $inover = 0;

    }

    if (m/^=(over)/) {

      $inover = 1;

    }

    if (m/^=(back)/) {

      $inover = 0;

    }

    if ($incomment || $inover) {

      next;

    }

    # skip the data section

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

      last;

    }

    # not everyone puts the package name of the file as the first

    # package name so we report all namespaces except some common

    # false positives as if they were provided packages (really ugly).

    if (m/^\s*package\s+([_:a-zA-Z0-9]+)\s*v?([0-9._]+)?\s*;/) {

      $package = $1;

      $version = defined($2) ? $2 : undef;

      if ($package eq 'main') {

        undef $package;

        undef $version;

      } else {

        # If $package already exists in the $require hash, it means

        # the package definition is broken up over multiple blocks.

        # In that case, don't stomp a previous $VERSION we might have

        # found.  (See BZ#214496.)

        $require{$package} = $version unless (exists $require{$package});

      }

    }

    # after we found the package name take the first assignment to

    # $VERSION as the version number. Exporter requires that the

    # variable be called VERSION so we are safe.

    # here are examples of VERSION lines from the perl distribution

    #FindBin.pm:$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);

    #ExtUtils/Install.pm:$VERSION = substr q$Revision: 1.9 $, 10;

    #CGI/Apache.pm:$VERSION = (qw$Revision: 1.9 $)[1];

    #DynaLoader.pm:$VERSION = $VERSION = "1.03";     # avoid typo warning

    #General.pm:$Config::General::VERSION = 2.33;

    #

    # or with the new "our" pragma you could (read will) see:

    #

    #    our $VERSION = '1.00'

    if ($package && m/^\s*(our\s+)?\$(\Q$package\E::)?VERSION\s*=[^=~>]\s*/) {

      # first see if the version string contains the string

      # '$Revision' this often causes bizarre strings and is the most

      # common method of non static numbering.

      if (m/\$Revision: (\d+[.0-9]+)/) {

        $version = $1;

      } elsif (m/\b['"]?v?(\d+(?:\.[.0-9]+)?)(_\d*|[a-zA-Z]*)?['"]?\b/) {

        # look for a static number hard coded in the script

        $version = $1;

      }

      $require{$package} = $version;

    }

    # Allow someone to have a variable that defines virtual packages

    # The variable is called $RPM_Provides.  It must be scoped with

    # "our", but not "local" or "my" (just would not make sense).

    #

    # For instance:

    #

    #     $RPM_Provides = "blah bleah"

    #

    # Will generate provides for "blah" and "bleah".

    #

    # Each keyword can appear multiple times.  Don't

    #  bother with datastructures to store these strings,

    #  if we need to print it print it now.

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

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

        print "$_\n";

      }

    }

  }

  close(FILE) ||

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

  return;

}