rpm-build/scripts/perl.prov

#!/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';
}