scripts/perl.prov

   1 #!/usr/bin/perl
   2
   3 # RPM (and it's source code) is covered under two separate licenses.
   4
   5 # The entire code base may be distributed under the terms of the GNU
   6 # General Public License (GPL), which appears immediately below.
   7 # Alternatively, all of the source code in the lib subdirectory of the
   8 # RPM source code distribution as well as any code derived from that
   9 # code may instead be distributed under the GNU Library General Public
  10 # License (LGPL), at the choice of the distributor. The complete text
  11 # of the LGPL appears at the bottom of this file.
  12
  13 # This alternative is allowed to enable applications to be linked
  14 # against the RPM library (commonly called librpm) without forcing
  15 # such applications to be distributed under the GPL.
  16
  17 # Any questions regarding the licensing of RPM should be addressed to
  18 # Erik Troan <ewt@redhat.com>.
  19
  20 # a simple script to print the proper name for perl libraries.
  21
  22 # To save development time I do not parse the perl grammmar but
  23 # instead just lex it looking for what I want.  I take special care to
  24 # ignore comments and pod's.
  25
  26 # it would be much better if perl could tell us the proper name of a
  27 # given script.
  28
  29 # The filenames to scan are either passed on the command line or if
  30 # that is empty they are passed via stdin.
  31
  32 # If there are lines in the file which match the pattern
  33 #      (m/^\s*\$VERSION\s*=\s+/)
  34 # then these are taken to be the version numbers of the modules.
  35 # Special care is taken with a few known idioms for specifying version
  36 # numbers of files under rcs/cvs control.
  37
  38 # If there are strings in the file which match the pattern
  39 #     m/^\s*\$RPM_Provides\s*=\s*["'](.*)['"]/i
  40 # then these are treated as additional names which are provided by the
  41 # file and are printed as well.
  42
  43 # I plan to rewrite this in C so that perl is not required by RPM at
  44 # build time.
  45
  46 # by Ken Estes Mail.com kestes@staff.mail.com
  47
  48 if ("@ARGV") {
  49   foreach (@ARGV) {
  50     process_file($_);
  51   }
  52 } else {
  53
  54   # notice we are passed a list of filenames NOT as common in unix the
  55   # contents of the file.
  56
  57   foreach (<>) {
  58     process_file($_);
  59   }
  60 }
  61
  62
  63 foreach $module (sort keys %require) {
  64   if (length($require{$module}) == 0) {
  65     print "perl($module)\n";
  66   } else {
  67
  68     # I am not using rpm3.0 so I do not want spaces arround my
  69     # operators. Also I will need to change the processing of the
  70     # $RPM_* variable when I upgrade.
  71
  72     print "perl($module) = $require{$module}\n";
  73   }
  74 }
  75
  76 exit 0;
  77
  78
  79
  80 sub process_file {
  81
  82   my ($file) = @_;
  83   chomp $file;
  84
  85   if (!open(FILE, $file)) {
  86     warn("$0: Warning: Could not open file '$file' for reading: $!\n");
  87     return;
  88   }
  89
  90   my ($package, $version, $incomment, $inover) = ();
  91
  92   while (<FILE>) {
  93
  94     # skip the documentation
  95
  96     # we should not need to have item in this if statement (it
  97     # properly belongs in the over/back section) but people do not
  98     # read the perldoc.
  99
 100     if (m/^=(head[1-4]|pod|for|item)/) {
 101       $incomment = 1;
 102     }
 103
 104     if (m/^=(cut)/) {
 105       $incomment = 0;
 106       $inover = 0;
 107     }
 108
 109     if (m/^=(over)/) {
 110       $inover = 1;
 111     }
 112
 113     if (m/^=(back)/) {
 114       $inover = 0;
 115     }
 116
 117     if ($incomment || $inover) {
 118        next;
 119     }
 120
 121     # skip the data section
 122     if (m/^__(DATA|END)__$/) {
 123       last;
 124     }
 125
 126     # not everyone puts the package name of the file as the first
 127     # package name so we report all namespaces except some common
 128     # false positives as if they were provided packages (really ugly).
 129
 130     if (m/^\s*package\s+([_:a-zA-Z0-9]+)\s*;/) {
 131       $package = $1;
 132       undef $version;
 133       if ($package eq 'main') {
 134         undef $package;
 135       } else {
 136         # If $package already exists in the $require hash, it means
 137         # the package definition is broken up over multiple blocks.
 138         # In that case, don't stomp a previous $VERSION we might have
 139         # found.  (See BZ#214496.)
 140         $require{$package} = undef unless (exists $require{$package});
 141       }
 142     }
 143
 144     # after we found the package name take the first assignment to
 145     # $VERSION as the version number. Exporter requires that the
 146     # variable be called VERSION so we are safe.
 147
 148     # here are examples of VERSION lines from the perl distribution
 149
 150     #FindBin.pm:$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
 151     #ExtUtils/Install.pm:$VERSION = substr q$Revision: 1.9 $, 10;
 152     #CGI/Apache.pm:$VERSION = (qw$Revision: 1.9 $)[1];
 153     #DynaLoader.pm:$VERSION = $VERSION = "1.03";     # avoid typo warning
 154     #General.pm:$Config::General::VERSION = 2.33;
 155     #
 156     # or with the new "our" pragma you could (read will) see:
 157     #
 158     #    our $VERSION = '1.00'
 159     if ($package && m/^\s*(our\s+)?\$(\Q$package\E::)?VERSION\s*=\s+/) {
 160
 161       # first see if the version string contains the string
 162       # '$Revision' this often causes bizarre strings and is the most
 163       # common method of non static numbering.
 164
 165       if (m/\$Revision: (\d+[.0-9]+)/) {
 166         $version = $1;
 167       } elsif (m/['"]?(\d+[.0-9]+)['"]?/) {
 168
 169         # look for a static number hard coded in the script
 170
 171         $version = $1;
 172       }
 173       $require{$package} ||= $version;
 174     }
 175
 176     # Allow someone to have a variable that defines virtual packages
 177     # The variable is called $RPM_Provides.  It must be scoped with
 178     # "our", but not "local" or "my" (just would not make sense).
 179     #
 180     # For instance:
 181     #
 182     #     $RPM_Provides = "blah bleah"
 183     #
 184     # Will generate provides for "blah" and "bleah".
 185     #
 186     # Each keyword can appear multiple times.  Don't
 187     #  bother with datastructures to store these strings,
 188     #  if we need to print it print it now.
 189
 190     if (m/^\s*(our\s+)?\$RPM_Provides\s*=\s*["'](.*)['"]/i) {
 191       foreach $_ (split(/\s+/, $2)) {
 192         print "$_\n";
 193       }
 194     }
 195
 196   }
 197
 198   close(FILE) ||
 199     die("$0: Could not close file: '$file' : $!\n");
 200
 201   return;
 202 }