openmamba/perl.*,fileattrs/perl*: restore perl auto provides/requires support removed since rpm 4.20

Makefile

@@ -25,13 +25,18 @@ all:
 
 install-dirs:
 	@$(INSTALL_DIR) $(DESTDIR)$(rpmdir)/openmamba
+	@$(INSTALL_DIR) $(DESTDIR)$(rpmdir)/fileattrs
 
 install-data:
 	@$(INSTALL_DATA) openmamba/macros $(DESTDIR)$(rpmdir)/openmamba/macros
 	@$(INSTALL_DATA) openmamba/rpmrc $(DESTDIR)$(rpmdir)/openmamba/rpmrc
+	@$(INSTALL_DATA) fileattrs/perl.attr $(DESTDIR)$(rpmdir)/fileattrs/perl.attr
+	@$(INSTALL_DATA) fileattrs/perllib.attr $(DESTDIR)$(rpmdir)/fileattrs/perllib.attr
 
 install-programs:
 	@$(INSTALL_SCRIPT) openmamba/brp-strip-lto $(DESTDIR)$(rpmdir)/openmamba/brp-strip-lto
+	@$(INSTALL_SCRIPT) openmamba/perl.prov $(DESTDIR)$(rpmdir)/openmamba/perl.prov
+	@$(INSTALL_SCRIPT) openmamba/perl.req $(DESTDIR)$(rpmdir)/openmamba/perl.req
 
 install: install-dirs install-data install-programs
 

fileattrs/perl.attr

@@ -0,0 +1,3 @@
+%__perl_requires	%{_rpmconfigdir}/openmamba/perl.req
+%__perl_magic		^.*[Pp]erl .*$
+%__perl_flags		exeonly

fileattrs/perllib.attr

@@ -0,0 +1,5 @@
+%__perllib_provides	%{_rpmconfigdir}/openmamba/perl.prov
+%__perllib_requires	%{_rpmconfigdir}/openmamba/perl.req
+%__perllib_magic	^Perl[[:digit:]] module source.*
+%__perllib_path		\\.pm$
+%__perllib_flags	magic_and_path

openmamba/perl.prov

@@ -0,0 +1,222 @@
+#!/usr/bin/perl
+
+# RPM (and it's source code) is covered under two separate licenses.
+
+# The entire code base may be distributed under the terms of the GNU
+# General Public License (GPL), which appears immediately below.
+# Alternatively, all of the source code in the lib subdirectory of the
+# RPM source code distribution as well as any code derived from that
+# code may instead be distributed under the GNU Library General Public
+# License (LGPL), at the choice of the distributor. The complete text
+# of the LGPL appears at the bottom of this file.
+
+# This alternative is allowed to enable applications to be linked
+# against the RPM library (commonly called librpm) without forcing
+# such applications to be distributed under the GPL.
+
+# Any questions regarding the licensing of RPM should be addressed to
+# Erik Troan <ewt@redhat.com>.
+
+# a simple script to print the proper name for perl libraries.
+
+# To save development time I do not parse the perl grammar but
+# instead just lex it looking for what I want.  I take special care to
+# ignore comments and pod's.
+
+# it would be much better if perl could tell us the proper name of a
+# given script.
+
+# 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.
+
+# I plan to rewrite this in C so that perl is not required by RPM at
+# build time.
+
+# by Ken Estes Mail.com kestes@staff.mail.com
+
+if ("@ARGV") {
+  foreach (@ARGV) {
+    next if !/\.pm$/;
+    process_file($_);
+  }
+} else {
+
+  # notice we are passed a list of filenames NOT as common in unix the
+  # contents of the file.
+
+  foreach (<>) {
+    next if !/\.pm$/;
+    process_file($_);
+  }
+}
+
+
+foreach $module (sort keys %require) {
+  if (length($require{$module}) == 0) {
+    print "perl($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($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, $inheredoc) = ();
+
+  while (<FILE>) {
+
+    # Skip contents of HEREDOCs
+    if (! defined $inheredoc) {
+      # 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 || m/^\s*#/) {
+        next;
+      }
+
+      # skip the data section
+      if (m/^__(DATA|END)__$/) {
+        last;
+      }
+
+      # Find the start of a HEREDOC
+      if (m/<<\s*[\"\'](\w+)[\"\']\s*;\s*$/) {
+        $inheredoc = $1;
+      }
+    } else {
+      # We're in a HEREDOC; continue until the end of it
+      if (m/^$inheredoc\s*$/) {
+        $inheredoc = undef;
+      }
+      next;
+    }
+
+    # 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 = $2;
+      if ($package eq 'main') {
+        undef $package;
+      } 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/=\s*['"]?(\d+[._0-9]+)['"]?/) {
+
+        # 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";
+      }
+    }
+
+  }
+
+  if (defined $inheredoc) {
+	  die "Unclosed HEREDOC [$inheredoc] in file: '$file'\n";
+  }
+
+  close(FILE) ||
+    die("$0: Could not close file: '$file' : $!\n");
+
+  return;
+}

openmamba/perl.req

@@ -0,0 +1,317 @@
+#!/usr/bin/perl
+
+# RPM (and its source code) is covered under two separate licenses.
+
+# The entire code base may be distributed under the terms of the GNU
+# General Public License (GPL), which appears immediately below.
+# Alternatively, all of the source code in the lib subdirectory of the
+# RPM source code distribution as well as any code derived from that
+# code may instead be distributed under the GNU Library General Public
+# License (LGPL), at the choice of the distributor. The complete text
+# of the LGPL appears at the bottom of this file.
+
+# This alternatively is allowed to enable applications to be linked
+# against the RPM library (commonly called librpm) without forcing
+# such applications to be distributed under the GPL.
+
+# Any questions regarding the licensing of RPM should be addressed to
+# Erik Troan <ewt@redhat.com>.
+
+# a simple makedepend like script for perl.
+
+# To save development time I do not parse the perl grammar but
+# instead just lex it looking for what I want.  I take special care to
+# ignore comments and pod's.
+
+# It would be much better if perl could tell us the dependencies of a
+# given script.
+
+# 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.
+
+# I plan to rewrite this in C so that perl is not required by RPM at
+# build time.
+
+# by Ken Estes Mail.com kestes@staff.mail.com
+
+$HAVE_VERSION = 0;
+eval { require version; $HAVE_VERSION = 1; };
+
+
+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 $perlver (sort keys %perlreq) {
+  print "perl >= $perlver\n";
+}
+foreach $module (sort keys %require) {
+  if (length($require{$module}) == 0) {
+    print "perl($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($module) >= $require{$module}\n";
+  }
+}
+
+exit 0;
+
+
+
+sub add_require {
+  my ($module, $newver) = @_;
+  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 "= <<" block
+
+    if (m/^\s*(?:my\s*)?\$(?:.*)\s*=\s*<<\s*(["'`])(.+?)\1/ ||
+        m/^\s*(?:my\s*)?\$(.*)\s*=\s*<<(\w+)\s*;/) {
+      $tag = $2;
+      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]+/;
+
+    #
+    # The (require|use) match further down in this subroutine will match lines
+    # within a multi-line print or return statements.  So, let's skip over such
+    # statements whose content should not be loading modules anyway. -BEF-
+    #
+    if (m/print(?:\s+|\s+\S+\s+)\<\<\s*(["'`])(.+?)\1/ ||
+        m/print(\s+|\s+\S+\s+)\<\<(\w+)/ ||
+	m/return(\s+)\<\<(\w+)/ ) {
+
+        my $tag = $2;
+        while (<FILE>) {
+            chomp;
+            ( $_ eq $tag ) && last;
+        }
+        $_ = <FILE>;
+    }
+
+    # 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
+         ['"]?([\w:\.\/]+?)['"]?[\t; ]
+         # the syntax for 'use' allows version requirements
+         # the latter part is for "use base qw(Foo)" and friends special case
+         \s*($modver_re|(qw\s*[(\/'"]\s*|['"])[^)\/"'\$]*?\s*[)\/"'])?
+         /x)
+       ) {
+      my ($whitespace, $statement, $module, $version) = ($1, $2, $3, $4);
+
+      # 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;
+
+      # 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.
+      $module =~ s/\.pm$//;
+
+      # some perl programmers write 'require URI/URL;' when
+      # they mean 'require URI::URL;'
+
+      $module =~ s/\//::/;
+
+      # 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 $ver = $1;
+      if ($ver =~ /5.00/) {
+        $perlreq{"0:$ver"} = 1;
+        next;
+      }
+      else {
+        $perlreq{"1:$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
+      if ($statement eq "use" && ($module eq "base" || $module eq "parent")) {
+        add_require($module, undef);
+        if ($version =~ /^qw\s*[(\/'"]\s*([^)\/"']+?)\s*[)\/"']/) {
+          add_require($_, undef) for split(' ', $1);
+        }
+        elsif ($version =~ /(["'])([^"']+)\1/) {
+          add_require($2, undef);
+        }
+        next;
+      }
+      $version = undef unless $version =~ /^$modver_re$/o;
+
+      add_require($module, $version);
+    }
+
+  }
+
+  close(FILE) ||
+    die("$0: Could not close file: '$file' : $!\n");
+
+  return;
+}