* [devel] Re: RPM requires -- perl
2003-03-21 16:35 ` Michael Shigorin
@ 2003-03-21 17:16 ` Alexey Tourbin
2003-03-21 22:53 ` Michael Shigorin
0 siblings, 1 reply; 7+ messages in thread
From: Alexey Tourbin @ 2003-03-21 17:16 UTC (permalink / raw)
To: devel
[-- Attachment #1.1: Type: text/plain, Size: 794 bytes --]
On Fri, Mar 21, 2003 at 06:35:08PM +0200, Michael Shigorin wrote:
> > Нет. У вас определяется внутренняя зависимость внутри пакета
> > (Rrequires), но не определяется Provides. См. ответ inger'а.
>
> Вообще меня тоже удивило -- жалко, что сломалось то, что просто
> работало... впрочем, майнтейнеру виднее.
Что именно раньше "просто работало" и что сломалось?
Тут просто такая специфика что Prefix1::Prefix2::Module преобразуется
в $PATH/Prefix1/Prefix2/Module.pm, а $PATH может иметь нестандарнтые
значения (подцепляется через perl -I$PATH или use lib $PATH).
Кста, у меня есть наброски /usr/lib/rpm/perl.{req,prov}, которые
используют B::Deparse и B::Xref (inspired by mhz). Но они пока не
работают как надо. И у меня есть некоторые сомнения. Впрочем, perl.req
уже можно показать.
[-- Attachment #1.2: perl.req --]
[-- Type: text/plain, Size: 11166 bytes --]
#!/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 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 makedepends like script for perl.
# 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 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
# modified by Mikhail Zabaluev <mookid@mu.ru>
# modified by Alexey Tourbin <at@turbinal.org>
use 5.8.0;
use Getopt::Long;
use Fcntl;
use strict;
GetOptions("debug" => \my $debug, "method=s" => \my $method);
sub debug ($) {
my $msg = shift;
warn "$msg\n" if $debug;
1;
}
if ($debug) {
require IO::Handle;
STDOUT->autoflush(1);
STDERR->autoflush(1);
debug "debug mode enabled";
}
$method ||= $ENV{RPM_PERL_REQ_METHOD};
$method eq "strict" || $method eq "normal" || $method eq "relaxed" ||
die "$0: strict, normal, relaxed methods supported\n";
debug "method = $method";
my @ignore_files = (
qr(/usr/share/doc/),
qr(/[Dd]emos?/),
qr(/examples?/),
);
my @ignore_reqs = (
qr(^Makefile\b),
# OS-specific
qr(^machine/ansi\b),
qr(^sys/systeminfo\b),
qr(^vmsish\b),
qr(^MacPerl\b),
qr(^Win32\b),
qr(^VMS\b),
qr(^OS2\b),
qr(^Mac\b),
qr(^ExtUtils/XSSymSet\b),
qr(^Convert/EBCDIC\b),
# old names
qr(^Digest/Perl/MD5\b),
qr(^Pod/PlainText\b),
# wrong names
qr(/\.),
qr(\$),
# so commonly used... just a database junk (guaranteed to be in perl-base)
qr(^strict\.pm$),
qr(^vars\.pm$),
);
# begin
process_file($_) foreach @ARGV ? @ARGV : <>;
sub process_file {
my $fname = shift;
chomp $fname;
return unless $fname;
if ($method ne "strict") {
foreach my $re (@ignore_files) {
if ($fname =~ $re) {
debug "file: $fname matches: $re; skip";
return;
}
}
}
debug "processing $fname";
# skip "syntax OK" messages
# fcntl(STDERR, F_SETFD, 1) unless $debug;
open(PIPE, "-|", $^X, "-MO=Deparse", $fname) || die;
process_line($_) while <PIPE>;
}
my %req;
sub process_line {
my $line = shift;
my $re_mod = qr/\b(?!\d)\w+(?:::(?!\d)\w+)*/;
my $re_fna = qr//;
my $re_ver = qr/\bv?[0-9]+(?:\.[0-9]+(?:_[0-9]+)?)*\b/;
again:
if ($line =~ /^\s*(?:use|require) ($re_ver)/) {
$req{"perl-base"}{package_version($1, '%.5f')}++;
} elsif ($line =~ /^\s*use ($re_mod) ($re_ver)/) {
$req{package_filename($1)}{package_version($2)}++;
} elsif ($line =~ /^\s*use ($re_mod)/) {
$req{package_filename($1)} ||= undef;
} elsif ($line =~ /^(\s*)require ($re_mod)( if\b| unless\b)?/) {
if ($3 && $method ne "strict") {
debug "skip: $line (conditional)";
} elsif ($1 && $method ne "strict") {
debug "skip: $line (indent)";
} else {
$req{package_filename($2)} ||= undef;
}
} }
sub package_filename {
my $package = shift;
$package =~ s/::/\//g;
return $package . '.pm';
}
sub package_version {
my ($version, $fmt) = (@_, '%s');
$version =~ s/_//g;
if ($version =~ s/^v// || $version =~ /\.\d+\./) {
return "1:$version";
} else {
$version = sprintf($fmt, $version);
return "0:$version";
}
}
# end
while (my ($k, $v) = each %req) {
foreach my $ver (ref $v ? keys %$v : undef) {
print $k eq "perl-base" ? $k : "perl($k)";
print " >= $ver" if defined $ver;
print "\n";
}
}
__END__
} elsif ($line =~ /^(\s*)(use|require|do) ([^\s;,]+)(.*)/) {
my ($ind, $sta, $tok, $rst) = ($1, $2, $3, $4);
my ($condit) = $rst =~ /($re_cnd)/;
my ($module) = $tok =~ /($re_mod)/;
my ($filena) = $tok =~ /($re_fna)/;
if ($condit && $method ne "strict" && $sta ne "use") {
debug "skip: $line (conditional)";
} elsif ($sta eq "use" && $module) {
print "use perl($module)\n";
} elsif ($sta eq "require" && $module && $ind && $method ne "strict") {
debug "skip: $line (indent)";
} elsif ($sta eq "require" && $module) {
print "require perl($module)\n";
} else {
print "???: $line\n";
}
}
}
MODULE:
foreach $module (sort keys %require) {
unless ($method eq "strict") {
for my $re (@ignore_reqs) {
if ($module =~ $re) {
debug "module $module matches $re; skip";
next MODULE;
}
}
}
if (length($require{$module}) == 0) {
print "perl($module)\n";
} else {
print "perl($module) >= $require{$module}\n";
}
}
exit 0;
sub process_file {
my ($file) = @_;
chomp($file);
return if $file eq '';
unless ($method eq "strict") {
foreach my $re (@ignore_files) {
if ($file =~ $re) {
debug "file: $file matches: $re; skip";
return;
}
}
}
open(FILE, "<$file")||
die("$0: Could not open file: '$file' : $!\n");
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
# AT: but what about AutoLoader and SelfLoader? (TODO)
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.
if ( m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
foreach (split(/\s+/, $1)) {
print "$_\n";
}
next;
}
chomp;
s/#.*//;
next unless /\b(use|require|do)\b/; # do not want 'do {' loops
next if /\bdo\s*{/; # do not want 'do {' loops
next if /^\s*["']/;
# print "just use it";
if (/^\s*(?:(?!use|require|do|eval|if|unless)[\w:$->]+\s*)+\(/) {
debug "skip: $_";
next;
}
if (/^\s*(?:(?!use|require|do|eval|if|unless)[\w:]+\s*)+\(?(['"]).*\1/) {
debug "skip: $_";
next;
}
next unless /^(.*?)\b(use|do|require)\s+(['"]?)([.:\w\/]+)\3\s*(.*)/;
my ($indent, $statement, $quote, $module, $rest) = ($1, $2, $3, $4, $5);
debug "line: $_";
next if $module =~ m/\$/;
next if $module !~ m/\w/;
# conditional statements
if (/\b(if|unless|eval)\b/ && $method eq "relaxed") {
debug "file: $file requires: $module (conditional); skip";
next;
}
# indent is somewhat unclear
if ($indent =~ /[^\w\s{}();:]/ && $method ne "strict") {
debug "file: $file requires: $module (indent unclear); skip";
next;
}
# statement requires a particular version of Perl
if ($module =~ m/^v?[0-9._]+$/ && $rest =~ /^;|\s*$/) {
print "perl-base >= " . package_version($module, '%.5f') . "\n";
next;
}
if ($statement eq "require") {
if ($indent =~ /^\s+$/ && $method eq "relaxed") {
debug "file: $file <require>s: $module (whitespace); skip";
next;
}
if ($indent =~ /\S/ && $method ne "strict") {
debug "file: $file <require>s: $module (inside); skip";
next;
}
}
if ($statement eq "do") {
if ($indent =~ /^\s+$/ && $method eq "relaxed") {
debug "file: $file <do>es: $module (whitespace); skip";
next;
}
if ($indent =~ /\S/ && $method ne "strict") {
debug "file: $file <do>es: $module (inside); skip";
next;
}
}
if ($statement eq "use") {
if ($indent =~ /\S/ && $method ne "strict") {
debug "file: $file <use>s: $module (inside); skip";
next;
}
}
# filename
if ($quote && $module =~ /^\w+(\/\w+)*\.p[lmh]$/ && $rest =~ /^$|;/ &&
($statement eq "do" || $statement eq "require"))
{
$require{$module} = undef;
debug "\$require{$module} = yes";
next;
}
# modules, variables, lists
my $m = qr/[:\w]+/;
my $v = qr/[\$\%\@]$m/;
my $s = qr/(?:[\s\t,]|=>)/;
my $ml = qr/^\s*(?:qw)?[\/('"]?\s*($m(?:$s$m)*)/;
my $fl = qr/^\s*(?:qw)?[\/('"]?\s*($m(?:$s$m)*)/;
my $vl = qr/^\s*(?:qw)?[\/('"]?\s*($v(?:$s$v)*)/;
# special pragma (vars, subs)
if (($module eq "vars" || $module eq "subs") && $rest =~ $vl) {
my $mod = module_filename($module);
$require{$mod} = undef;
debug "$module: \$requires{$mod} = yes";
next;
}
# special pragma (constant)
if ($module eq "constant" && $rest =~ $ml) {
my $mod = module_filename($module);
$require{$mod} = undef;
debug "$module: \$requires{$mod} = yes";
next;
}
# special pragma (base, autouse)
if (($module eq "base" || $module eq "autouse") && $rest =~ $vl) {
my $modules = $1;
my @modules = split $s, $modules;
foreach my $mod (@modules, $module) {
if ($mod =~ /^\w+(::\w+)*$/) {
$mod = module_filename($mod);
$require{$mod} = undef;
debug "$module: \$requires{$mod} = yes";
}
}
next;
}
# special pragma (overload)
if ($statement eq "use" && $module eq "overload" && $rest =~ /'|"|=>|,/) {
my $mod = module_filename($module);
$require{$mod} = undef;
debug "\$requires{$mod} = yes";
next;
}
# perl module
if ($module && $module =~ /^\w+(::\w+)*$/ &&
($rest =~ /^$|^[;}"']|\b(if|unless|eval)\b|\(|^v?\d|qw|$fl/ &&
$indent =~ /^\s*$|[^\w\s]\s*$/) &&
($statement eq "use" || $statement eq "require"))
{
$module = module_filename($module);
my ($version) = $rest =~ /^(v?[0-9._]+)\b/;
if ($version) {
$version = package_version($version);
debug "\$require{$module} >= $version";
$require{$module} = $version
unless $require{$module} && $require{$module} >= $version;
} else {
$require{$module} = undef;
debug "\$require{$module} = yes";
}
next;
}
debug "untrapped: $_";
}
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'; #'
}
# package_version($version[, $oldformat]) -
# converts Perl version constant to RPM package version.
# New style 'vN.N.N' numbers are converted to epoch 1 versions,
# whereas old-style floating point versions are given epoch 0 and
# optionally formatted by sprintf() using supplied format.
# Parameters:
# $version - version number in 'vN.N.N' or 'N.NNN_NN' format
# $oldformat - format specifier for sprintf() used to format old-style
# floating-point version number
[-- Attachment #2: Type: application/pgp-signature, Size: 189 bytes --]
^ permalink raw reply [flat|nested] 7+ messages in thread