sboupgrade

#!/usr/bin/perl
#
# vim: ts=4:noet
#
# sboupgrade
# script to upgrade (a) SlackBuild(s) by name
#
# authors: Jacob Pipkin <j@dawnrazor.net>
#          Luke Williams <xocel@iquidus.org>
#          Andreas Guldstrand <andreas.guldstrand@gmail.com>
# maintainer: K. Eugene Carlson <kvngncrlsn@gmail.com>
# license: MIT License

use 5.16.0;
use strict;
use warnings FATAL => 'all';
use SBO::Lib qw/ :config :const :colors %old_libs auto_reverse check_x32 check_x64 check_multilib error_code get_available_updates prompt usage_error slackbuilds_or_fetch uniq get_full_reverse_queue get_sbo_locations get_sbo_location get_inst_names get_installed_cpans get_installed_packages get_build_queue get_orig_location get_readme_contents get_requires get_user_group ignore_tests in ineligible_compat installed_solibs is_obsolete merge_queues on_blacklist open_fh user_group_do_not_exist user_prompt process_sbos print_failures rationalize_queue series_check slurp solib_check verify_gpg %config show_version lint_sbo_config wrapsay %concluded %warnings /;
use Getopt::Long qw(:config bundling);
use File::Basename;
use File::Copy;

my $self = basename($0);

sub show_usage {
    print <<"EOF";
Usage: $self (options) sbo ...
Usage: $self --all

Options (defaults shown first where applicable):
  -h|--help:
    this screen.
  -v|--version:
    version information.
  --(no)color:
    (do not) use sbotools color output.
  --(no)wrap:
    (do not) wrap sbotools output.
  --all
    this flag upgrades everything reported by sbocheck(1).
  --all-plus-failures
    like --all; also rebuild SBo packages failing solibs and other tests.
  --batch:
    like nointeractive, but calculates dependencies (use with caution).
  -b|--build-ignore (FALSE|TRUE):
    if TRUE, only offer to upgrade on version changes.
  -c|--noclean (FALSE|TRUE):
    if TRUE, do not clean working directories after building.
  -D|--dry-run:
    show the potential queue and exit
  -d|--distclean (FALSE|TRUE):
    if TRUE, delete downloaded source archives and the completed package.
  -e|--etc-profile (FALSE|TRUE):
    if TRUE, source all executable *.sh scripts in /etc/profile.d.
  -f|--force:
    force an upgrade, even if the version and build number are the same.
  -i|--noinstall:
    do not run upgradepkg at the end of the build process.
  -j|--jobs (FALSE|#):
    specify the number of parallel jobs (make).
  -k|--pkg-dir (FALSE|/path):
    set to an absolute path to save compiled packages here, or to FALSE.
  -L|--log-dir (FALSE|/path):
    set to an absolute path to save build logs here, or to FALSE.
  -N|--nonet (FALSE|TRUE):
    if TRUE, do not allow network access when running SlackBuilds.
  -o|--norecall:
    do not use saved build options with nointeractive.
  -p|--compat32:
    install a -compat32 package (multilib systems only).
  -q|--reverse-rebuild:
    rebuild the reverse dependency queue after upgrading.
  -r|--nointeractive:
    non-interactive; skips README and all prompts.
  -S|--strict-upgrades (FALSE|TRUE):
    if TRUE, SBo upgrades only when the version or build number is higher.
  -X|--so-check (FALSE|TRUE):
    if TRUE, check for missing .so dependencies if needed.
  -z|--force-reqs:
    rebuild dependencies as well.
EOF
	return 1;
}

my ($help, $vers, $force, $no_install, $no_recall, $non_int, $force_reqs, $reverse, $compat32, $all, $yes_really, $dry_run, $noclean, $distclean, $jobs, $pkg_dir, $log_dir, $build_ignore, $strict_upgrades, $gpg, $etc_profile, $nocolor, $color, $socheck, $wrap, $nowrap, $nonet, $all_fails);

my $options_ok = GetOptions(
	'help|h'            => \$help,
	'version|v'         => \$vers,
	'noclean|c=s'       => \$noclean,
	'distclean|d=s'     => \$distclean,
	'force|f'           => \$force,
	'noinstall|i'       => \$no_install,
	'norecall|o'        => \$no_recall,
	'jobs|j=s'          => \$jobs,
	'reverse-rebuild|q' => \$reverse,
	'nointeractive|r'   => \$non_int,
	'force-reqs|z'      => \$force_reqs,
	'build-ignore|b=s'	=> \$build_ignore,
	'all'               => \$all,
	'strict-upgrades|S=s' => \$strict_upgrades,
	'compat32|p'        => \$compat32,
	'batch'             => \$yes_really,
	'dry-run|D'         => \$dry_run,
	'etc-profile|e=s'   => \$etc_profile,
	'pkg-dir|k=s'       => \$pkg_dir,
	'log-dir|L=s'       => \$log_dir,
	'nocolor'           => \$nocolor,
	'color'             => \$color,
	'so-check|X=s'      => \$socheck,
	'nowrap'            => \$nowrap,
	'wrap'              => \$wrap,
	'nonet|N=s'         => \$nonet,
	'all-plus-failures' => \$all_fails,
);

if ($help) {
	show_usage();
	wrapsay "\nNon-root users can call $self with -D, -v and -h." unless $< == 0;
	exit 0;
}
if ($vers) { show_version(); exit 0 }
$config{COLOR} = $color ? 'TRUE' : 'FALSE' if $color xor $nocolor;
$config{NOWRAP} = $nowrap ? 'TRUE' : 'FALSE' if $wrap xor $nowrap;
unless ($< == 0 or $dry_run) {
	show_usage();
	usage_error "\nNon-root users can call $self with -D, -v and -h.";
}
unless ($options_ok) {
	show_usage();
	usage_error "\nOne or more invalid options detected.";
}

$config{NOCLEAN} = $noclean if $noclean;
$config{DISTCLEAN} = $distclean if $distclean;
$config{BUILD_IGNORE} = $build_ignore if $build_ignore;
$config{GPG_VERIFY} = $gpg if $gpg;
$config{STRICT_UPGRADES} = $strict_upgrades if $strict_upgrades;
$config{ETC_PROFILE} = $etc_profile if $etc_profile;
$config{PKG_DIR} = $pkg_dir if $pkg_dir;
$config{LOG_DIR} = $log_dir if $log_dir;
$config{SO_CHECK} = $socheck if $socheck;
$config{JOBS} = $jobs if $jobs;
$config{NONET} = $nonet if $nonet;

lint_sbo_config($self, %config);

# warn about missing local overrides directory (stop the show if --batch
# or --nointeractive))
if ($config{LOCAL_OVERRIDES} ne "FALSE" and not -d $config{LOCAL_OVERRIDES}) {
	usage_error "$config{LOCAL_OVERRIDES} is specified as the overrides directory, but does not exist. Exiting." if $yes_really or $non_int;
	if ($dry_run) {
		wrapsay_color $color_lesser, "$config{LOCAL_OVERRIDES} is specified as the overrides directory, but does not exist.";
	} else {
		unless (prompt($color_lesser, "$config{LOCAL_OVERRIDES} is specified as the overrides directory, but does not exist.\nContinue anyway?", default => 'no')) {
			exit 0;
		}
	}
}

usage_error("force-reqs is incompatible with nointeractive.") if $non_int && $force_reqs;
usage_error("reverse-rebuild is incompatible with noinstall.") if $reverse && $no_install;
usage_error("all is incompatible with compat32.") if $compat32 && $all;
usage_error("all-plus-failures is incompatible with compat32.") if $compat32 && $all_fails;
usage_error("all is incompatible with all-plus-failures.") if $all_fails && $all;

$yes_really = 1 if $dry_run;
$non_int = 1 if $yes_really;
$all = 1 if $all_fails;

if ($config{GPG_VERIFY} eq "TRUE" and not ($dry_run and $< != 0)) { verify_gpg(); }

# if we can't find SLACKBUILDS.TXT in $config{SBO_HOME}, prompt to fetch the tree
slackbuilds_or_fetch();
my %locations = get_sbo_locations();

my ($updates, @failed_test);
if ($all) {
	slackbuilds_or_fetch();
	wrapsay_color $color_notice, "Checking for updated SlackBuilds...";
	if ($config{BUILD_IGNORE} eq "TRUE") {
		$updates = get_available_updates('VERS');
	} else {
		$updates = get_available_updates('BOTH');
	}
	push @ARGV, map { $_->{name} } @$updates;
	if ($all_fails) {
		my @installed_sbos = @{ get_installed_packages('SBO') };
		if (@installed_sbos) {
			my (@bad_solibs, @bad_perl, @bad_python, @bad_ruby);
			my $sbo_pkg = +{ map {; $_->{name}, $_->{pkg} } @installed_sbos };
			wrapsay_color $color_notice, "Checking packges for missing shared objects...";
			for my $sbo (keys %$sbo_pkg) {
				next if in $sbo, @ARGV or on_blacklist $sbo or ignore_tests $sbo;
				unless (solib_check($sbo_pkg->{$sbo})) {
					push @ARGV, $sbo;
					push @bad_solibs, $sbo;
				}
			}
			if (@bad_solibs) {
				print "\n";
				wrapsay_color $color_lesser, "Rebuilding for missing solibs:";
				for (sort @bad_solibs) {
					print "  $_\n";
				}
				print "\n";
			}
			wrapsay_color $color_notice, "Checking packges for system incompatibility...";
			my @series_to_check = ("perl", "python", "ruby");
			for my $sbo (keys %$sbo_pkg) {
				next if in $sbo, @ARGV or on_blacklist $sbo or ignore_tests $sbo;
				my @results = series_check($sbo_pkg->{$sbo}, @series_to_check);
				push @bad_perl, $sbo unless $results[0];
				push @bad_python, $sbo unless $results[1];
				push @bad_ruby, $sbo unless $results[2];
			}
			push @ARGV, @bad_perl, @bad_python, @bad_ruby;
			push @failed_test, @bad_solibs, @bad_perl, @bad_python, @bad_ruby;
			if (@bad_perl) {
				print "\n";
				wrapsay_color $color_lesser, "Rebuilding for perl incompatibility:";
				for (sort @bad_perl) {
					print "  $_\n";
				}
				print "\n";
			}
			if (@bad_python) {
				print "\n";
				wrapsay_color $color_lesser, "Rebuilding for python incompatibility:";
				for (sort @bad_python) {
					print "  $_\n";
				}
				print "\n";
			}
			if (@bad_ruby) {
				print "\n";
				wrapsay_color $color_lesser, "Rebuilding for ruby incompatibility:";
				for (sort @bad_ruby) {
					print "  $_\n";
				}
				print "\n";
			}
		}
	}
	unless (@ARGV) { print "Nothing to update."; exit 0; }
	@ARGV = uniq @ARGV;
}

if (!@ARGV) { show_usage(); exit 1 }

my @sbos;

# if a requested compat32 script is ineligible anyway,
# do not bother with its dependencies, etc.
#
# also check here for incompatible architecture
if (@ARGV) {
	for my $sbo (@ARGV) {
		my $sbo_location = get_sbo_location($sbo);
		unless ($sbo_location) {
			wrapsay_color $color_lesser, "$sbo not found; skipping.";
			next;
		}
		if ($compat32 or $sbo =~ /-compat32$/) {
			if (my $msg = ineligible_compat $sbo_location) {
				wrapsay_color $color_lesser, $msg;
				next;
			}
		} elsif ($arch !~ /64/) {
			if (check_x64 $sbo_location) {
				wrapsay_color $color_lesser, "$sbo is 64-bit only; skipping.";
				next;
			}
		} elsif ($arch =~ /64/ and not check_multilib()) {
			if (check_x32 $sbo_location) {
				wrapsay_color $color_lesser, "$sbo is 32-bit only; skipping.";
				next;
			}
		}
		push @sbos, $sbo;
	}
}
if (@ARGV and not @sbos) { exit 0; }
@sbos = uniq @sbos;

# Filter out standard packages
my $std_installs = get_inst_names(get_installed_packages('STD'));
my %std_names;
$std_names{$_} = 1 for @$std_installs;
@sbos = grep { not $std_names{$_} } @sbos;

# get a list of installed SBos to check upgradability against,
# and perl modules from CPAN
my $inst_names = get_inst_names(get_installed_packages('SBO'));
my %inst_names;
$inst_names{$_} = 1 for @$inst_names;
my %updates;
unless ($non_int and $force) {
	if ($config{BUILD_IGNORE} eq "TRUE") {
		$updates = get_available_updates('VERS') unless defined $updates;
	} else {
		$updates = get_available_updates('BOTH') unless defined $updates;
	}
	$updates{$$_{name}} = 1 for @$updates;
}
my ($pms, $defective);
unless ($config{CPAN_IGNORE} eq "TRUE") {
	($pms, $defective) = get_installed_cpans();
	s/::/-/g for @$pms;
	s/::/-/g for @$defective;
}

my ($upgrade_queue, @needs_reverse, $needs_rationalize);

# ensure that compat32 is picked up on the upgrade list
if ($compat32) {
	for my $sbo (@sbos) { $sbo = "$sbo-compat32" unless $sbo =~ /-compat32$/; }
}

# doesn't matter what's updatable and what's not if force is specified,
# but without force, we only want to upgrade upgradable packages while
# accounting for all-plus-failures
if ($non_int and not $reverse and not $yes_really) {
	# --force, non-interactive
	if ($force) {
		for my $sbo (@sbos) {
			push @$upgrade_queue, $sbo if $inst_names{$sbo};
			if (auto_reverse($sbo) and not $no_install) {
				push @needs_reverse, $sbo;
				wrapsay_color $color_notice, "Reverse dependency rebuild for $sbo." unless not $all and not $compat32 and $sbo =~ m/-compat32$/;
			}
		}
	# non-interactive, no --force
	} else {
		for my $sbo (@sbos) {
			push @$upgrade_queue, $sbo if $updates{$sbo} or in $sbo, @failed_test;
			if (auto_reverse($sbo) and not $no_install) {
				push @needs_reverse, $sbo;
				wrapsay_color $color_notice, "Reverse dependency rebuild for $sbo." unless not $all and not $compat32 and $sbo =~ m/-compat32/;
			}
		}
	}
} else {
	my @notified;
	for my $sbo (@sbos) {
		next if exists $concluded{$sbo};
		unless ($force_reqs or $force) {
			next unless $updates{$sbo} or in $sbo, @failed_test;
		}
		my $queue = get_build_queue([$sbo]);
		unless ($force_reqs) {
			@$queue = grep { !$inst_names{$_} or $updates{$_} or in $_, @failed_test} @$queue;
		}
		push @$queue, $sbo if $force;
		$upgrade_queue = merge_queues($upgrade_queue, $queue);
	}
	if ($reverse) {
		my $extra_queue = get_full_reverse_queue($self, $updates, @$upgrade_queue);
		if ($extra_queue) {
			$upgrade_queue = merge_queues($upgrade_queue, $extra_queue);
		}
		$needs_rationalize = 1;
	}
	# no --reverse-rebuild; trigger automatic rebuilds unless --no-install
	unless ($no_install or $reverse) {
		for my $sbo (@$upgrade_queue) {
			if (auto_reverse($sbo)) {
				push @needs_reverse, $sbo;
				wrapsay_color $color_notice, "Reverse dependency rebuild for $sbo." unless in $sbo, @notified or (not $all and not $compat32 and $sbo =~ m/-compat32$/);
				push @notified, $sbo;
			}
		}
	}
}

# handle all automatic reverse dependency rebuilds here
if (@needs_reverse and not $no_install and not $reverse) {
	$needs_rationalize = 1;
	my $extra_queue = get_full_reverse_queue($self, $updates, @needs_reverse);
	if ($extra_queue) {
		$upgrade_queue = merge_queues($upgrade_queue, $extra_queue);
	}
}

my $cqueue;

# Get user input regarding upgrades
my (@temp_queue, %commands, %options, %missing_user_group);
my (@see_readme, %saved_options);
$upgrade_queue = rationalize_queue($upgrade_queue) if $needs_rationalize;
FIRST: for my $sbo (@$upgrade_queue) {
	next FIRST if $std_names{$sbo};
	my $name = $sbo;
	if ($compat32 and $sbo !~ /-compat32$/) {
		next FIRST unless $updates{$sbo} or not $inst_names{$sbo};
	}
	$sbo =~ s/-compat32//;

	$locations{$name} = get_sbo_location($name) unless $locations{$name};
	if ($name =~ /-compat32$/ and $locations{$name}) {
		my $compat_fail_msg = ineligible_compat($locations{$name});
		if ($compat_fail_msg) { wrapsay_color $color_lesser, $compat_fail_msg; next FIRST; }
	}

	if (defined $warnings{$name} and $warnings{$name} eq 'nonexistent') {
		next FIRST if is_obsolete($sbo);
		unless ($inst_names{$name}) {
			wrapsay "Unable to locate $name in the SlackBuilds.org tree.";
			unless ($non_int) {
				exit 0 unless prompt($color_default, "Do you want to ignore it and continue?", default => 'yes');
			}
		}
		next FIRST;
	}
	# will give %README% advisories later for --dry-run
	push @see_readme, $name if defined $warnings{$name} and $warnings{$name} eq '%README%';

	if ($name =~ /^perl-/ and $config{CPAN_IGNORE} ne "TRUE" and not $inst_names{$name}) {
		my $pm_name = $sbo;
		$pm_name =~ s/^perl-//;
		for my $pm (@$pms) {
			if ($pm =~ /^$pm_name$/i) {
				say "sbo installed via the CPAN.";
				next FIRST;
			}
			for my $pm (@$defective) {
				if ($pm =~ /^$pm_name$/i) {
					wrapsay "$sbo installed via the CPAN, but file(s) missing.";
				}
			}
		}
	}

	unless ($non_int) {
		my ($proceed, $cmds, $opts) = user_prompt($name, $locations{$name});
		next FIRST unless $proceed;
		push(@temp_queue, $name);
		$commands{$name} = $cmds;
		$options{$name} = $opts;
		unless ($no_install) {
			say "$name added to upgrade queue.";
		} else {
			say "$name added to build queue.";
		}
	} else {
		# for --batch, check for existing user and group, exiting
		# with a message if not
		if ($yes_really) {
			my $cmds;
			if ($no_recall) {
				$cmds = get_user_group($sbo, $locations{$sbo});
			} else {
				if (-s "/var/log/sbotools/$sbo") {
					chomp(my $saved_opts = slurp "/var/log/sbotools/$sbo");
					$cmds = get_user_group($sbo, $locations{$sbo}, $saved_opts);
				} else {
					$cmds = get_user_group($sbo, $locations{$sbo});
				}
			}
			if ($$cmds[0]) {
				my $nonexistent = user_group_do_not_exist(@$cmds);
				if (@$nonexistent) {
					if ($dry_run) {
						$missing_user_group{$name} = $nonexistent;
					} else {
						wrapsay_color $color_warn, "A required user or group is missing for $sbo:", 1;
						for my $cmd (@$nonexistent) { say $cmd; }
						say "";
						error_code("Run the command(s) to install $sbo with --batch.", _ERR_USR_GRP);
					}
				}
			}
		}
		# reuse build options automatically if non-interactive
		# unless norecall is used
		unless ($no_recall) {
			my $opts_log = "/var/log/sbotools/$sbo";
			if (-f $opts_log) {
				my ($prev_fh, $exit) = open_fh($opts_log, '<');
				if ($exit) {
					warn_color $color_lesser, $prev_fh;
				} else {
					chomp(my $opts = <$prev_fh>);
					$saved_options{$name} = $opts if $dry_run;
					$options{$name} = $opts;
				}
			}
		}
		push(@temp_queue, $name);
		unless ($no_install) {
			say "\n$name added to upgrade queue." unless $dry_run;
		} else {
			say "\n$name added to build queue." unless $dry_run;
		}
	}
}
@$upgrade_queue = @temp_queue;

unless (exists $$upgrade_queue[0]) { say "Nothing to update."; exit 0; }
if ($dry_run) {
	if (@see_readme) {
		wrapsay_color $color_lesser, "\nSee README for:";
		for my $item (@see_readme) { say "  $item"; }
	}
	if (%saved_options) {
		wrapsay_color $color_notice, "\nSaved build options to be used:";
		for my $item (keys %saved_options) { say "  $item: $saved_options{$item}"; }
	}
	if ($config{NONET} eq "TRUE") {
		wrapsay_color $color_lesser, "\nBlocking network access for SlackBuilds.";
	}
}
unless ($no_install) {
	wrapsay "\nUpgrade queue: ". join(' ', @$upgrade_queue);
} else {
	wrapsay "\nBuild queue: ". join(' ', @$upgrade_queue);
}
unless ($non_int) {
	wrapsay_color $color_notice, "\n--noinstall (-i) is in use; built packages will not be installed." if $no_install;
	wrapsay_color $color_lesser, "\nBlocking network access for SlackBuilds." if $config{NONET} eq "TRUE";
	exit 0 unless prompt($color_notice, "\nAre you sure you wish to continue?", default => 'yes');
}
if ($dry_run) {
	wrapsay_color $color_notice, "\n--noinstall (-i) is in use; built packages will not be installed." if $no_install;
	my $usr_grp_missing;
	if (%missing_user_group) {
		for my $item (keys %missing_user_group) {
			wrapsay_color $color_lesser, "\nA required user or group is missing for $item:", 1;
			for my $cmd (@{ $missing_user_group{$item} }) { say $cmd; }
			say "";
			wrapsay_color $color_lesser, "Run the command(s) to install $item with --batch.";
			$usr_grp_missing = 1;
		}
	}
	exit _ERR_USR_GRP if $usr_grp_missing;
	exit 0;
}

my @solib_search;
if ($config{SO_CHECK} eq "TRUE") {
	wrapsay_color $color_notice, "Checking for shared objects installed in the upgrade queue...";
	my @before_installed = @{ get_installed_packages("SBO") };
	my $installed_pkg = +{ map {; $_->{name}, $_->{pkg} } @before_installed };
	for my $sbo (@$upgrade_queue) {
		next unless exists $inst_names{$sbo};
		my $pkg = $installed_pkg->{$sbo};
		if (my @pkg_solibs = installed_solibs $pkg) { push @solib_search, $_ for (@pkg_solibs); }
	}
}

my ($failures, $exit) = process_sbos(
	TODO      => $upgrade_queue,
	CMDS      => \%commands,
	OPTS      => \%options,
	LOCATIONS => \%locations,
	NOINSTALL => $no_install,
	NON_INT   => $non_int,
);
print_failures($failures);

if ($config{SO_CHECK} eq "TRUE" and @solib_search and not $no_install) {
	print "\nChecking for broken shared object dependencies from this upgrade...";
	my (@actionable, @log_output);
	my @new_installed = @{ get_installed_packages("SBO", 1) };
	my $installed_pkg = +{ map {; $_->{name}, $_->{pkg} } @new_installed };
	my $installed_vers = +{ map {; $_->{name}, $_->{version} } @new_installed };
	my $pkg_count = @new_installed;
	my $count = 0;
	if ($pkg_count) {
		$| = 1;
		for my $sbo (keys %$installed_pkg) {
			$count++;
			print "\rChecking for broken shared object dependencies from this upgrade... ($count / $pkg_count)";
			next if ignore_tests $sbo;
			push @actionable, $sbo unless solib_check($installed_pkg->{$sbo}, @solib_search);
		}
		$| = 0;
		if (@actionable) {
			wrapsay_color $color_lesser, "\nThe following packages may require rebuilding:", 1;
			for my $sbo (sort @actionable) { print "  $sbo\n"; }
			for my $sbo (sort @actionable) { push @log_output, "$sbo $installed_vers->{$sbo}:\n$old_libs{$installed_pkg->{$sbo}}\n"; }
			my $logfile = '/var/log/sboupgrade-solibs.log';
			unlink $logfile if -f $logfile;
			my ($log_fh, $exit) = open_fh($logfile, '>');
			if ($exit) {
				warn_color $color_lesser, $log_fh;
			} else {
				say {$log_fh} $_ for @log_output;
				close $log_fh;
				wrapsay "\nSee $logfile for details.";
			}
		} else {
			wrapsay_color $color_notice, "\nNo broken dependencies from this upgrade found.";
		}
	}
} elsif ($config{SO_CHECK} eq "TRUE" and not @solib_search and not $no_install) {
	wrapsay_color $color_notice, "\nNo outgoing package provided shared objects. Skipping the shared object check.";
}

if ($exit) {
	exit $exit;
} else {
	exit 0;
}

END { say ""; }