#!/usr/bin/perl

=head1	NAME

perl.req - calculate the requirements for Perl sources

=head1	SYNOPSIS

B<perl.req> --method=normal /path/to/Module.pm

echo /path/to/Module.pm | RPM_PERL_REQ_METHOD=normal B<perl.req>

=head1	DESCRIPTION

This Perl script is intended for automatic detection of modules the given Perl
code depends on.  It looks for common C<use>, C<require> and C<do> statements
and extracts module and version requirements for RPM C<Requires:> clause.

Unlike earlier versions, this script uses B::Deparse (Perl compiler backend,
see C<perldoc B::Deparse>) to re-format Perl code.  This makes dependency
extraction more accurate and simple, but this also has some tremendous
implication: all Perl code should pass C<perl -c> syntax check, since the
compile stage (see C<perldoc perlcompile>) happens for all the code that gets
deparsed.  This is a very strong requirement, but as we talk about packaging
quality, this is considered good.

=head2	Invocation

=head2	Dependencies

For old-style perl libraries and C<*.ph> files, depndencies look like this:

	perl(library.pl)
	perl(header.ph)

And for Perl5 modules like this:

	perl(Some/Module.pm)

The latter differs from the original RedHat RPM style, in which module
dependencies look like C<perl(Some::Module)>.  The style was changed long ago,
and I don't know the exact reason why. :)

=head2	Versioning

For old-style floating point versioning, versions look like this:

	0:5.005003

And for new v-string style versioning:

	1:5.8.1

Please note that RPM does not understand "decimal dot" in versions, so
sometimes you may need to adjust the percision to fit the version in
C<Provides:> clause.

=head2	Methods

The following three modes or "methods" are supported by this script:

=over

=item	strict

In this mode, C<perl.req> goes straight and tries to extract all the
dependencies that happen to be in the given perl code, including
platform-specific dependencies, conditional ones, etc.  This mode is useful for
debugging, but in some cases it can produce too strong/overkill requirements of
your package.

=item	normal

This mode is recommended for default use.  It tries to skip the dependencies
that are too strong by the following criteria:

=over

=item	file list

There's a simple file list in this script by which certain files are
ignored.  E.g., it will not look in files that match */demos/* or
*/examples/* shell path.

=item	package list

There's a list of modules to ignore in "normal" mode.  They are mostly
OS-specific modules like C<Win32::*> or C<VMS::*>.  Modules that are used very
often (like C<strict.pm>) are also ignored in order not to bloat RPM database.

=item	$^O

Here we also ignore conditional blocks with C<$^O> variable involved (see
C<perldoc perlvar>).  This kind of code always does some OS-specific trickery
(well, most of the times).

B<Not implemented yet.>

=item	eval

Statements in C<eval> blocks are also ignored, since this is known to be a
common technique to check the module availability safely.

=back

=item	relaxed

This mode makes C<perl.req> fail-tolerant and even more relaxed:

=over

=item	conditional dependencies

In "relaxed" mode, conditional dependencies (i.e. C<require> and C<do>
statements enclosed in conditional block and this having indentation) are
ignored -- B::Deparse makes it easy!  

=item	fail tolerance

When C<perl.req> cannot deparse the given perl code, it should usually fail.
In turn, RPM should abort the package build process.  Unfortunatelly it does
not, which may result in packages with boroken dependencies.  Only the latest
releases (as of July 2003) of ALT RPM aborts the build process in such cases.

In "relaxed" mode, C<perl.req> will not fail if the deparse fails.  But please
note that some dependencies will be probably missed.

=back

=back

Since there's no default method, you have to specify the one with C<--method>
command line argument.  Alternatively, RPM_PERL_REQ_METHOD environement
variable can be used to set the method.  ALT RPM sets this variable to "normal"
by default.

=head1	AUTHOR

Alexey Tourbin <at@altlinux.org>,
based on an earlier version by Ken Estes <kestes@staff.mail.com>,
with contributions from Mikhail Zabaluev <mhz@altlinux.org>.

=head1	COPYING

This program is intended to be an optional/alternative part of RPM package
manager.  You can redistribute it and/or modify it under the same terms as RPM
itself.  As of version 4.x, RPM code base is covered with GPL and
(alternatively) LGPL licenses.  Any questions regarding the licensing of RPM
should be addressed to Erik Troan <ewt@redhat.com>.

=cut

use 5.8.0;
use Getopt::Long;
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?/),
	qr(\bVMS\b),
);
my @ignore_reqs = (
	qr(^Makefile\b),
# OS-specific
	qr(^machine/ansi\b),
	qr(^sys/systeminfo\b),
	qr(^vmsish\b),
	qr(^MacPerl\b),
	qr(^Win32),
	qr(\bVMS\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$),
	qr(^Exporter\.pm$),
	qr(^DynaLoader\.pm$),
	qr(^AutoLoader\.pm$),
	qr(^Carp\.pm$),
);

# list of requires
my %req;

if ($ENV{RPM_BUILD_ROOT} && open REQ, "$ENV{RPM_BUILD_ROOT}/.perl.req") {
	while (<REQ>) {
		while (s/perl\(([\w:]+)\)>=([\dv._]+)//) {
			$2
			and $req{package_filename($1)}{package_version($2)}++
			or  $req{package_filename($1)} ||= undef;
		}
	}
	close REQ;
	unlink "$ENV{RPM_BUILD_ROOT}/.perl.req";
}

# 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
#	use Fcntl;
#	fcntl(STDERR, F_SETFD, 1) if !$debug && $method eq 'relaxed';

# fake paths should take precedence
	local $_ = $ENV{RPM_PERL_LIB_PATH};
	my @inc = $ENV{RPM_BUILD_ROOT}
		? map { "-I$ENV{RPM_BUILD_ROOT}$_" } split, @INC
		: map { "-I$_" } split;
# deparse
	open(PIPE, "-|", $^X, "-MO=Deparse", @inc, $fname) || die;
	while (<PIPE>) {
		last if /^__(DATA|END)__/;
		process_line($_);
	}
	close(PIPE) or $method ne 'relaxed' and die "$fname: deparse failed.\n";
}

# whether we are in BEGIN block
my ($begin, $begin_indent);
# whether we are in eval block
my ($eval, $eval_indent);

sub process_line {
	my $line = shift;
	chomp $line;
	my $re_mod = qr/\b(?!\d)\w+(?:::(?!\d)\w+)*/;
	my $re_fna = qr/\w+(?:\/\w+)*\.p[lmh]/;
	my $re_ver = qr/\bv?[0-9]+(?:\.[0-9]+(?:_[0-9]+)?)*\b/;

	if ($begin && $line =~ /^\Q$begin_indent}/) {
		debug "exit begin:$.: $line";
		$begin = 0;
	} elsif ($eval && $line =~ /^\Q$eval_indent}/) {
		debug "exit eval:$.: $line";
		$eval = 0;
	}
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|do) '($re_fna)'/) {
		if ($eval && $method ne "strict") {
			debug "skip: $line (eval)";
		} else {
			$req{$1} ||= undef;
		}
	} elsif ($line =~ /^(\s*)require ($re_mod)( if\b| unless\b)?/) {
		if ($eval && $method ne "strict") {
			debug "skip: $line (eval)";
		} elsif ($begin) {
			$req{package_filename($2)} ||= undef;
		} elsif ($3 && $method eq "relaxed") {
			debug "skip: $line (conditional)";
		} elsif ($1 && $method eq "relaxed") {
			debug "skip: $line (indent)";
		} else {
			$req{package_filename($2)} ||= undef;
		}
	} elsif ($line =~ /'?($re_mod)'?->VERSION\(($re_ver)\)/) {
		exists $req{package_filename($1)} and
                $req{package_filename($1)}{package_version($2)}++;
	}
	if ($line =~ /^(\s*)sub [\w:]+\b(BEGIN|CHECK|INIT) {$/) {
		debug "enter begin:$.: $line";
		$begin = 1; $begin_indent = $1;
	} elsif ($line =~ /^(\s*)(.*)\beval {$/) {
		debug "enter eval:$.: $line";
		$eval = 1; $eval_indent = $1;
	}
}

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(?=\d)// || $version =~ /\.\d+\./) {
		return "1:$version";
	} else {
		$version =  sprintf($fmt, $version);
		return "0:$version";
	}
}

# end
req:
foreach my $k (keys %req) {
	if ($method ne "strict") {
		foreach my $re (@ignore_reqs) {
			if ($k =~ $re) {
				debug "req: $k; matches: $re; skip";
				delete $req{$k};
				next req;
			}
		}
	}
	foreach my $v (ref $req{$k} ? keys %{$req{$k}} : undef) {
		if ($k eq "perl-base") {
# too old perl?
			if ($method ne "strict"
			&& ($v =~ /^0:/ && $' lt "5.006" 
			|| $v =~ /^1:/ && $' lt "5.6.0")) {
				delete $req{$k}{$v};
				%{$req{$k}} && next;
				delete $req{$k};
				next req;
			} else {
				print "perl-base";
			}
		} else {
			print "perl($k)";
		}
		print " >= $v" if $v;
		print "\n";
	}
}
# nothing special?
print "perl-base\n" unless %req;