#!/usr/bin/perl -w
#
# Bare-bones ports maintainer. Safe to "just run" - it will not do
# anything on its own, but rather just print the commands that need
# to be executed for updating ports.
#
# Requires Perl >5.0 or above.
#
# Add --debug for verbose output, repeat for additional verbosity.
# Add --leaf to display leaf ports and exit.
# Add --force to unconditionally re-make.
# Add --make to define arguments for make.
# Add --restart to execute rc.d scripts
# Add --shell to pipe output directly to a shell.
#
# Command line arguments restrict the ports that are to be considered
# for updating. Use category/portname syntax, e.g. "lang/perl5.8".
# Depending ports will be included automatically. If no command line
# arguments are present all ports will be considered.
#
#
#  Copyright © 2005-2006 Helge Oldach
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.

use strict;
use Getopt::Long qw(:config bundling);

my $debug = 0;
my $force = 0;
my $leaf = 0;
my $restart = 0;
my $shell = "";
my $make = "all deinstall install clean";

die "option error" unless GetOptions("debug|d+" => \$debug, "force|f" => \$force, "leaf|l"=> \$leaf, "make|m=s"=> \$make, "restart|r" => \$restart, "shell|s=s" => \$shell);

open STDOUT, "|-", $shell or die "can't open STDOUT" if $shell;

chomp(my ($portsdir, $pkg_dbdir, $prefix, $rc_subr_suffix) = qx(make -f /usr/share/mk/bsd.port.mk -V PORTSDIR -V PKG_DBDIR -V PREFIX -V RC_SUBR_SUFFIX));

opendir DIR, $pkg_dbdir or die "can't opendir $pkg_dbdir: $!";
@_ = grep { -d "$pkg_dbdir/$_" && -f "$pkg_dbdir/$_/+CONTENTS" } readdir(DIR);
closedir DIR;

my %dbdir;	# key is category/portname; value is subdirectory of $pkg_dbdir
my %mtime;	# mtime of +CONTENTS

foreach my $curdir (@_) {
	open IN, "<$pkg_dbdir/$curdir/+CONTENTS" or die "can't open $pkg_dbdir/$curdir/+CONTENTS: $!";
	map {
		$dbdir{$_} = $curdir;
		$mtime{$_} = (stat "$pkg_dbdir/$curdir/+CONTENTS")[9]
	} grep {
		chomp $_;
		$_ =~ s/\@comment ORIGIN://
	} <IN>;
	close IN;
};

map { print("# $dbdir{$_} was orphaned: $_\n"), delete $dbdir{$_} unless -d "$portsdir/$_" } keys %dbdir;

my %requiredby;	# key is required-by array of ports
my %requires;	# key requires array of ports
my %version;	# PORTVERSION [ _PORTREVISION ] [ ,PORTEPOCH ]
my %name;	# port name
my %use_rc_subr;	# rc.d scripts

print "#---dependency list---\n" if $debug > 2;
sub depend;
sub depend {
	my $curport = shift;
	return if exists $version{$curport};
	chomp(@_ = qx(make -C $portsdir/$curport -V RUN_DEPENDS -V LIB_DEPENDS -V DEPENDS -V PORTVERSION -V PORTREVISION -V PORTEPOCH -V PKGNAME -V USE_RC_SUBR));
	$version{$curport} = $_[3] . ($_[4] ? "_$_[4]" : "") . ($_[5] ? ",$_[5]" : "");
	$name{$curport} = substr $_[6], 0, rindex $_[6], "-$version{$curport}";
	$use_rc_subr{$curport} = $_[7] =~ /^yes$/i || !$restart ? "" : $_[7];
	foreach (split /\s+/, join " ", @_[0..2]) {
		next unless $_ =~ /.*:$portsdir\/([^\s:]+).*/;
		print "#", $curport, " depends on ", $1, "\n" if $debug > 2;
		push @{$requires{$curport}}, $1;
		push @{$requiredby{$1}}, $curport;
		$dbdir{$1} = "" unless exists $dbdir{$1};
		depend $1;
	}
}
map { depend $_ } sort keys %dbdir;

my %want;
map { ++$want{$_} } keys %dbdir unless scalar @ARGV;
map { exists $dbdir{$_} ? ++$want{$_} : print "# $_ not installed\n" } @ARGV;

sub wantrequired;
sub wantrequired {
	$_ = shift;
	return unless $want{$_};
	map { ++$want{$_}, wantrequired $_ } @{$requires{$_}};
};
map { wantrequired $_ } keys %want;

# get rid of dangling duplicates
map { my $prev = ""; @{$requires{$_}} = grep { $_ ne $prev && ($prev = $_) } sort @{$requires{$_}} } sort keys %requires;
map { my $prev = ""; @{$requiredby{$_}} = grep { $_ ne $prev && ($prev = $_) } sort @{$requiredby{$_}} } sort keys %requiredby;

print "#---\"requires\" list---\n" if $debug > 1;
map { print "#", $_, " requires ", join(" ", @{$requires{$_}}), "\n" } sort keys %requires if $debug > 1;

print "#---\"required by\" list---\n" if $debug > 1;
map { print "#", $_, " is required by ", join(" ", @{$requiredby{$_}}), "\n" } sort keys %requiredby if $debug > 1;

print "#---leaf ports list---\n" if $debug;
map { print $debug ? "#" : "", "$dbdir{$_} $_\n" } sort { $dbdir{$a} cmp $dbdir{$b} } grep { not exists $requiredby{$_} } sort keys %want if $debug || $leaf;
exit if $leaf;

print "#---dependency tree---\n" if $debug > 1;
sub prdep;
sub prdep {
	print "#", " " x $_[0], $_[1], exists $dbdir{$_[1]} ? "" : " (not installed)", "\n";
	map { prdep $_[0] + 1, $_ } sort @{$requires{$_[1]}} if exists $requires{$_[1]};
}
map { prdep 0, $_ } sort keys %dbdir if $debug > 1;

print "#---version list---\n" if $debug > 2;
map { print "#port=\"$_\" name=\"$name{$_}\" version=\"$version{$_}\" dir=\"$dbdir{$_}\"" . ("$name{$_}-$version{$_}" eq $dbdir{$_} ? " ok" : " NOT OK") . "\n" } keys %dbdir if $debug > 2;

print "#---\n" if $debug;

my %dirty;	# ports that we must rebuild

sub mark;
sub mark {
	my $what = shift;
	return if $dirty{$what};
	++$dirty{$what};
	map { print("# $_ needs updating: depends on $what\n"), mark $_ } @{$requiredby{$what}} if exists $requiredby{$what};
}

# pass 0: not installed ports
map { print("# $_ needs updating: not installed\n"), mark $_ unless $dbdir{$_} } keys %want;

# pass 1: compare versions
map { print("# $_ needs updating: installed $dbdir{$_}, in ports $name{$_}-$version{$_}\n"), mark $_ if $dbdir{$_} && $name{$_} . "-" . $version{$_} ne $dbdir{$_} } keys %want;

# pass 2: compare build time of depending ports
foreach my $curdir (keys %want) {
	map { print("# $_ needs updating: $curdir is more recent than $_\n"), mark $_ if $mtime{$curdir} && $mtime{$_} && $mtime{$curdir} > $mtime{$_} } @{$requiredby{$curdir}} if exists $requiredby{$curdir};
}

# pass 3: forcing ports
map { print("# $_ forced\n"), mark $_ } keys %want if $force;

print "#up to date: ", join(" ", grep { not $dirty{$_} } keys %dbdir), "\n" if $debug;
print "#update required: ", join(" ", grep { $dirty{$_} } keys %dbdir), "\n" if $debug;

my %level;	# maximum depth of the port in the dependency tree

sub remake;
sub remake {
	print "#", "-" x $_[0], $_[1], "\n" if $debug;
	$level{$_[1]} = $_[0] unless exists $level{$_[1]} && $level{$_[1]} >= $_[0];
	map { remake $_[0] + 1, $_ } @{$requiredby{$_[1]}} if exists $requiredby{$_[1]};
}
map { remake 0, $_ } keys %dirty;

my %rc_subr_level;	# depth of where to execute rc script (i.e. after all dependent ports)

foreach (keys %level) {
	my $toplevel = $level{$_};
	map { $toplevel = $level{$_} if $toplevel < $level{$_} } @{$requiredby{$_}} if exists $requiredby{$_};
	map { $_ =~ s/\.sh$//; $rc_subr_level{$_} = $toplevel } (split /\s+/, $use_rc_subr{$_});
}

if (scalar %dirty) {
	foreach my $curlevel (0..((reverse sort { $a <=> $b } values %level)[0])) {
		map { print " " x $curlevel, "make -C $portsdir/$_ $make &&\n" } grep { $level{$_} == $curlevel } keys %level;
		map { print " " x $curlevel, "$prefix/etc/rc.d/$_$rc_subr_suffix restart &&\n" } grep { $rc_subr_level{$_} == $curlevel } keys %rc_subr_level;
	}
	print "true\n";
}

close STDOUT;