autoupdate/autoupdate.pl

#! /usr/bin/perl -w
# $Id: autoupdate.pl,v 1.36 2014/09/07 07:35:06 markus Exp $
# Copyright (c) 2007,2008,2009
#    Markus Hennecke <markus-hennecke@markus-hennecke.de>
#
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

## no critic (RequireBriefOpen)

use strict;
use warnings;

use Cwd;
use File::Spec;
use File::Temp qw/tempfile tempdir/;
use FindBin;
use Getopt::Long;
use IO::Handle;
use List::Util qw/reduce/;
use OpenBSD::PackageName;
use POSIX qw/uname :sys_wait_h :signal_h/;


# Tries to get a variable either from the environment or /etc/mk.conf
# falling back to the passed default value if the variable was not
# found in either location
sub get_mkconf_variable {
	my $var = shift;
	my $default = shift || '';

	if (defined $ENV{$var}) {
		print STDERR "$var = $ENV{$var}\n";
		return $ENV{$var};
	}

	my $mkconf = '/etc/mk.conf';
	return $default if (! -f $mkconf);

	open(my $fh, '-|', 'make', '-f', '/etc/mk.conf', '-V', $var)
	    or die "Unable to query $mkconf for '$var': $!\n";
        my $result = do { local $/ = undef; <$fh> };
	close($fh);
	chomp $result;
	return $result || $default;
}


# Defaults to 1, can be set via the --verbose switch
my $verbose = 1;

# If set logs of the build are written under this directory
my $logdir = undef;

# If set it will show the usage information and exit afterwards
my $show_help = 0;

# If set to more than one it will try to build ports in parallel
my $num_jobs = 1;

# If set to 1 update will take those ports into account flagged for always
# update
my $always_update = 0;

# If set to 1 the make clean part of the ports build will use sudo
my $sudo_make_clean = 0;
my $sudo = get_mkconf_variable('SUDO', '');

# If defined via command line the script will use that file as input for
# out of date ports. If the filename is '-' it will use stdin.
my $out_of_date = undef;

# The default location of the ports tree and the path where we should look
my $portsdir = get_mkconf_variable('PORTSDIR', '/usr/ports');
my $portsdir_path = get_mkconf_variable('PORTSDIR_PATH', "$portsdir:$portsdir/mystuff");

# Number of jobs currently active
my $jobs = 0;

# Number of concurrent jobs in a build
my $make_jobs = 1;

# This hash will hold the PIDs of the forked build processes
my %forked_builds = ();

# Regex used to match a flavor
my $regex_flavor = '((,[a-z][a-z0-9_]*)*)';
# Regex used to match a subpackage
my $regex_subpkg = '(,-[a-z][a-z0-9_+-]*)?';

# List of pseudo flavors we apply if the port supports them
my %pseudo_flavors = ();

# Global abort flag, only set from the reaper func
my $abort = 0;

# Ports that failed to build
my @aborted = ();

# Hash of reaped child processes
my %reaped_pids = ();

# Default signal handler for SIGCHLD
my $old_child_sigaction = POSIX::SigAction->new();

# Status variables for the logging / redirect of STDOUT & STDERR
my ($logpipe, $tee_pid, $stdout_orig, $stderr_orig);

# This function will remove the finished forked build from the list of
# currently build ports.
sub REAPER {
	while ((my $wpid = waitpid(-1, &WNOHANG)) > 0) {
		my $status = $?;
		$abort = 1 if ($status != 0);

		if (!defined($tee_pid) || $wpid != $tee_pid) {
			$reaped_pids{$wpid} = $status;
		}
		else {
			$tee_pid = undef;
		}
	}
	return;
}


# Cleanup the log redirect to the tee child if
sub END {
	if ($logpipe) {
		close($logpipe);
		if ($stderr_orig) {
			close(STDERR);
			open(STDERR, '>&', $stderr_orig);
		}
		if ($stdout_orig) {
			close(STDOUT);
			open(STDOUT, '>&', $stdout_orig);
		}
	}
	if ($tee_pid) {
		waitpid($tee_pid, 0);
	}
	return;
}


# Remove the status codes/PIDs from the reaped_pids hash periodically
sub reap {
	my @pids = keys %reaped_pids;
	while (scalar @pids) {
		my $wpid = shift @pids;
		if (exists $forked_builds{$wpid}) {
			my $portname = $forked_builds{$wpid};
			$jobs--;
			my $status = $reaped_pids{$wpid};
			if ($status == 0) {
				print STDOUT 'Finished build of ';
			}
			else {
				print STDOUT 'Build aborted of ';
				push @aborted, ($portname);
			}
			delete $forked_builds{$wpid};
			print STDOUT $portname . "\n";
		}
		else {
			print STDOUT 'No forked process recorded for '
			  . $wpid . "\n";
		}
		delete $reaped_pids{$wpid};
	}
	return;
}

# Reads a config file and parses the options set in the config file.
# A list of valid options must be passed to the function.
sub read_rc_file {
	my $valid_vars = shift;
	my ($fh, @lines, %config);
	open($fh, '<', "$ENV{HOME}/.autoupdaterc")
	    or return \%config;

	while (<$fh>) {
		chomp;
		s/\t/ /g;
		push @lines, ($_);
	}
	close($fh);

	my $temp_line = '';
	my $append = 0;
	my $real_lineno = 0;
	my $lineno = 0;
	foreach (@lines) {
		$lineno++;

		# Check if we have a multiline statement
		if (m/\\$/) {
			$append++;
			s/\\$//g;
			$temp_line .= $_;
			next;
		}
		elsif ($append != 0) {
			$_ = $temp_line . $_;
			$real_lineno = $lineno - $append;
			$append = 0;
			$temp_line = '';
		}

		# Remove comments and unnecessary whitespace
		s/\#.*$//g;
		s/^[[:space:]]//g;
		s/ *= */=/g;
		s/ +/ /g;
		next if (m/^$/);

		# Check if the line has a = character, if not issue an error
		if (! m/=/) {
			print STDERR 'Not a valid config in line '
			    . $real_lineno . "\n";
			return;
		}

		# Split the line at the first '='
		my $split_index = index($_, '=');
		my $var = substr($_, 0, $split_index);
		my $val = substr($_, $split_index + 1);

		# Check if the varible is valid
		if (defined $valid_vars && defined $valid_vars->{$var}) {
			$config{$var} = $val;
		}
		else {
			print STDERR 'Warning: Unknown variable "' . $var
			    . '" in config file' . "\n";
		}
	}
	return \%config;
}


# Fill a lookup hash from config
sub setup_lookup_hash {
	my $config_line = shift;
	my $hash = shift;
	my $info = shift;

	if (defined $config_line) {
		$config_line =~ tr/,/ /;
		foreach (split / /, $config_line) {
			print STDOUT "Adding $_ to $info\n"
			    unless ($verbose < 2);
			$hash->{$_} = 1;
		}
	}
	return;
}


# Sets up the log directory
sub setup_logging {
	my $config = shift;

	if (defined $config->{logging} && $config->{logging} == 1) {
		my $tmpdir = $ENV{TMPDIR} ? $ENV{TMPDIR} : '/tmp';
		$logdir = tempdir("$tmpdir/autoupdate.XXXXXXXXXX");
		my $logfile = $logdir . '/autoupdate.log';

		pipe my $pipe_out, $logpipe
		    or die "Unable to create pipe: $!\n";
		my $pid = fork();
		if (! defined($pid)) {
			die "Unable to fork: $!\n";
		}
		if ($pid == 0) {
			# child
			POSIX::sigaction(&POSIX::SIGCHLD, $old_child_sigaction)
			    or die "Unable to set SIGCHLD handler: $!\n";

			close($logpipe)
			    or warn "Unable to close pipe endpoint in child: $!\n";
			open(STDIN, '<&=', $pipe_out)
			    or die "Unable to reopen STDIN: $!\n";

			exec 'tee', $logfile;
			exit(1);
		}
		# Parent
		close($pipe_out)
		    or warn "Unable to close pipe endpoint in parent: $!\n";

		open($stdout_orig, '>&', \*STDOUT)
		    or die "Unable to save STDOUT: $!\n";
		open($stderr_orig, '>&', \*STDERR)
		    or die "Unable to save STDERR: $!\n";

		close(STDERR);
		close(STDOUT);

		$logpipe->autoflush(1);

		open(STDERR, '>&', $logpipe)
		    or die "Unable to reopen STDERR: $!\n";
		open(STDOUT, '>&', $logpipe)
		    or die "Unable to reopen STDOUT: $!\n";

		STDOUT->autoflush(1);
		STDERR->autoflush(1);

		print STDOUT qq{Logging builds in "$logdir"\n};
		print STDOUT qq{Using "$logfile" as mainlog\n};
	}
	return;
}


# Returns the ports version or undef if no such version could be deduced
sub get_ports_version {
	my $port = shift;

	chdir "$port" || return;
	my $show = 'show';
	my @uname = POSIX::uname();
	if ($uname[2] > 6.4) {
            $show .= '-indexed';
	}
	my $cmd = "make $show=FULLPKGNAME";
	my $pkgname = '';

	open(my $in, '-|', "$cmd 2>&1")
	    or die "Unable to get version for \"$port\"\n";
	while (<$in>) {
		chomp;
		$pkgname .= $_;
	}
	close($in);

	my ($stem, $version, @flavors)
	    = OpenBSD::PackageName::splitname($pkgname);
	return $version;
}


# Returns an integer according to the version numbers supplied.
# -1 if the first argument is the higher version number
#  0 if both version numbers are equal
# +1 if the second argument is the higher version number
sub get_higher_version {
	my ($ver1, $ver2) = @_;

	if (! defined($ver1)) {
		return 0 if (! defined($ver2));
		return 1;
	}
	elsif (! defined($ver2)) {
		return -1;
	}

	my @vers1 = split /[\.pv]/, $ver1;
	my @vers2 = split /[\.pv]/, $ver2;

	my $max_len = scalar @vers1;
	$max_len = scalar @vers2 if (scalar @vers2 > scalar @vers1);

	my $index;
	for ($index = 0; $index < $max_len; $index++) {
		return -1 if ($index >= scalar @vers2);
		return 1 if ($index >= scalar @vers1);
		my $vers1 = $vers1[$index];
		my $vers2 = $vers2[$index];
		my $cmp;
		if (($vers1 =~ /[a-z]/) || ($vers2 =~ /[a-z]/)) {
			$cmp = ($vers2 cmp $vers1);
		}
		else {
			$cmp = ($vers2 <=> $vers1);
		}
		return $cmp if ($cmp);
	}
	return 0;
}


# Creates an array with the name of all packages that need updates
sub read_update_package_list {
	my $input = shift;
	my ($in, @package_list, $out);

	# Save the output from pkg_outdated in a log file
	if (defined $logdir && !defined $input) {
		open($out, '>', "$logdir/pkg_outdated");
		print STDERR "Warning: Unable to open log for pkg_outdated\n"
		    if (not defined $out);
	}

	if (not defined $input) {
		my $ood_path = 'infrastructure/bin';
		my $cmd = "env PORTSDIR=\"$portsdir\" "
		    . "\"$portsdir/$ood_path/pkg_outdated\" ";
		unless (open($in, '-|', "$cmd 2>/dev/null")) {
			print STDERR "Unable to execute $cmd\n";
			exit 1;
		}
	}
	elsif ($input eq '-') {
		unless (open($in, '<&=', \*STDIN)) {
			print STDERR "Unable to open stdin\n";
			exit 1;
		}
	}
	else {
		unless (open($in, '<', $input)) {
			print STDERR "Unable to open file: " . $input
			    . " for reading\n";
			exit 1;
		}
	}

	while (<$in>) {
		print $out $_ if (defined $out);
		chomp;
		my $pkg = $_;
		$pkg =~ s/ +#.*$//g;
		if ($_ =~ m/\#\s+->/) {
			# Ignore ports that show up every time in pkg_outdated
			print STDERR 'Ignoring ' . $pkg . "\n";
			next;
		}
		if ($_ =~ m/\#\s+always-update\s+->\s+[0-9],/x &&
				!$always_update) {
			print STDERR "Ignoring $pkg (always update)\n";
			next;
		}
		push @package_list, ($pkg);
	}
	close($in);
	close($out) if (defined $out);

	return \@package_list;
}


# Creates an array with a hash for each port that needs an update
sub create_package_information {
	my $pkg_list = shift;

	# Create an array of hashes that has the following data:
	# category	=> name of the ports category
	# port		=> name of the port (the directory in the ports tree)
	# subdir	=> version of the port (for ports with more than one
	#					version, e.q. python)
	# flavor	=> list of flavors as an array reference
	# subpackage	=> name of the subpackage
	my @pkg_information = ();
	foreach my $pkg (@$pkg_list) {
		# Get all the variables from the port identification string
		my ($category, $port, $subdir, $flavor, $subpackage);

		# Each group in the regex has the following meaning:
		# $1 :  category main which may consist of the alphabet
		# $2 :  port name, which must start with at least one alpha
		#	char and may have a number appended.
		#	Some examples may be gtk+2, libIDL etc.
		# $3 :	optional subdirs for the port, $4 will hold the last
		# $5 :  an optional subpackage name, this will start with a
		#	comma followed by an hyphen and have an alphanumeric
		#	identifier
		# $6 :	a list with optional flavors. Each flavor starts with
		#	a comma and may be an alphanumeric identifier
		if ($pkg =~ m/^
				([a-z][a-z0-9]*)\/
				([A-Za-z][\.A-Za-z0-9-+_]*)
				((\/[^,]*)*)?
				$regex_subpkg
				$regex_flavor/x) {
			$category = $1;
			$port = $2;
			$subdir = $3;
			$subpackage = $5;
			$flavor = $6;
			$subdir = '' if (not defined $subdir);
			$subdir =~ s/(^\/|\/$)//g;
			$subpackage = '' if (not defined $subpackage);
			$subpackage =~ s/^,//g;
			$flavor = '' if (not defined $flavor);

			$flavor =~ s/,/ /g;
			$flavor =~ s/^ //g;

			my %p = (
				category => $category,
				port     => $port,
				subdir   => $subdir,
				subpkg   => $subpackage,
				flavor   => $flavor,
				pkg      => $pkg,
			);
			$p{jobs} = set_parallel_build(\%p);
			$p{dependencies} = create_dependencies_list(\%p);
			$p{deppkgs}
				= create_dependencies_hash($p{dependencies});
			$p{pseudo_flavors} = create_pseudo_flavors_list(\%p);
			add_pseudo_flavors(\%p);
			push @pkg_information, (\%p);
		}
		else {
			next if ((not defined $pkg) || ($pkg eq ''));
			print STDERR "Unknown port name: $pkg\n";
			exit 2;
		}
		print STDOUT "Category:\t$category\n"
		    . "Port:\t\t$port\n"
		    . "Subdir:\t\t$subdir\n"
		    . "Subpackage:\t$subpackage\n"
		    . "Flavor:\t\t$flavor\n\n" unless ($verbose < 5);
	}

	return \@pkg_information;
}


# Adds pseudo flavors to the flavors list if they appear both in the
# pseudo_flavors array from the ports info hash and the %pseudo_flavors
# global hash set via command line.
sub add_pseudo_flavors {
	my $info = shift;

	my $flavors = $info->{flavor};

	foreach my $pseudo_flavor (@{$info->{pseudo_flavors}}) {
		if (exists $pseudo_flavors{$pseudo_flavor}) {
			$flavors .= ' ';
			$flavors .= $pseudo_flavor;
		}
	}
	$info->{flavor} = $flavors;
	return;
}


# Creates an array with pseudo flavors. We can check this array against the
# %pseudo_flavors hash to add flavors on demand.
sub create_pseudo_flavors_list {
	my $info = shift;
	my $cur_dir = getcwd;

	my $cmd = 'make show=PSEUDO_FLAVORS';

	# chdir into the ports directory
	my ($port, $port_dir) = find_newer_ports_dir($info);
	chdir $port_dir or die qq{Unable to change to "$port_dir": $!\n};

	open (my $in, '-|', "$cmd")
	    or die qq{Unable to get pseudo flavors for "$port"\n};

	my $output;
	while (<$in>) {
		chomp;
		$output .= $_ . ' ';
	}
	chop $output;
	close($in);
	if ($? != 0) {
		die qq{Unable to get pseudo flavors for "$port\n"};
	}

	my @pseudo_flavors = split / /, $output;
	return \@pseudo_flavors;
}


# Returns the reference of the package information belonging to a package
# name from the package info array. The sub will die if there is no such
# package listed.
# A package listed more than one time, e.g. several subpackages, will
# always return the first subpackage. It is taken care of the update of the
# other subpackages via the ports Makefile, so we should only need this first
# one.
sub get_pkg_info {
	my ($info_array, $pkg_name) = @_;

	foreach my $info (@$info_array) {
		my $info_pkg_name = $info->{pkg};
		$info_pkg_name =~ s/$regex_subpkg$regex_flavor//g;
		return $info if ($info_pkg_name eq $pkg_name);
	}
	die "ERROR: Internal error, package information not consistent.\n";
}


# Tries to find the newest port from directories listed in $PORTSDIR_PATH
# by comparing the output from make show=FULLPKGNAME.
sub find_newer_ports_dir {
	my $info = shift;

	my $port = $info->{category} . '/' . $info->{port};
	$port .= '/' . $info->{subdir} if ($info->{subdir} ne '');

	return ($port, $info->{portdir})
	    if ((defined $info->{portdir}) && ($info->{portdir} ne ''));

	my @port_locations = split /:/, $portsdir_path;
	# Take a shortcut here if we got only one location
	if (scalar @port_locations == 1) {
		$info->{portdir} = "$portsdir_path/$port";
		return ($port, $info->{portdir});
	}

	my @versions = ();
	foreach my $dir (@port_locations) {
		my $port_dir = "$dir/$port";
		my $version = get_ports_version($port_dir);
		push @versions, $version;
	}

	my $highest
	    = reduce { get_higher_version($a, $b) <= 0 ? $a : $b } @versions;
	my $idx = 1;
	$idx = grep
		{ defined($versions[$_])
		    && ($versions[$_] eq $highest) ? $_ : -1 } 0..$#versions
	    if (scalar @versions > 1);
	$info->{portdir} = "$port_locations[$idx - 1]/$port";
	return ($port, $info->{portdir});
}


# (Re)builds a package and updates it.
# The following targets for make are given: repackage, update, clean
# All output from the build process is logged and printed if the package did
# not build.
sub build_pkg {
	my $info = shift;
	my $cur_dir = getcwd();
	my ($port, $port_dir) = find_newer_ports_dir($info);

	my $pid = fork();
	if (! defined $pid) {
		die "Cannot fork to build $port\n";
	}
	elsif ($pid) {
		$forked_builds{$pid} = $port;
		$jobs++;
		return;
	}

	POSIX::sigaction(&POSIX::SIGCHLD, $old_child_sigaction)
	    or die "Unable to set SIGCHLD handler: $!\n";

	# Give the parent time to update the forked_builds hash
	sleep 1;

	# Create the command that will build the package
	my $cmd = 'env ';
	$cmd .= 'MAKE_JOBS=' . $info->{jobs} . ' ' if ($info->{jobs});
	$cmd .= "FLAVOR=\"$info->{flavor}\" " if ($info->{flavor} ne '');
	$cmd .= "SUBPACKAGE=$info->{subpkg} " if ($info->{subpkg} ne '');
	$cmd .= 'make build';

	# chdir into the ports directory
	chdir $port_dir or die "Unable to change to \"$port_dir\"\n";

	print STDOUT "Building $info->{pkg}\n";
	my (@log, $logfile, $logfilename);
	if (defined $logdir) {
		my $tmp = $info->{port};
		$tmp .= "_$info->{subdir}" if ($info->{subdir} ne '');
		$tmp =~ s/\//_/g;
		$logfilename = "$logdir/$tmp.log";
		open($logfile, '>>', $logfilename)
		    or die "Unable to create log file for $info->{pkg}: $!\n";
	}
	open(my $in, '-|', "$cmd 2>&1")
	    or die qq{Unable to make "$port"\n};
	while (<$in>) {
		exit 1 if (/^Detected loop/);

		print STDOUT $_ unless (($verbose < 2) || ($num_jobs > 1));
		print $logfile $_ if (defined $logfile);
		push @log, ($_);
	}
	close($in);
	my $build_result = $?;
	my $update_result = 1;
	if ($build_result == 0) {
		$cmd = '';
		$cmd .= $sudo if ($sudo_make_clean);
		$cmd .= ' env FORCE_UPDATE=Yes CLEANDEPENDS=No ';
		$cmd .= "FLAVOR=\"$info->{flavor}\" "
		    if ($info->{flavor} ne '');
		$cmd .= "SUBPACKAGE=$info->{subpkg} "
		    if ($info->{subpkg} ne '');
		$cmd .= ' make repackage update clean';
		open($in, '-|', "$cmd 2>&1")
		    or die "Unable to update \"$port\"\n";
		while (<$in>) {
			print STDOUT $_
			    unless (($verbose < 2) || ($num_jobs > 1));
			print $logfile $_ if (defined $logfile);
			push @log, ($_);
		}
		close($in);
		$update_result = $?;
	}
	close($logfile) if (defined $logfile);
	if ($build_result != 0 || $update_result != 0) {
		# Something went wrong. We list the output of the make process
		# and kill the update process
		if (!defined $logdir) {
			foreach my $line (@log) {
				print STDOUT $line;
			}
		}
		else {
			print STDERR "Failed: See log in '$logfilename'\n";
		}
		print STDERR "Aborting build process...\n";
		exit 3;
	}

	chdir $cur_dir;
	exit 0;
}


sub set_parallel_build {
	my $info = shift;

	my $cur_dir = getcwd;
	my ($port, $port_dir) = find_newer_ports_dir($info);
	chdir $port_dir or die qq{Unable to change to "$port_dir"\n};

	open(my $in, '-|', 'make', 'show=DPB_PROPERTIES')
	    or die qq{Unable to determine parallel build info for "$port"\n};
	my $parallel = grep { /parallel/x } (<$in>);
	close($in);
	chdir $cur_dir;

	$info->{jobs} = ($parallel) ? $make_jobs : 1;
	return $info->{jobs};
}


# Creates the dependencies list for a given port from the port information
# hash
sub create_dependencies_list {
	my $info = shift;

	my $cur_dir = getcwd;
	my @dep_list = ();

	# Create the command that will give us the dependencies list
	my $cmd = 'env ';
	$cmd .= "FLAVOR=\"$info->{flavor}\" " if ($info->{flavor} ne '');
	$cmd .= "SUBPACKAGE=$info->{subpkg} " if ($info->{subpkg} ne '');
	$cmd .= 'make build-dir-depends';

	# chdir into the ports directory
	my ($port, $port_dir) = find_newer_ports_dir($info);
	chdir $port_dir or die "Unable to change to \"$port_dir\"\n";

	open(my $in, '-|', "$cmd")
	    or die "Unable to get dependencies for \"$port\"\n";
	while (<$in>) {
		chomp;
		push @dep_list, ($_);
	}
	close($in);
	if ($? != 0) {
		die "Unable to gather information for $port\n";
	}

	# Add the port itself to the list
	$port = "$info->{category}/$info->{port}";
	$port .= "/$info->{subdir}" if ($info->{subdir} ne '');
	$port .= ",$info->{subpkg}" if ($info->{subpkg} ne '');
	# Add the flavors in raw form
	if ($info->{flavor} ne '') {
		$port .= ',';
		my $flavs = $info->{flavor};
		$flavs =~ s/ /,/g;
		$port .= $flavs;
	}
	#push @dep_list, ("$port $port");
	chdir $cur_dir;

	return \@dep_list;
}


# Creates a single hash with all dependant packages from the array created
# via create_dependencies_list
sub create_dependencies_hash {
	my $dep_list = shift;
	my %dep_hash;

	foreach my $pkg (@$dep_list) {
		my $key = $pkg;
		$key =~ s/^.* //g;
		$key =~ s/$regex_subpkg$regex_flavor//g;
		$dep_hash{$key} = 1;
	}
	return \%dep_hash;
}


# Returns true if a package with a given name is in the package list array
# The function will ignore flavors and subpackages.
sub is_pkg_in_list {
	my ($pkg_name, $pkgs) = @_;

	foreach my $p (@$pkgs) {
		$p =~ s/$regex_subpkg$regex_flavor//g;
		return 1 if ($p eq $pkg_name);
	}
	return 0;
}


# Returns 1 if one of the dependencies from the arguments pkg info is currently
# build by a child
sub can_pkg_be_build {
	my $pkg = shift;

	my $pkgs = $pkg->{deppkgs};

	my @pkg_list = keys %$pkgs;
	foreach my $pid (keys %forked_builds) {
		my $build_pkg = $forked_builds{$pid};
		return 1 if (is_pkg_in_list($build_pkg, \@pkg_list));
	}

	return 0;
}


# Prints out the usage information on STDERR
sub usage {
	print STDERR "USAGE: autoupdate.pl [options]\n";
	print STDERR "OPTIONS:\n"
	    . " -v|--verbose\t\tSet verbosity level (1..5)\n"
	    . " -f|--outdated\t\tUse file as output from the "
	    . "pkg_outdated script\n"
	    . " -j|--jobs\t\tTry to build packages in parallel\n"
	    . " \t\t\tIf the filename is '-' the input will be\n"
	    . " \t\t\tread from stdin\n"
	    . " -a|--alwaysupdate\tBuild all packages, even those\n"
	    . "\t\t\tflagged as always update\n"
	    . " -h|--help\t\tShow this help\n";
	exit ($show_help ? 0 : 1);
}

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

# Read the command line params
my $result = GetOptions("v|verbose=i" => \$verbose,
			"f|outdated=s" => \$out_of_date,
			"j|jobs=i" => \$num_jobs,
			"a|alwaysupdate" => \$always_update,
			"h|help" => \$show_help);

usage() if ($show_help != 0 || ! $result || $num_jobs < 1);

$out_of_date = File::Spec->rel2abs($out_of_date) if (defined($out_of_date));

my $basedir = $FindBin::Bin;
chdir($basedir);

# Fill the hash with the allowed variables
my %valid_vars = ( 'logging', 1,
		   'make_jobs', 1,
		   'sudo_make_clean', 1,
		   'pseudo_flavors', 1 );

# Read the config and set everything up
my $config = read_rc_file(\%valid_vars);
setup_logging($config);
$make_jobs = $config->{make_jobs} if $config->{make_jobs};
setup_lookup_hash($config->{pseudo_flavors}, \%pseudo_flavors,
		  'pseudo flavors');
$sudo_make_clean = $config->{sudo_make_clean}
    if (defined $config->{sudo_make_clean});

print STDOUT "Reading package list scheduled for update...\n";
my $package_list = read_update_package_list($out_of_date);
print STDOUT "Got " . @$package_list . " packages for update\n";

print STDOUT "Gathering package information...\n";
my $port_info = create_package_information($package_list);

print STDOUT "Merging dependencies...\n";
my @dep_list = ();
my @package_dep_list = ();
# Get the dep list of each port
foreach my $info (@$port_info) {
	my $deps = $info->{dependencies};
	push @dep_list, @$deps
}

print STDOUT "Create dependencies...\n";
my ($fh, $file, $pipe);
($fh, $file) = tempfile(UNLINK => 1);
open($pipe, '|-', "tsort -r >$file") or die "ERROR: Unable to spawn tsort\n";
foreach my $dep_entry (@dep_list) {
	# Zap the flavors and the subpackages for our dep list
	$dep_entry =~ s/$regex_subpkg$regex_flavor//g;
	print "$dep_entry\n" unless ($verbose < 5);
	print $pipe "$dep_entry\n";
}
close $pipe;
die "ERROR: Internal error\n" if ($? != 0);

# Read the result
while (<$fh>) {
	my $pkg = $_;
	chomp $pkg;
	push @package_dep_list, ($pkg);
}
close $fh;

print STDOUT "Got " . @package_dep_list . " packages as dependencies\n"
    unless ($verbose < 1);

print STDOUT "Removing unneeded packages...\n";
# Remove all packages from @package_dep_list that are not in the @package_list
# array, so that only those packages may be build that are in need.
my @pkg_list = ();
foreach my $pkg_name (@package_dep_list) {
	if (is_pkg_in_list($pkg_name, $package_list) == 1) {
		push @pkg_list, ($pkg_name);
	}
}
if ($verbose > 1) {
	print STDOUT "Got " . @pkg_list . " packages for building:\n";
	foreach my $pkg_name (@pkg_list) {
		print STDOUT $pkg_name . "\n";
	}
}

POSIX::sigaction(
	&POSIX::SIGCHLD,
	POSIX::SigAction->new(
		\&REAPER, POSIX::SigSet->new(), &POSIX::SA_NODEFER
	),
	$old_child_sigaction
) or die "Unable to set SIGCHLD signal handler: $!\n";

# Build all the packages. Packages that are still unknown to us are ignored.
foreach my $pkg_name (@pkg_list)  {

	reap();

	# Get the package information from the info array
	my $info = get_pkg_info($port_info, $pkg_name);

	if (not defined $info) {
		print STDERR "Unable to retrieve package information for "
		    . $pkg_name . "\n";
		next;
	}

	my $wait_for_dep_notice = 0;

	# XXX Here we must check if the package depends on a currently build
	# package too.
	while (($jobs >= $num_jobs || can_pkg_be_build($info)) && !$abort) {
		if ($wait_for_dep_notice == 0 && !can_pkg_be_build($info)) {
			print STDOUT "Waiting for dependant package to finish "
			    . "building ($pkg_name)\n"
				unless ($verbose < 2);
			$wait_for_dep_notice++;
		}
		reap();
		sleep 1;
	}

	last if ($abort != 0);
	build_pkg($info);
}

# Wait for all childs to finish
while (scalar (keys %forked_builds)) {
	sleep 1;
	reap();
}

POSIX::sigaction(
	&POSIX::SIGCHLD,
	$old_child_sigaction
) or warn "Unable to set SIGCHLD signal handler: $!\n";

die "Abort requested by child\n" if ($abort != 0);
print STDOUT "Done.\n";

exit 0;