#!/usr/bin/perl
#
# vim: ts=4:noet
#
# sbocheck
# script to update the local sbo tree and check for updates
#
# 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/ update_tree build_cmp get_all_available get_available_updates get_installed_packages get_removed_builds get_obsolete script_error open_fh in is_local is_obsolete show_version get_local_outdated_versions on_blacklist open_read series_check solib_check $slackbuilds_txt slackbuilds_or_fetch verify_gpg lint_sbo_config version_cmp usage_error wrapsay :colors %old_libs %config /;
use Getopt::Long qw(:config no_ignore_case_always bundling);
use File::Basename;
use List::Util 'max';
use Data::Dumper;

my $self = basename($0);

sub show_usage {
	print <<"EOF";
Usage: $self (options)

Options:
  -h|--help:
    this screen.
  -v|--version:
    version information.
  --(no)color:
    (do not) use sbotools color output.
  --(no)wrap:
    (do not) wrap sbotools output.
  -C|--check-all-packages:
    check all installed packages for missing shared objects.
  -c|--check-package:
    check one or more packages for missing shared objects.
  -g|--gpg-verify:
    perform gpg verification.
  -O|--obsolete-check:
    download updated obsolete script list and perl version history.
  -n|--nopull:
    run without updating the tree.
  -t|--type:
    a comma-separated list of package tests to run.
	  default: solibs
	  available: perl,python,ruby,solibs
	  use all available: all
  -X|--so-check:
    check for missing shared objects only, all SBO packages.
EOF
	return 1;
}

my $line_needed = 1;

my ($help, $vers, $gpg, $nopull, $obsolete_check, $nocolor, $color, $socheck, $pkg_check, $full_check, $nowrap, $wrap, $solibs, $perl, $python, $ruby, $type, @types);

my @valid_types = ("solibs", "perl", "python", "ruby");

my $options_ok = GetOptions('help|h' => \$help, 'version|v' => \$vers, 'gpg-verify|g' => \$gpg, 'obsolete-check|O' => \$obsolete_check, 'nopull|n' => \$nopull, 'nocolor' => \$nocolor, 'color' => \$color, 'nowrap' => \$nowrap, 'wrap' => \$wrap, 'X|so-check' => \$socheck, 'c|check-package' => \$pkg_check, 'C|check-all-packages' => \$full_check, 't|type=s' => \$type);

if ($help) {
	show_usage();
	wrapsay "\nNon-root users can call $self with -C -c, -n, -t, -X, -h and -v." 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 $nowrap xor $wrap;
if ($< != 0) { $config{GPG_VERIFY} = "FALSE"; }
unless ($options_ok) {
	show_usage();
	usage_error "\nOne or more invalid options detected.";
}

if ($type) {
	$socheck = ($socheck or $pkg_check or $full_check) ? $socheck : 1;
	@types = split ",", $type;
	if (in "all", @types) {
		@types = @valid_types;
	} else {
		for (@types) { usage_error "Valid check types include: @valid_types." unless in $_, @valid_types; }
	}
} else {
	push @types, "solibs";
}
$perl = in "perl", @types;
$python = in "python", @types;
$ruby = in "ruby", @types;
$solibs = in "solibs", @types;

unless ($< == 0 or ($nopull and not $gpg) or $socheck or $pkg_check or $full_check) {
	show_usage();
	usage_error "Non-root users can call $self with -C, -c, -n, -t, -X, -h and -v." unless $< == 0;
}

usage_error "obsolete-check is incompatible with nopull." if $nopull and $obsolete_check;
usage_error "so-check, check-all-packages and check-package are incompatible with each other." if ($socheck and $pkg_check) or ($socheck and $full_check) or ($pkg_check and $full_check);
usage_error "pkg-check requires a list of packages." if $pkg_check and not @ARGV;

lint_sbo_config($self, %config);

unless ($gpg) {
	$gpg = $config{GPG_VERIFY};
	$gpg = $gpg eq 'TRUE' ? 1 : 0;
}
if ($gpg and $nopull) { verify_gpg(); }
elsif ($gpg) { $config{GPG_VERIFY} = "TRUE"; }

if ($obsolete_check) {
	wrapsay_color $color_notice, "Not updating the SlackBuilds tree...";
	get_obsolete;
	exit 0;
}

my $auto_series = ($config{SO_CHECK} eq "TRUE" and not ($socheck or $pkg_check or $full_check));

update_tree() unless $nopull or $socheck or $pkg_check or $full_check;
if ((($nopull or $socheck) and slackbuilds_or_fetch()) or $pkg_check or $full_check) {
	wrapsay_color $color_notice, "Not updating the SlackBuilds tree...";
	wrapsay_color $color_notice, "Not writing log files..." unless $< == 0 or $socheck or $pkg_check or $full_check or $perl or $python or $ruby or $auto_series;
}
get_all_available();

# In case of package tests
my @requested = @ARGV if $pkg_check;
my (@to_check, @missing, @installed, $installed_pkg, $installed_vers, $scope, $pkg_count);
if ($socheck or $pkg_check or $full_check or $auto_series) {
	$scope = ($pkg_check or $full_check) ? "ALL" : "SBO";
	@installed = @{ get_installed_packages($scope) };
	$installed_pkg = +{ map {; $_->{name}, $_->{pkg} } @installed };
	$installed_vers = +{ map {; $_->{name}, $_->{version} } @installed };
	for my $request (@requested) {
		if (exists $installed_pkg->{$request}) {
			push @to_check, $request;
		} else {
			push @missing, $request;
		}
	}
	$pkg_count = $pkg_check ? @to_check : @installed;
}
wrapsay_color $color_lesser, "Not installed: ". join", ", @missing if @missing;

my (@bad_perl, @bad_python, @bad_ruby);

# check for and display packages that appear to be incompatible with
# system perl, python or ruby
sub evaluate_series {
	script_error("evaluate_series requires \$perl, \$python or \$ruby.") unless $perl or $python or $ruby or $auto_series;
	my @series_to_check;
	if ($auto_series) {
		push @series_to_check, "perl", "python", "ruby";
	} else {
		push @series_to_check, "perl" if $perl;
		push @series_to_check, "python" if $python;
		push @series_to_check, "ruby" if $ruby;
	}

	my $msg = "Checking packages for system incompatibility...";
	print "\n$msg";
	my $count = 0;
	return unless $pkg_count;
	$| = 1;
	for my $sbo (keys %$installed_pkg) {
		if ($pkg_check) {
			next unless in $sbo, @to_check;
		}
		$count++;
		print "\r$msg ($count / $pkg_count)";
		my @results = series_check($installed_pkg->{$sbo}, @series_to_check);
		push @bad_perl, "$sbo $installed_vers->{$sbo}" unless $results[0];
		push @bad_python, "$sbo $installed_vers->{$sbo}" unless $results[1];
		push @bad_ruby, "$sbo $installed_vers->{$sbo}" unless $results[2];
	}
	$| = 0;
	print "\n";
}

# check for and display missing shared objects
sub evaluate_solibs {
	my (@actionable, @to_rebuild);
	my $count = 0;
	my $msg = "Checking packages for missing shared objects...";
	print "\n" if $pkg_check or $socheck or $full_check;
	print $msg;
	return unless $pkg_count;
	$| = 1;
	for my $sbo (keys %$installed_pkg) {
		if ($pkg_check) {
			next unless in $sbo, @to_check;
		}
		$count++;
		print "\r$msg ($count / $pkg_count)";
		push @actionable, $sbo unless solib_check($installed_pkg->{$sbo});
	}
	$| = 0;
	print "\nChecked for missing objects.      ";
	if (@actionable) {
		for my $sbo (sort @actionable) { push @to_rebuild, "$sbo $installed_vers->{$sbo}:\n$old_libs{$installed_pkg->{$sbo}}"; }
	}
	return @to_rebuild;
}

# retrieve and format list of removed builds
sub get_removed_list {
	print "Checking for out-of-tree builds...";
	my @removes = @{ get_removed_builds() };

	my %removes;
	for my $remove (@removes) {
		$removes{$remove->{name}} = {
			installed => $remove->{installed}
		};
	}

	my @remove_list;
	my $changelog = "$config{SBO_HOME}/repo/ChangeLog.txt";
	foreach my $gone (keys %removes) {
		my $info = $removes{$gone};
		my $item = sprintf "%s %s", $gone, $info->{installed};
		if (is_obsolete($gone)) {
			$item .= " - Obsolete on -current.";
		} elsif (-s $changelog) {
			my ($fh, $exit) = open_read($changelog);
			unless ($exit) {
				for my $line (<$fh>) {
					next unless $line =~ m/\/$gone: Removed/;
					$line =~ s/.*\/$gone: //;
					chomp($item .= " - $line");
					last;
				}
				close $fh;
			}
		}
		push @remove_list, $item;
	}

	return @remove_list;
}

# retrieve and format list of available updates
sub get_update_list {
	my $filter = shift;
	if ($filter eq 'VERS') {
		if ($config{CLASSIC} ne "TRUE") { print "\nChecking for updated SlackBuilds..."; }
		else { print "Checking for updated SlackBuilds...\n"; }
	}
	if ($filter eq 'BUILD') { print "Checking for bumped SlackBuilds..."; }
	my @updates;
	# if STRICT_UPGRADES is true, apparent downgrades must still be reported, just with different formatting
	if ($config{STRICT_UPGRADES} eq 'TRUE') {
		$config{STRICT_UPGRADES} = 'FALSE';
		@updates = @{ get_available_updates($filter) };
		$config{STRICT_UPGRADES} = 'TRUE';
	} else {
		@updates = @{ get_available_updates($filter) };
	}
	my @outdated = get_local_outdated_versions($filter);
	return() unless @outdated + @updates;

	my %updates;
	for my $update (@updates) {
		$updates{$update->{name}} = {
			installed => $update->{installed},
			available => $update->{update},
			local => is_local($update->{name})
		};
		if ($filter eq 'BUILD') { $updates{$update->{name}}{available} = $update->{bump}; }
		if ($filter eq 'BUILD') { $updates{$update->{name}}{build} = $update->{build}; }
		if ($filter eq 'VERS' and $config{STRICT_UPGRADES} eq 'TRUE') { $updates{$update->{name}}{differs_only} = 1 unless version_cmp($updates{$update->{name}}{available}, $updates{$update->{name}}{installed}) > 0; }
		if ($filter eq 'BUILD' and $config{STRICT_UPGRADES} eq 'TRUE') { $updates{$update->{name}}{differs_only} = 1 unless build_cmp($updates{$update->{name}}{available}, $update->{build}, 1, 1) > 0; }
	}
	for my $update (@outdated) {
		my $name = $update->{name};
		$updates{$name}{installed} = $update->{version};
		$updates{$name}{sbo} = $update->{orig};
		$updates{$name}{local} = 1;
		if ($filter eq 'BUILD') {
			$updates{$update->{name}}{available} = $update->{bump};
			$updates{$name}{build} = $update->{numbuild};
			$updates{$update->{name}}{sbo} = $update->{intree};
		}
	}

# Output should look like this where the < is aligned to the longest sboname 1.0 string (excepting ones that would then wrap):
# sboname 1.0  <  needs updating (1.1 from overrides)
# sboname 1.0  <  needs updating (1.1 from SBo)
# sboname 1.0  <  needs updating (1.1 from overrides, 1.2 from SBo)
# sboname 1.0 (1)  <  was bumped (build 2 from overrides)
# sboname 1.0 (1)  <  was bumped (build 2 from SBo)
# sboname 1.0 (2)  =  differs (build 1 from SBo) # (note: for STRICT_UPGRADES)
# sboname 1.1  =  version differs (1.0 from SBo) # (note: for STRICT_UPGRADES)
# sboname 1.0  =  override differs (1.1 from SBo)

# The left carat is replaced by an equals sign if the script would not be upgraded.

	my $max = 0;
	my @not_upgradable;
	foreach my $sbo (keys %updates) {
		my $use_equals;
		$use_equals = 1 if on_blacklist($sbo);
		my $info = $updates{$sbo};
		my $current;
		if ($filter eq 'BUILD') {
			$current = sprintf "%s %s (%s)", $sbo, $info->{installed}, $info->{build};
		}
		else {
			$current = sprintf "%s %s", $sbo, $info->{installed};
		}

		# Packages from LOCAL_OVERRIDES only have build number differences with the overrides directory reported
		my $available = '';
		if (defined $info->{available} and defined $info->{sbo} and $filter ne 'BUILD' and not defined $info->{differs_only}) {
			if ($filter eq 'VERS') { $available = sprintf "needs updating (%s from overrides, %s from SBo)", $info->{available}, $info->{sbo}; }
		} elsif ($info->{available}) {
			if ($filter eq 'VERS' and $info->{local}) { $available = sprintf "needs updating (%s from overrides)", $info->{available}; }
			elsif ($filter eq 'VERS' and not defined $info->{differs_only}) { $available = sprintf "needs updating (%s from SBo)", $info->{available}; }
			elsif ($filter eq 'VERS' and not $info->{local} and defined $info->{differs_only}) { $available = sprintf "version differs (%s from SBo)", $info->{available}; $use_equals = 1; }
			if ($filter eq 'BUILD' and not defined $info->{differs_only}) { $available = sprintf "was bumped (build %s from %s)", $info->{available}, $info->{local} ? "overrides" : "SBo"; $use_equals = 1 if $config{BUILD_IGNORE} eq 'TRUE'; }
			if ($filter eq 'BUILD' and defined $info->{differs_only} and not $info->{local}) { $available = sprintf "differs (build %s from SBo)", $info->{available}; $use_equals = 1; }
			if ($filter eq 'BUILD' and defined $info->{differs_only} and $info->{local}) { $available = sprintf "was bumped (build %s from overrides)", $info->{available}; $use_equals = 1 if $config{BUILD_IGNORE} eq 'TRUE'; }
		}
		else {
			if ($filter eq 'VERS') { $available = sprintf "override differs (%s from SBo)", $info->{sbo}; $use_equals = 1; }
		}
		if (defined $use_equals) {
			push @not_upgradable, $sbo;
		}
		$info->{name_str} = $current;
		$info->{upd_str} = $available;

		my $str = sprintf "%s  <  %s", $current, $available;
		if (length($str) <= 80) {
			$max = length($current) if length($current) > $max;
		}
	}

	my @listing;
	foreach my $sbo (sort keys %updates) {
		my $info = $updates{$sbo};

		my $sign = "<";
		$sign = "=" if in $sbo, @not_upgradable and $config{CLASSIC} ne 'TRUE';
		my $str = sprintf "%s  $sign  %s", $info->{name_str}, $info->{upd_str};
		if (length($str) <= 80) {
			$str = sprintf "%-*s  $sign  %s", $max, $info->{name_str}, $info->{upd_str};
			my $adjust = 1;
			while (length($str) > 80) {
				$str = sprintf "%-*s  $sign  %s", $max-$adjust++, $info->{name_str}, $info->{upd_str};
			}
		}
		push @listing, $str;
	}
	return @listing;
}

# print a list
sub print_output {
	my $logfile = shift;
	$line_needed = 0;
	my @listing = @_;
	my $message = "";
	my $non_root_write = ($logfile =~ /^\/tmp\// and (-w '/tmp' and (-w $logfile or not -f $logfile)));
	if($logfile eq '/var/log/sbocheck.log') {
		if ($config{CLASSIC} ne "TRUE") { $message="\tNo version updates available."; }
		else { $message="\nNo version updates available.\n"; }
	}
	if($logfile eq '/var/log/sbocheck-bumps.log') { $message="\tNo build numbers differ."; }
	if($logfile eq '/var/log/sbocheck-out-of-tree.log') { $message="\tNo out-of-tree _SBo builds."; }
	if($logfile =~ /solibs/) { $message="\tNo missing shared objects."; }
	if($logfile =~ /perl/) {
		print "Checked for perl incompatibility.";
		$message="\tNo perl-incompatible packages.";
	}
	if($logfile =~ /python/) {
		print "Checked for python incompatibility.";
		$message="\tNo python-incompatible packages.";
	}
	if($logfile =~ /ruby/) {
		print "Checked for ruby incompatibility.";
		$message="\tNo ruby-incompatible packages.";
	}
	if (@listing) {
		if ($config{CLASSIC} ne "TRUE" and ($< == 0 or $non_root_write)) { print_color $color_notice; print "\tSee $logfile.\n\n"; print_color $color_default; }
		else { print "\n\n"; }
		if ($logfile =~ /solibs/) {
			$line_needed = 1;
			for my $listing (@listing) {
				my $print_line = (split "\n", $listing)[0];
				$print_line =~ s/\:$//;
				say $print_line;
			}
			wrapsay_color $color_lesser, "\nBinary repackages generally do not require rebuilds.";
			wrapsay_color $color_lesser, "Run as root and see /var/log/sbocheck-solibs.log for a breakdown of missing shared objects." if $< != 0 and not $non_root_write;
		} elsif ($logfile =~ /perl/) {
				wrapsay_color $color_lesser, "Built against the wrong major perl version:";
				print "\n";
				say $_ for @listing;
				print "\n";
				wrapsay_color $color_lesser, "Run as root and see /var/log/sbocheck-perl.log to save a log." if $< != 0 and not $non_root_write;
		} elsif ($logfile =~ /python/) {
				wrapsay_color $color_lesser, "Built against the wrong major python version:";
				print "\n";
				say $_ for @listing;
				print "\n";
				wrapsay_color $color_lesser, "Run as root and see /var/log/sbocheck-python.log to save a log." if $< != 0 and not $non_root_write;
		} elsif ($logfile =~ /ruby/) {
				wrapsay_color $color_lesser, "Built against the wrong major ruby version:";
				print "\n";
				say $_ for @listing;
				print "\n";
				wrapsay_color $color_lesser, "Run as root and see /var/log/sbocheck-ruby.log to save a log." if $< != 0 and not $non_root_write;
		} else {
			say $_ for @listing;
			print "\n";
		}
		# root can save a log of available updates
		if ($< == 0 or $non_root_write) {
			unlink $logfile if -f $logfile;
			my ($log_fh, $exit) = open_fh($logfile, '>');
			# non-fatal
			if ($exit) {
				warn_color $color_lesser, $log_fh;
			} else {
				say {$log_fh} $_ for @listing;
				close $log_fh;
				if ($config{CLASSIC} eq "TRUE") { wrapsay "A copy of the above result is kept in $logfile.", 1; }
			}
		}
	} else {
		$line_needed = 1;
		wrapsay_color $color_notice, $message;
	}
	return 1;
}

unless ($socheck or $pkg_check or $full_check or $perl or $python or $ruby) {
	my @listing = get_update_list('VERS');
	print_output('/var/log/sbocheck.log', @listing);
	if ($config{CLASSIC} ne "TRUE") {
		my @bumps = get_update_list('BUILD');
		print_output('/var/log/sbocheck-bumps.log', @bumps);
		my @removed = get_removed_list();
		print_output('/var/log/sbocheck-out-of-tree.log', @removed);
	}
}
if ($solibs and ($socheck or ($config{SO_CHECK} eq "TRUE" and not ($perl or $python or $ruby)) or $pkg_check or $full_check)) {
	my @to_rebuild = evaluate_solibs();
	my $check_log = $< == 0 ? '/var/log/sbocheck-solibs.log' : '/tmp/sbocheck-solibs.log';
	print_output($check_log, @to_rebuild);
}
if ($perl or $python or $ruby or $auto_series) {
	evaluate_series();
	my $check_log_prefix = $< == 0 ? '/var/log/sbocheck' : '/tmp/sbocheck';
	print_output("$check_log_prefix-perl.log", @bad_perl) if $perl or $auto_series;
	print_output("$check_log_prefix-python.log", @bad_python) if $python or $auto_series;
	print_output("$check_log_prefix-ruby.log", @bad_ruby) if $ruby or $auto_series;
}

wrapsay "\nWarning: Local overrides directory $config{LOCAL_OVERRIDES} does not exist." if $config{LOCAL_OVERRIDES} ne "FALSE" and not -d $config{LOCAL_OVERRIDES};

END { say "" if $line_needed; }
