#!/usr/bin/perl
# vim: ts=4 sw=4

use 5.006;
use strict;
use sort 'stable';

use File::Basename qw(basename);
my $progname = basename $0;

################################################################

sub strace (@) {
	pipe my ($r, $w) or die "$progname: pipe: $!\n";
	my $pid = fork;
	defined $pid or die "$progname: fork: $!\n";
	if ($pid) {
		close $w;
		return ($pid, $r);
	} else {
		close $r;
		use Fcntl qw(F_SETFD);
		fcntl $w, F_SETFD, 0;
		my $out = "/dev/fd/" . fileno($w);
		my @strace = (qw(strace -kqfF -e trace=file -o) => $out => "--");
		exec @strace, @_;
		die "$progname: exec strace: $!\n";
	}
}

################################################################

package SPP;

sub TIEHANDLE {
	my ($class, $fh) = @_;
	return bless { fh => $fh, trace => {} } => $class;
}

sub READLINE {
	my $self = shift;
	my $fh = $$self{fh};
	my $trace = $$self{trace};
	while (1) {
		local $_ = <$fh> or return;
		if (s/^(\d+)(\s+)(.*)\s+<unfinished\s+\.\.\.>$/$1$2$3/) {
			die "$progname: pid $1 unfinished twice\n"
				if defined $$trace{$1};
			$$trace{$1} = $_;
			next;
		} elsif (s/^(\d+)\s+<\.\.\.\s+\w+\s+resumed>//) {
			die "$progname: pid $1 resumed without being unfinished\n"
				if not defined $$trace{$1};
			$_ = delete($$trace{$1}) . $_;
		}
		return $_;
	}
}

package main;

################################################################

sub filereq (@) {
	my ($pid, $fd) = &strace;
	tie local *FH, SPP => $fd;
	my %files; local $_;
	while (<FH>) {
		$files{$1}++ if m#^\d+\s+\w+[(]"(/.+?)"#;
	}
	untie *FH;
	close $fd;
	waitpid($pid, 0) == $pid or die "$progname: waitpid: $!\n";
	$? == 0 or die "$progname: strace exit status $?\n";
	return sort grep { -f } keys %files;
}

################################################################

use RPM::Database;
my $rpmdb = RPM::Database->new
	or die "$progname: rpmdb: $RPM::err\n";

my %qR;
sub qR ($) {
	my $name = shift;
	my $deps = $qR{$name} ||= $$rpmdb{$name} && $$rpmdb{$name}{REQUIRENAME};
	return wantarray ? @$deps : scalar @$deps;
}

my %qP;
sub qP ($) {
	my $name = shift;
	my $deps = $qP{$name} ||= $$rpmdb{$name} && $$rpmdb{$name}{PROVIDES};
	return wantarray ? @$deps : scalar @$deps;
}

my %qwP;
sub qwP ($) {
	my $name = shift;
	my $deps = $qwP{$name} ||= [ map { $$_{NAME} } $rpmdb->find_what_provides($name) ];
	return wantarray ? @$deps : scalar @$deps;
}

################################################################

sub packagereq (@) {
	my $bad = qr{^/etc/rpm/macros[.]d/|^/usr/share/aclocal/}; # hardcoded
	my @files = grep { not /$bad/ } &filereq;
	my %packages;
	foreach my $file (@files) {
		my $hdr = $rpmdb->find_by_file($file);
		next unless $hdr;
		my $package = $$hdr{NAME};
		next unless $package;
		push @{$packages{$package}}, $file;
	}
	return \%packages;
}

sub buildreq ($) {
	my $spec = shift;
	my @rpmargs = ("--nodeps", "--define", "__buildreqs 1", "--define", "__nprocs 1");
	return packagereq("rpm", "-bc", @rpmargs, "--", $spec);
}

################################################################

sub expand (@) {
	my %packages = my %expanded = map { $_ => 1 } @_;
	do {
		%packages = %expanded;
		my @packages = sort keys %packages;
		foreach my $pkg (@packages) {
			my @req = qR($pkg) or next;
			foreach my $req (@req) {
				next if $expanded{$req};
				if (exists $$rpmdb{$req}) {
					print "$pkg -> $req\n";
					$expanded{$req} = 1;
					next;
				} else {
					my @prov = qwP($req);
					next unless @prov;
					next if grep { $expanded{$_} } @prov;
					@prov = reverse sort @prov;
					print "warning: $req provided by @prov\n" if @prov > 1;
					next if @prov > 1;
					print "$pkg -> $req -> $prov[0]\n";
					$expanded{$prov[0]} = 1;
				}
			}
		}
	} while keys(%expanded) > keys(%packages);
	return sort keys %expanded;
}

sub intersect ($$) {
	my ($aref1, $aref2) = @_;
	my @sect;
	foreach my $e1 (@$aref1) {
		foreach my $e2 (@$aref2) {
			push @sect, $e1 if $e1 eq $e2;
		}
	}
	return unless @sect;
	@sect = sort { length($a) <=> length($b) } sort @sect;
	return wantarray ? @sect : $sect[0];
}

sub squeeze (@) {
	my @packages = sort { qR($a) <=> qR($b) } sort @_;
	my %packages = map { $_ => 1 } @packages;
PREY:
	foreach my $p0 (@packages) {
		my @req0 = qR($p0); my @prov0 = qP($p0);
RAPTOR:	
		foreach my $pN (@packages) {
			next PREY unless $packages{$p0};
			next RAPTOR if $p0 eq $pN;
			my @reqN = qR($pN); my @provN = qP($pN);
			my $do = intersect [ $p0 ] => \@reqN;
			my $dox = intersect \@prov0 => \@reqN;
			my $undo = intersect [ $pN ] => \@req0;
			my $undox = intersect \@provN => \@req0;
			if ($do and (not ($undo or $undox) or $packages{$pN})) {
				print "$p0 < $pN\n";
				$packages{$p0} = 0;
				next PREY;
			}
			if ($dox and (not ($undo or $undox) or $packages{$pN})) {
				print "$p0 < $dox < $pN\n";
				$packages{$p0} = 0;
				next PREY;
			}
		}
	}
	return sort grep { $packages{$_} } keys %packages;
}

################################################################

sub optimize (@) {
	my @packages = @_;
	print "\tExpanding...\n";
	@packages = expand(@packages);
	print "BuildRequires: @packages\n";
	print "\tSqueezing...\n";
	@packages = squeeze(@packages);
	print "BuildRequires: @packages\n";
	my $bad = qr{^glibc-core-|^rpm-build$|^ccache$|^hostinfo$}; # hardcoded
	my @new;
	foreach my $pkg (@packages) {
		if ($pkg =~ $bad) {
			print "Removing $pkg...\n";
		} else {
			push @new, $pkg;
		}
	}
	print "BuildRequires: @new\n" if @new < @packages;
	return @new;	
}

sub explain ($) {
	use Data::Dumper qw(Dumper);
	local $Data::Dumper::Terse = 1;
	local $Data::Dumper::Useqq = 1;
	local $Data::Dumper::Indent = 1;
	print Dumper(@_);
	return shift;
}

################################################################

sub alter_spec ($@) {
	my $spec = shift;
	my @packages = sort @_;
	use POSIX qw(strftime);
	my $date = strftime "%a %b %d %Y", localtime;
	my $fmt = <<EOF;
# Automatically added by $progname on %s
BuildRequires: %s
EOF
	my $tag = sprintf $fmt, $date, "@packages";
	my $catch = quotemeta $fmt;
	$catch =~ s/\\%s\b/.*/g;
	local ($^I, @ARGV) = ("~", $spec); # perlfaq5
	local $/ = undef;
	local $_ = <>;
	s/^$catch/$tag/mo 
		or
	s/^(%package|%description)\b/$tag\n$1/m
		or die "$progname: $spec: bad specfile\n";
	print;
}

################################################################

sub usage ($) {
	use Pod::Usage qw(pod2usage);
	my $rv = shift;
	pod2usage
		-message => "$progname: calculate build dependencies",
		-output => $rv ? \*STDERR : \*STDOUT,
		-exitval => $rv,
		-verbose => 1;
}	

use Getopt::Long qw(GetOptions);
GetOptions help => \my $opt_help,
	filereq => \my $opt_filereq, 
	packagereq => \my $opt_packagereq,
	squeeze => \my $opt_squeeze
		or usage(1);

my $opt_buildreq = not ($opt_filereq or $opt_packagereq or $opt_squeeze);

die "$progname: options --filereq, --packagereq and --squeeze are mutually exclusive\n"
	unless $opt_filereq xor $opt_packagereq xor $opt_squeeze xor $opt_buildreq;

usage(0) if $opt_help;
usage(1) if not @ARGV;

################################################################

if ($opt_filereq) {
	local $, = local $\ = "\n";
	print filereq(@ARGV);
} elsif ($opt_squeeze) {
	optimize(@ARGV);
} elsif ($opt_packagereq) {
	my $packages = explain(packagereq(@ARGV));
	optimize(keys %$packages);
} else {
	foreach my $spec (@ARGV) {
		my $packages = explain(buildreq($spec));
		my @packages = optimize(keys %$packages);
		alter_spec($spec, @packages) if @packages;
	}
}

__END__

=head1	NAME

buildreq2 - calculate build dependencies

=head1	SYNOPSIS

	buildreq2 specfile...
	buildreq2 --filereq cmd [args...]
	buildreq2 --packagereq cmd [args...]
	buildreq2 --squeeze pkg...

=head1	AUTHOR

Written by Alexey Tourbin <at@altlinux.org>,
based upon earlier work by Dmitry V. Levin <ldv@altlinux.org>.

=head1	COPYING

Copyright (c) 2004, 2005 Alexey Tourbin, ALT Linux Team.

This is free software; you can redistribute it and/or modify it under
the terms of the GNU Library General Public License as published by the
Free Software Foundation; either version 2 of the License, or (at your
option) any later version.

=cut