rpm-build/scripts/perl.prov

#!/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 grammmar 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.

# 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.

# The RPM_PERL_LIB_PATH environment variable, if set, must contain the list of
# absolute paths, separated by colons, spaces or commas. These paths are
# considered as library paths used to determine relative names of provided
# perl files. If RPM_PERL_LIB_PATH is not set, paths from @INC Perl variable
# are used instead.

# by Ken Estes Mail.com kestes@staff.mail.com
# modified by Mikhail Zabaluev <mookid@mu.ru>
# modified by Alexey Tourbin <at@turbinal.org>

require v5.6.0;

use Safe;

use strict;

use vars qw(%provide @perl_inc);


# obtain the list of library directories. If not provided, use @INC

if (exists $ENV{RPM_PERL_LIB_PATH}) {
  @perl_inc = split(/[:,\s]+/, $ENV{RPM_PERL_LIB_PATH});
}
else {
  @perl_inc = grep { m|^/| } @INC;
}

# Sort @perl_inc descending by length to search for longest prefix rapidly.

@perl_inc = sort { length($b) <=> length($a) } @perl_inc;

# Prepend $RPM_BUILD_ROOT to paths.

my $buildroot = $ENV{RPM_BUILD_ROOT};
@perl_inc = map { "${buildroot}$_" } @perl_inc;

# process files

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($_);
  }
}

# print out sorted results

foreach my $module (sort keys %provide) {
  my $version = $provide{$module};
  if (length($version) == 0) {
    print "perl($module)\n";
  } else {
    print "perl($module) = $version\n";
    if ($version =~ /^1:(.*)/) {

      # provide an additional epoch 0 version converted using Perl's rules

      my $fpver = 0;
      my $ratio = 1;
      my @series = split(/\./, $1);
      for (@series) {
	$fpver += $_ * $ratio;
	$ratio *= 0.001;
      }
      my $fdigits = $#series * 3;
      printf("perl($module) = 0:%.${fdigits}f\n", $fpver);
    }
  }
}

exit 0;



sub process_file {

  my ($file) = @_;
  chomp $file;

  return if $file eq '';

  # find the longest matching prefix among Perl library search directories

  my $prefix = '';
  foreach (@perl_inc) {
    if (substr($file, 0, length($_)) eq $_) {
      $prefix = $_;
      last;
    }
  }

  return if $prefix eq '';

  # get path to the module file without prefix

  my $module_file = substr($file, length($prefix));
  $module_file =~ s{^/}{};

  $provide{$module_file} = undef;

  return if $module_file !~ /\.pm$/;

  # try to extract version number for this package

  open(FILE, "<$file")||
    die("$0: Could not open file: '$file' : $!\n");

  my $inpackage = 0;

  my ($package_name, $package_filename);
  my $module_path = $module_file;
  $module_path =~ s/(.+?)\/(.+)/$1\//;

  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[12]|pod|over|item|for|begin)/) .. (m/^=(cut)/)) {
      next;
    }
    
    if ( (m/^=(over)/) .. (m/^=(back)/) ) {
      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 browse through all namespaces

    if (m/^\s*package\s+([\w:']+)\s*;/) {

# AT: 
# $ grep '^[ \t]*package' /usr/lib/perl5/i386-linux/B/CC.pm
# /usr/lib/perl5/i386-linux/B/CC.pm:package B::CC;
# /usr/lib/perl5/i386-linux/B/CC.pm:    package B::Pseudoreg;
# /usr/lib/perl5/i386-linux/B/CC.pm:    package B::Shadow;

	$package_name = $1;
	$package_filename = module_filename($package_name);
	next if $package_filename eq $module_file;
	if ($module_path && index($package_filename, $module_path) == 0) {
		$provide{$package_filename} = undef;
	} else {
		undef $package_name;
		undef $package_filename;
	}
	next;
    }

    # 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.

    if ($package_filename &&
	s/^([\s(]*)(our\s*)?\$VERSION\s*=/$1\$VERSION =/) {
      $provide{$package_filename} = extract_version($_);
      next;
    }

    # also consider version initializations with explicit package specification

    if (s/^([\s(]*)(our\s*)?\$([\w:']+)::VERSION\s*=/$1\$VERSION =/) {
      my $filename = module_filename($3);
      if ($filename eq $module_file || 
        $module_path && index($filename, $module_path) == 0) 
      {
	$provide{$filename} = extract_version($_);
      }
      next;
    }

    # 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*\$RPM_Provides\s*=\s*["'](.*)['"]/i) {
      foreach (split(/\s+/, $1)) {
	print "$_\n";
      }
    }

  }

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

  return ;
}


# module_filename($name) -
# converts module name to relative file path

sub module_filename {
  my $name = shift;
  $name =~ s{::|'}{/}g;
  return $name . '.pm';
}


# extract_version - 
# this subroutine tries to evaluate line containing assignment to $VERSION
# in order to achieve version number

sub extract_version {

  my $line = shift;

  # Try to evaluate the assignment to get the value of $VERSION.
  # It is usually computed without using data external to the expression,
  # so we would have no problems.

  local $SIG{__WARN__} = sub { };

  my $safe = new Safe;
  $safe->permit_only(qw(:base_core :base_mem :base_orig entereval
                        grepstart grepwhile mapstart mapwhile));
  my $version = $safe->reval("$line; \$VERSION;");

  return undef if $@ || length($version) == 0;

  if ($version =~ s/^\s*(\d[\d_]*(\.[\d_]*)?|\.[\d_]+)/$1/) {

    # plain old numeric version

    return '0:' . $version;
  }
  else {

    # Supposedly, a new style version evaluated as a string constant.
    # Return an epoch 1 version

    return sprintf('1:%vd', $version);
  }

  return undef;
}