[devel] autodeps

Сб Ноя 25 00:07:46 MSK 2000

Привет.

Обнаружил, в чем проблема с 'AutoReqProv: perl' в rpm. Скрипт
find-provides слишком полагается на суждение программы file о том, что
есть perl script. Та, на самом деле, почти никогда не скажет такого о 
модуле, который не начинается со строки типа '#!/usr/bin/perl'.
file-3.33-1mdk вообще считает многие модули какими-то файлами для
palmtop'а Newton, даже не текстовыми! Пришлось отучать.

Прилагаю патч для find-{provides,requires} и снова perl.prov - там нужно
было добавить содержимое RPM_BUILD_ROOT ко всем путям поиска.

Следует заметить, что скриптам perl.prov и perl.req лучше давать весь
список файлов зараз - так _намного_ быстрее.

Еще есть предложения:
- добавить еще один псевдоним для значения по умолчанию Auto{Req,Prov} -
  'default', чтобы можно было писать 'AutoReqProv: default, perl'
  или 'AutoReqProv: default, noshell';
- реализовать подстановку переменной окружения RPM_PERL_LIB_PATH для
  perl.prov из макроса.

-- 
Stay tuned,
  MhZ                                    mailto:mookid на sigent.ru
-----------
Mr. Cole's Axiom:
	The sum of the intelligence on the planet is a constant;
	the population is growing.
----------- следующая часть -----------

--- find-provides.orig	Fri Nov 24 18:51:28 2000
+++ find-provides	Fri Nov 24 22:28:31 2000
@@ -91,7 +91,7 @@
 {
 	local f="$1"
 	local t="$2"
-	if [ -z "${t/$f: perl script text*/}" ]; then
+	if [ -z "${t/$f: perl script text*/}" -o -z "${f/*.p[lmh]/}" ]; then
 		if [ -n "$FIND_PERL" ]; then
 			/usr/lib/rpm/perl.prov "$f"
 		fi
@@ -129,7 +129,7 @@
 
 while IFS= read -r f; do
 	if t="$(file -L "$f")"; then
-		if [ -z "${t/$f: * script text*/}" ]; then
+		if [ -z "${t/$f: * text*/}" ]; then
 			FOUND_PROVS="$FOUND_PROVS
 $(FindScriptProvs "$f" "$t")"
 		elif [ -z "${t/$f: * shared object*/}" ]; then
--- find-requires.orig	Fri Nov 24 18:51:39 2000
+++ find-requires	Fri Nov 24 22:28:21 2000
@@ -115,7 +115,7 @@
 		if [ -n "$FIND_SHELL" ]; then
 			/usr/lib/rpm/shell.req "$f"
 		fi
-	elif [ -z "${t/$f: perl script text*/}" ]; then
+	elif [ -z "${t/$f: perl script text*/}" -o -z "${f/*.p[lmh]/}" ]; then
 		if [ -n "$FIND_PERL" ]; then
 			/usr/lib/rpm/perl.req "$f"
 		fi
@@ -164,7 +164,7 @@
 
 while IFS= read -r f; do
 	t="$(file "$f")"
-	if [ -z "${t/$f: * script text*/}" ]; then
+	if [ -z "${t/$f: * text*/}" ]; then
 		FOUND_REQS="$FOUND_REQS
 $(FindScriptReqs "$f" "$t")"
 	elif [ -z "${t/$f: * executable*/}" ]; then
----------- следующая часть -----------
#!/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>

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;

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

  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;
    }
    
    # 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*;/) {
      $inpackage =  (module_filename($1) eq $module_file)? 1 : 0;
      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 ($inpackage &&
	s/^([\s(]*)(our\s*)?\$VERSION\s*=/$1\$VERSION =/) {
      $provide{$module_file} = extract_version($_);
      next;
    }

    # also consider version initializations with explicit package specification

    if (s/^([\s(]*)(our\s*)?\$([\w:']+)::VERSION\s*=/$1\$VERSION =/) {
      if (module_filename($3) eq $module_file) {
	$provide{$module_file} = 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_loop :base_orig entereval));
  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;
}
