sbohints

#!/usr/bin/perl
#
# vim: ts=4:noet
#
# sbohints
# script to modify the blacklist and optional dependencies
#
# author: K. Eugene Carlson <kvngncrlsn@gmail.com>
# license: MIT License

use 5.16.0;
use strict;
use warnings FATAL => 'all';
use SBO::Lib qw/ :config :colors auto_reverse get_optional ignore_tests in lint_sbo_config on_blacklist open_fh open_read prompt read_hints script_error show_version uniq usage_error wrapsay /;
use File::Basename;
use Getopt::Long qw(:config no_ignore_case_always bundling);

my $self = basename($0);
my $label = $is_sbotest ? "sbotest hints" : $self;

sub show_usage {
	print <<"EOF";
Usage: $label [options] sbo ...
       $label [-l|--reset]

Options:
  -h|--help:
    this screen.
  -v|--version:
    version information.
  --(no)color:
    (do not) use sbotools color output.
  --(no)wrap:
    (do not) wrap sbotools output.
  -l|--list:
    show current blacklist and optional dependencies.
  -q|--query:
    show the hint status of one or more scripts.
  -b|--blacklist:
    add scripts to the blacklist (clear with c).
  -o|--optional:
    add optional dependencies to scripts (clear with c).
  -O|--replace-optional:
    replace all optional dependencies for scripts (clear with c).
  -r|--reverse:
    add reverse dependency rebuild requests for scripts (clear with c).
  -t|--ignore-tests:
    sboupgrade ignores test results for scripts (clear with c).
  --reset:
    clear all hints.

  -c|--clear:
    clear instead of add.

  Examples:
  $label -b libsystemd sbotools
  $label -cb vifm
  $label -q qemu
EOF
}

my ($help, $version, $list, $reset, $reverse, $optional, $replace_optional, $blacklist, $ignore_tests, $clear, $query, $nocolor, $color, $nowrap, $wrap);

GetOptions(
	'help|h'              => \$help,
	'version|v'           => \$version,
	'list|l'              => \$list,
	'reset'               => \$reset,
	'reverse|r'           => \$reverse,
	'optional|o'          => \$optional,
	'replace-optional|O'  => \$replace_optional,
	'clear|c'             => \$clear,
	'query|q'             => \$query,
	'blacklist|b'         => \$blacklist,
	'ignore-tests|t'      => \$ignore_tests,
	'nocolor'             => \$nocolor,
	'color'               => \$color,
	'nowrap'              => \$nowrap,
	'wrap'                => \$wrap,
);

if ($help) {
	show_usage();
	wrapsay "\nNon-root users can call $label with -l, -q, -h and -v." unless $< == 0;
	exit 0;
}
if ($version) { 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 $list or $query) {
	show_usage();
	usage_error "\nNon-root users can call $label with -l, -q, -h and -v.";
}
unless (@ARGV or $list or $reset) { show_usage(); exit 0; }

lint_sbo_config($self, %config);

if (($blacklist and ($optional or $replace_optional or $reverse or $ignore_tests)) or ($optional and ($replace_optional or $reverse or $ignore_tests)) or ($replace_optional and $reverse) or ($replace_optional and $ignore_tests) or ($reverse and $ignore_tests)) {
	usage_error("optional, replace-optional, reverse, ignore-tests and blacklist cannot be used together.");
}

if ($list) { show_list(); exit 0; }

for my $item (@ARGV) {
	usage_error "Separate compat32 requests are not needed." if $item =~ /-compat32$/;
}

if ($query) { make_query(); exit 0; }

if ($reset and ($optional or $clear or $replace_optional or $blacklist or $clear or $reverse or $ignore_tests)) {
	usage_error("reset cannot be used with other flags.");
}

if ($reset) {
	if (prompt($color_warn, "Are you sure you want to clear all scripts from the blacklist and all optional dependency requests?", default => 'no')) {
		wrapsay "Clearing the blacklist and all optional depedency requests...";
		reset_all();
	} else {
		exit 0;
	}
}

if ($replace_optional or $optional) {
	unless (@ARGV) { show_usage(); exit 0; }
	my $made_output;
	for my $target (uniq @ARGV){
		print "\n" if $made_output;
		$made_output = 1;
		prompt_queue($target);
	}
}

if ($blacklist or $reverse or $ignore_tests) {
	unless (@ARGV) { show_usage(); exit 0; }
	for my $target (uniq @ARGV) { alter_designation($target); }
}

# Takes one script to be added or cleared at a time. If flag
# -b or -cb, alter the blacklist. If flag -r or -cr, add or clear
# reverse dependency rebuild requests.
sub alter_designation {
	script_error("alter_designation requires an argument.") unless @_;
	my $sbo = shift;
	if ($clear and $blacklist and not on_blacklist($sbo)) {
		wrapsay "$sbo is not on the blacklist.";
		return;
	}
	if ($blacklist and on_blacklist($sbo) and not $clear) {
		wrapsay "$sbo is already on the blacklist.";
		return;
	}
	if ($clear and $reverse and not auto_reverse($sbo)) {
		wrapsay "$sbo does not have a reverse dependency rebuild request.";
		return;
	}
	if ($reverse and auto_reverse($sbo) and not $clear) {
		wrapsay "$sbo already has a reverse dependency rebuild request.";
		return;
	}
	if ($clear and $ignore_tests and not ignore_tests($sbo)) {
		wrapsay "$sbo test failures are not ignored by sboupgrade.";
		return;
	}
	if ($ignore_tests and ignore_tests($sbo) and not $clear) {
		wrapsay "$sbo test failures are already ignored by sboupgrade.";
		return;
	}
	if ($clear) {
		my @incoming;
		# it is not possible to reach this point unless
		# /etc/sbotools/sbotools.hints exists
		my ($rfh, $rexit) = open_read($hint_file);
		error_code("Failed to open $hint_file; exiting.", $rexit) if $rexit;
		# flag -cb/-cr/-ct; only write back lines that don't alter the
		# designation for $sbo
		if ($blacklist) {
			wrapsay "Clearing $sbo from the blacklist...";
			for my $line (<$rfh>) { push @incoming, $line unless $line =~ m/^\!\Q$sbo\E$/; }
		} elsif ($reverse) {
			wrapsay "Clearing reverse dependency rebuild request for $sbo...";
			for my $line (<$rfh>) { push @incoming, $line unless $line =~ m/^\~\Q$sbo\E$/; }
		} elsif ($ignore_tests) {
			wrapsay "Clearing test failure ignore request for $sbo...";
			for my $line (<$rfh>) { push @incoming, $line unless $line =~ m/^\%\Q$sbo\E$/; }
		}
		close $rfh;
		my ($fh, $exit) = open_fh($hint_file, ">");
		error_code("Failed to open $hint_file; exiting.", $exit) if $exit;
		print {$fh} @incoming;
		close $fh;
	} else {
		mkdir $conf_dir unless -d $conf_dir;
		system(qw/ touch /, $hint_file) unless -f $hint_file;
		my ($fh, $exit) = open_fh($hint_file, ">>");
		error_code("Failed to open $hint_file; exiting.", $exit) if $exit;
		# flag -b/-r/-t; print a new line blacklisting/requesting reverse
		# rebuilds/ignoring test failures for $sbo
		if ($blacklist) {
			wrapsay "Blacklisting $sbo...";
			print {$fh} "!$sbo\n";
		} elsif ($reverse) {
			wrapsay "Requesting reverse dependency rebuilds for $sbo...";
			print {$fh} "~$sbo\n";
		} elsif ($ignore_tests) {
			wrapsay "sboupgrade will ignore test failures for $sbo...";
			print {$fh} "%$sbo\n";
		}
		close $fh;
	}
}

sub invalid_prompt_input {
	script_error("invalid_prompt_input requires two arguments.") unless @_ ge 2;
	my ($sbo, @incoming) = @_;
	if (grep { /-compat32$/ } @incoming) {
		wrapsay("Separate -compat32 requests are not needed.", 1);
		return 1;
	}
	if (grep { /(\!|\%|\~)/ } @incoming) {
		wrapsay_color $color_lesser, "!, ~ and % cannot be used in optional dependency requests.", 1;
		return 1;
	}
	if (in $sbo, @incoming) {
		if ($clear) {
			wrapsay_color $color_lesser, "Cannot clear $sbo from its own list.", 1;
		} else {
			wrapsay_color $color_lesser, "$sbo cannot be its own optional dependency.", 1;
		}
		return 1;
	}
	return 0;
}

sub make_query {
	unless (@ARGV) { show_usage(); exit 0; }
	my $made_output;
	for my $sbo (uniq @ARGV) {
		print "\n" if $made_output;
		if (on_blacklist($sbo)) {
			say "$sbo is blacklisted.";
			$made_output = 1;
		}
		if (auto_reverse($sbo)) {
			wrapsay "$sbo has automatic reverse dependency rebuilding.";
			$made_output = 1;
		}
		if (ignore_tests($sbo)) {
			wrapsay "$sbo test failures are ignored by sboupgrade.";
			$made_output = 1;
		}
		if (my @optionals = get_optional($sbo)) {
			my $word = @optionals == 1 ? "request" : "requests";
			wrapsay_color $color_notice, "Optional dependency $word for $sbo:";
			wrapsay(join(" ", @optionals));
			$made_output = 1;
		}
		my @optional_for;
		for my $has_optional (keys %optional) {
			push @optional_for, $has_optional if in $sbo, @{ $optional{$has_optional} };
		}
		if (@optional_for) {
			@optional_for = uniq @optional_for;
			$made_output = 1;
			if (@optional_for == 1) {
				my $requested = shift @optional_for;
				wrapsay "$sbo is an optional dependency of $requested.";
			} else {
				wrapsay_color $color_notice, "The following scripts optionally depend on $sbo:";
				@optional_for = sort @optional_for;
				for my $result (@optional_for) { wrapsay "$result"; }
			}
		}
	}
}

# Get user input for optional dependency modifications.
sub prompt_queue {
	script_error("prompt_queue requires an argument.") unless @_;
	my $sbo = shift;
	my (@incoming, $message);
	$message = "Select one or more scripts to add, or leave blank to skip: ";
	$message = "Select one or more scripts to clear, or leave blank to skip: " if $clear;
	$message = "Enter the new optional dependency list, or leave blank to skip: " if $replace_optional;
	$message = "Proceed with clearing the optional dependency list for $sbo?" if $replace_optional and $clear;

	my @current = get_optional($sbo);
	if (@current) {
		wrapsay "Current optional dependencies for $sbo:";
		wrapsay(join(" ", @current), 1);
		# flags -co, -o, -O
		unless ($replace_optional and $clear) {
			if (@incoming = split(" ", prompt($color_notice, $message))) {
				if (invalid_prompt_input($sbo, @incoming)) {
					prompt_queue($sbo);
					return;
				}
				# for -o and -co, don't attempt changes if unneeded
				my $is_needed;
				for my $item (@incoming) {
					unless (($clear and not in $item, @current) or ($optional and not $clear and in $item, @current)) {
						$is_needed = 1;
						last;
					}
				}
				if ($is_needed) {
					write_optional($sbo, @incoming);
				} else {
					wrapsay "No changes to be made to $sbo; skipping.";
				}
			} else {
				say "Skipping.";
				return;
			}
		} elsif (prompt($color_lesser, $message, default => 'no')) {
			# flag -cO
			write_optional($sbo);
			return;
		} else {
			say "Skipping.";
			return;
		}
	} elsif ($clear) {
		# flags -co and -cO, no existing entry
		wrapsay "No optional dependency requests to clear for $sbo.";
		return;
	} else {
		# flags -o and -O, no existing entry
		wrapsay("$sbo has no optional dependency requests.", 1);
		if (@incoming = split(" ", prompt($color_notice, $message))) {
			if (invalid_prompt_input($sbo, @incoming)) {
				prompt_queue($sbo);
				return;
			}
			write_optional($sbo, @incoming);
			return;
		} else {
			say "Skipping.";
			return;
		}
	}
}

# Remove any line from sbotools.hints that isn't commented or whitespace-
# initial.
sub reset_all {
	my @remaining;
	unless (@listings) {
		wrapsay "No blacklist or optional dependency requests found.";
		exit 0;
	}
	my ($rfh, $rexit) = open_read($hint_file);
	error_code("Failed to open $hint_file; exiting.", $rexit) if $rexit;
	for my $line (<$rfh>) {
		chomp(my $search = $line);
		push @remaining, $line unless in $search, @listings;
	}
	close $rfh;
	my ($fh, $exit) = open_fh($hint_file, '>');
	error_code("Failed to open $hint_file; exiting.", $exit) if $exit;
	print {$fh} @remaining;
	close $fh;
}

# Write out the blacklist, followed by optional dependency requests
# per script. If anything on the blacklist has requests, or if a script
# in a list of optional dependencies is blacklisted, note that fact.
sub show_list {
	my (@ineffectuals, @ineffectual_requests, $made_output);
	if (@on_blacklist) {
		my @display_blacklist = grep { !/-compat32$/ } @on_blacklist;
		@display_blacklist = sort(uniq(@display_blacklist));
		unless (@display_blacklist == 1) {
			wrapsay_color $color_notice, "The following scripts are blacklisted:";
			say $_ for (@display_blacklist);
		} else {
			my $result = shift @display_blacklist;
			wrapsay "$result is blacklisted.";
		}
		$made_output = 1;
	}
	if (@auto_reverse) {
		print "\n" if $made_output;
		my @display_auto_reverse = grep { !/-compat32$/ } @auto_reverse;
		@display_auto_reverse = sort(uniq(@display_auto_reverse));
		unless (@display_auto_reverse == 1) {
			wrapsay_color $color_notice, "The following scripts have reverse dependency rebuilding:";
			say $_ for (@display_auto_reverse);
		} else {
			my $result = shift @display_auto_reverse;
			wrapsay "$result has reverse dependency rebuilding.";
		}
		$made_output = 1;
	}
	if (@ignore_tests) {
		print "\n" if $made_output;
		my @display_ignore_tests = grep { !/-compat32$/ } @ignore_tests;
		@display_ignore_tests = sort(uniq(@display_ignore_tests));
		unless (@display_ignore_tests == 1) {
			wrapsay_color $color_notice, "Test failures for the following scripts are ignored by sboupgrade:";
			say $_ for (@display_ignore_tests);
		} else {
			my $result = shift @display_ignore_tests;
			wrapsay "$result test failures are ignored by sboupgrade.";
		}
		$made_output = 1;
	}
	for my $has_optional (sort(keys %optional)) {
		next if $has_optional =~ /-compat32$/;
		print "\n" if $made_output;
		my @optional_array = @{ $optional{$has_optional} };
		my $word = @optional_array == 1 ? "request" : "requests";
		wrapsay_color $color_notice, "Optional dependency $word for $has_optional:";
		wrapsay join " ", @optional_array;
		$made_output = 1;
		push @ineffectual_requests, $has_optional if on_blacklist($has_optional);
		for (@optional_array) { push @ineffectuals, $_ if on_blacklist($_); }
	}

	if (@ineffectuals) {
		@ineffectuals = uniq sort(@ineffectuals);
		say " ";
		wrapsay_color $color_lesser, "The following scripts have optional dependency requests, but are blacklisted:";
		wrapsay(join("\n", @ineffectuals));
	}
	if (@ineffectual_requests) {
		@ineffectual_requests = uniq sort(@ineffectual_requests);
		say " ";
		wrapsay_color $color_lesser, "The following scripts are requested as optional dependencies, but are blacklisted:";
		wrapsay(join("\n", @ineffectual_requests));
	}
	wrapsay "The blacklist is empty and no optional dependency or reverse dependency rebuild requests could be identified." unless $made_output;
	exit 0;
}

# Takes the name of a SlackBuild and an array with scripts to add or
# clear (except for -cO).
sub write_optional {
	script_error("write_optional requires at least one argument.") unless @_;
	my ($sbo, @operation) = @_;
	script_error("write_optional needs two arguments except for clear operations.") unless @operation or $clear;
	mkdir $conf_dir unless -d $conf_dir;
	read_hints() if -f $hint_file;
	system(qw/ touch /, $hint_file) unless -f $hint_file;
	@operation = uniq @operation if @operation;
	my ($rfh, $rexit) = open_read($hint_file);
	error_code("Failed to open $hint_file; exiting.", $rexit) if $rexit;
	my (@outgoing, $replaced);
	push @operation, $sbo if $replace_optional and not $clear;
	if ($optional and not $clear) {
		if (my @current = get_optional($sbo)) {
			for my $to_add (@operation) { push @current, $to_add; }
			@operation = @current;
		}
		push @operation, $sbo;
	}
	@operation = uniq @operation;
	wrapsay "Making changes for $sbo...";
	# read the hints file one line at a time; whether (and how) the
	# line is written back in to the file depends on the flags
	FIRST: for my $line (<$rfh>) {
		chomp(my $search = $line);
		my $target = (in $search, @listings and $search =~ m/\s\Q$sbo\E$/);
		unless ($clear) {
			# replace the first specification for $sbo, and then
			# skip further instances (flags: -O, -o)
			if ($target and not $replaced) {
				push @outgoing, join(" ", @operation), "\n";
				$replaced = 1;
			} elsif ($target) {
				next FIRST;
			} else {
				push @outgoing, $line;
			}
		} elsif ($replace_optional) {
			# skip any line that specifies optional dependencies for
			# $sbo (flag: -cO)
			push @outgoing, $line unless $target;
		} else {
			# clear the requested scripts from any specification for
			# $sbo (flag: -co)
			if ($target) {
				for my $to_clear (@operation) { $line =~ s/(?<=^)\Q$to_clear\E\s//g; }
				for my $to_clear (@operation) { $line =~ s/(?<=\s)\Q$to_clear\E\s//g; }
			}
			push @outgoing, $line;
		}
	}
	# The simplest case of all is adding a completely new request.
	unless ($clear or $replaced) { push @outgoing, join(" ", @operation) . "\n"; }
	close $rfh;
	my ($fh, $exit) = open_fh($hint_file, '>');
	error_code("Failed to open $hint_file; exiting.", $exit) if $exit;
	print {$fh} @outgoing;
	close $fh;
}

END { say ""; }