120 lines
2.7 KiB
Perl
Executable File
120 lines
2.7 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
use Safe;
|
|
use strict;
|
|
|
|
# list of provides
|
|
my %prov;
|
|
|
|
# fake paths should take precedence
|
|
local $_ = $ENV{RPM_PERL_LIB_PATH};
|
|
my @inc = map { "$ENV{RPM_BUILD_ROOT}$_" } split, @INC;
|
|
|
|
# begin
|
|
process_file($_) foreach @ARGV ? @ARGV : <>;
|
|
|
|
sub process_file {
|
|
my $fname = shift;
|
|
chomp $fname;
|
|
return unless $fname;
|
|
|
|
# check if we match any prefix
|
|
# and take the longest...
|
|
my ($prefix) = sort { length($b) <=> length($a) }
|
|
grep { index($fname, $_) == 0 } @inc;
|
|
return unless $prefix;
|
|
my $basename = substr $fname, length $prefix;
|
|
$basename =~ s/^\///;
|
|
return unless $basename;
|
|
|
|
# provide *.p[lh]
|
|
if ($fname =~ /\.p[lh]$/) {
|
|
$prov{$basename} = undef;
|
|
return;
|
|
# only *.pm left
|
|
} elsif ($basename =~ /\.pm$/) {
|
|
$prov{$basename} = undef;
|
|
} else {
|
|
return;
|
|
}
|
|
# process *.pm
|
|
my $in_package;
|
|
my $re_mod = qr/\b(?!\d)\w+(?:::(?!\d)\w+)*/;
|
|
my $re_ver = qr/\bv?[0-9]+(?:\.[0-9]+(?:_[0-9]+)?)*\b/;
|
|
open(FILE, '<', $fname) || die;
|
|
while (<FILE>) {
|
|
/^=\w/ .. /^=cut/ and next;
|
|
/^__(DATA|END)__$/ and last;
|
|
# look for 'package' declaration that matches filename
|
|
if (/^\s*package\s+($re_mod)\s*;/) {
|
|
if ($basename eq package_filename($1)) {
|
|
$in_package = $1;
|
|
} else {
|
|
undef $in_package;
|
|
}
|
|
# look for $VERSION
|
|
} elsif ($in_package && m/\$(?:$in_package\::)?VERSION\s*=.*\d/) {
|
|
$prov{$basename} = extract_version($_);
|
|
last;
|
|
}
|
|
}
|
|
close FILE;
|
|
}
|
|
|
|
# end
|
|
while (my ($k, $v) = each %prov) {
|
|
if ($v) {
|
|
print "perl($k) = $v\n";
|
|
# provide an additional epoch 0 version converted using Perl's rules
|
|
print "perl($k) = 0:" . old_version($1) . "\n"
|
|
if $v =~ /^1:(.+)/;
|
|
} else {
|
|
print "perl($k)\n";
|
|
}
|
|
}
|
|
|
|
sub old_version {
|
|
local $_ = shift;
|
|
my $fpver = 0;
|
|
my $ratio = 1;
|
|
my @series = split(/\./, $1);
|
|
for (@series) {
|
|
$fpver += $_ * $ratio;
|
|
$ratio *= 0.001;
|
|
}
|
|
my $fdigits = $#series * 3;
|
|
return sprintf "%.${fdigits}f", $fpver;
|
|
}
|
|
|
|
# XXX Mhz code?
|
|
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");
|
|
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;
|
|
}
|
|
}
|
|
|
|
# copy-pasted from perl.req
|
|
sub package_filename {
|
|
my $package = shift;
|
|
$package =~ s/::/\//g;
|
|
return $package . '.pm';
|
|
}
|