362 lines
9.0 KiB
Perl
Executable File
362 lines
9.0 KiB
Perl
Executable File
#!/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.005; # qr
|
|
use Getopt::Long;
|
|
use File::Spec;
|
|
|
|
GetOptions("debug" => \my $debug, "method=s" => \my $method);
|
|
sub debug ($) {
|
|
my $msg = shift;
|
|
warn "$msg\n" if $debug;
|
|
}
|
|
if ($debug) {
|
|
require IO::Handle;
|
|
STDOUT->autoflush(1);
|
|
STDERR->autoflush(1);
|
|
debug "debug mode enabled";
|
|
}
|
|
$method ||= $ENV{RPM_PERL_REQ_METHOD};
|
|
$method =~ s/\s+//g;
|
|
$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(^VMS/),
|
|
qr(^Win32/),
|
|
qr(^OS2/),
|
|
qr(^Mac/),
|
|
qr(^ExtUtils/XSSymSet\b),
|
|
qr(^Convert/EBCDIC\b),
|
|
# old names
|
|
qr(^Digest/Perl/MD5\b),
|
|
qr(^Pod/PlainText\b),
|
|
# wrong names
|
|
qr(/\.),
|
|
qr(\$),
|
|
# MDK: skip if the phrase was "use of" -- shows up in gimp-perl, et al
|
|
qr(^of$),
|
|
);
|
|
|
|
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($_);
|
|
}
|
|
}
|
|
|
|
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
|
|
|
|
sub package_version {
|
|
my $version = shift;
|
|
if ($version =~ s/^v// || $version =~ /\.[\d_]+\./) {
|
|
return "1:$version";
|
|
}
|
|
else {
|
|
my $format = shift;
|
|
$format = '%s' unless defined $format;
|
|
return '0:' . sprintf($format, $version);
|
|
}
|
|
}
|