#!/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 } => $class;
}

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

package main;

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

my $filereq_trace_files;

sub filereq (@) {
	local $| = 1 if $filereq_trace_files;
	my ($pid, $fd) = &strace;
	tie local *FH, SPP => $fd;
	my %files; local $_;
	while (<FH>) {
		if (m#^\d+\s+\w+[(]"(/.+?)"#) {
			$files{$1}++;
			if ($filereq_trace_files) {
				my $file = $1;
				if ($file =~ $filereq_trace_files) {
					print "$progname: $file\n";
				}
			}
		}
	}
	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{	^/(?:tmp|dev|home|proc|mnt)/
		|	^/etc/rpm/macros[.]d/
		|	^/usr/share/aclocal/
		|	^/etc/gnome-vfs-.*/modules/
		|	^/usr/share/fonts/.*/fonts[.]cache\b
		|	^/etc/perl5/Net/libnet[.]cfg
		}x; # 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, @args) = @_;
	my @args0 = ("--nodeps", "--define", "__buildreqs 1", "--define", "__nprocs 1");
	unshift @args, "-bc" unless grep /^-b\w$/ => @args;
	my $packages = packagereq("rpmbuild", @args0, @args, "--", $spec);
	$$packages{basesystem} ||= []; # hardcoded
	return $packages;
}

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

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 (reverse @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 cleanup (@) {
	my @packages = @_;
	my @new;
	my $bad = qr{^glibc-core-|^basesystem$|^rpm-build$|^ccache$|^hostinfo$}; # hardcoded
	my @new;
	foreach my $pkg (@packages) {
		if ($pkg =~ $bad) {
			print "Removing $pkg...\n";
			next;
		}
		my @pkgparts = split /-/, $pkg, 2;
		goto add unless @pkgparts == 2;
		my @prov = qP($pkg);
		foreach my $prov (@prov) {
			my @provparts = split /-/, $prov, 2;
			next unless @provparts == 2;
			next unless $pkgparts[1] eq $provparts[1];
			if ($pkgparts[0] =~ /^\Q$provparts[0]\E[\d.]+$/) {
				print "Substituting $pkg -> $prov...\n";
				$pkg = $prov;
			}
		}
add:
		push @new, $pkg;
	}
	return @new;
}
	
sub optimize (@) {
	my @packages = @_;
	print "BuildRequires: @packages\n";
	print "\tExpanding...\n";
	@packages = expand(@packages);
	print "BuildRequires: @packages\n";
	print "\tSqueezing...\n";
	@packages = squeeze(@packages);
	print "BuildRequires: @packages\n";
	my @new = cleanup(@packages);
	print "BuildRequires: @new\n" if "@new" ne "@packages";
	return @new;	
}

sub explain ($) {
	my $packages = shift;
	foreach my $pkg (sort keys %$packages) {
		print "$pkg\n";
		my @files = sort @{$$packages{$pkg}};
		print "\t$_\n" foreach @files;
	}
}

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

my $fmt0 = "# Added by $progname on %s\nBuildRequires: %s\n";
my $fmt1 = "# Added by $progname on %s (%s)\nBuildRequires: %s\n";

my $catch0 = quotemeta $fmt0; $catch0 =~ s/\\%s\b/(.+)/g; $catch0 = qr{^$catch0}m;
my $catch1 = quotemeta $fmt1; $catch1 =~ s/\\%s\b/(.+)/g; $catch1 = qr{^$catch1}m;

sub spec_args ($) {
	my $spec = shift;
	open my $fh, $spec or die "$progname: $spec: $!\n";
	local $/ = undef; local $_ = <$fh>;
	if (/$catch1/mo) {
		my $args = $2;
		use Text::ParseWords qw(shellwords);
		my @args = shellwords($args);
		warn "spec args: @args\n";
		return @args;
	}
	return;
}

sub fmt_args (@) {
	my @args = grep { $_ ne "-bc" } @_;
	foreach (grep /[\s\\'"]/ => @args) {
		s/[\\"]/\\$1/g;
		$_ = qq("$_");
	}
	return "@args";
}

sub fmt_now () {
	use POSIX qw(strftime);
	my $now = strftime "%a %b %d %Y", localtime;
	return $now;
}

sub fmt_packages {
	my @packages = sort @_;
	return "@packages";
}

sub alter_spec ($$$) {
	my $spec = shift;
	my $packages = shift; $packages = fmt_packages(@$packages);
	my $args = shift; $args = fmt_args(@$args);
	my $date = fmt_now;
	my $tag = $args
		? sprintf $fmt1, $date, $args, $packages 
		: sprintf $fmt0, $date, $packages
		;
	local ($^I, @ARGV) = ("~", $spec); # perlfaq5
	local $/ = undef; local $_ = <>;
	s/$catch0/$tag/mo 
		or
	s/$catch1/$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);
Getopt::Long::Configure("bundling");

my %opt_rpmargs;

GetOptions help => \my $opt_help,
	filereq		=> \my $opt_filereq,
	packagereq	=> \my $opt_packagereq,
	squeeze		=> \my $opt_squeeze,

	"tracepkg=s" => \my @opt_tracepkg,
	
	"b=s"		=> \my $opt_stage,
	map { +"$_=s" => \@{$opt_rpmargs{$_}} } qw(define with without enable disable)
	
		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;

my @opt_rpmargs;
while (my ($opt, $args) = each %opt_rpmargs) {
	foreach my $arg (@$args) {
		push @opt_rpmargs, "--$opt" => $arg;
	}
}
unshift @opt_rpmargs, "-b$opt_stage" if $opt_stage;

if (@opt_tracepkg) {
	my @files = map { @{$_->filenames} }
	map { $$rpmdb{$_} or die "$progname: tracepkg: $_: no such package" } @opt_tracepkg;
	if (@files) {
		my $re_files = join "|" => map quotemeta, @files;
		$filereq_trace_files = qr{^(?:$re_files)$};
	}
}

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

if ($opt_filereq) {
	my @files = filereq(@ARGV);
	print join("\n" => @files), "\n";
} elsif ($opt_squeeze) {
	optimize(@ARGV);
} elsif ($opt_packagereq) {
	my $packages = packagereq(@ARGV);
	explain($packages);
	optimize(keys %$packages);
} else {
	foreach my $spec (@ARGV) {
		my @args = @opt_rpmargs ? @opt_rpmargs : spec_args($spec);
		my $packages = buildreq($spec, @args);
		explain($packages);
		my @packages = optimize(keys %$packages);
		alter_spec($spec, \@packages, \@args) 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