#!/usr/bin/perl
#
# Copyright (c) 2018, 2019, 2021  Peter Pentchev
# 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 v5.10;
use strict;
use warnings;

use Getopt::Std;
use IO::Handle;
use JSON::XS;
use POSIX qw(dup2);

my $debug = 0;
my $version = '1.0.1';
my $default_option = '--features';
my $default_prefix = 'Features: ';
my $default_output_fmt = 'tsv';

my %re = (
	var => qr{ [A-Za-z0-9_-]+ }x,
	value => qr{ [A-Za-z0-9.]+ }x,
	op => qr{ (?: < | <= | = | >= | > | lt | le | eq | ge | gt ) }x,
);

sub usage($)
{
	my ($err) = @_;
	my $s = <<EOUSAGE
Usage:	feature-check [-v] [-O optname] [-P prefix] program feature-name
	feature-check [-O optname] [-P prefix] program feature-name op version
	feature-check [-O optname] [-o json|tsv] [-P prefix] -l program
	feature-check -h | --help
	feature-check -V | --version

	-h	display program usage information and exit
	-l	list the features supported by the specified program
	-o	specify the output format for the list of features
		(default: $default_output_fmt)
	-O	specify the query-features option to pass to the program
		(default: $default_option)
	-P	specify the prefix on the line of the program output that
		contains the list of features (default: '$default_prefix')
	-N	no-operation mode
	-V	display program version information and exit
	-v	output the feature version when querying a single feature
EOUSAGE
	;

	if ($err) {
		die $s;
	} else {
		print "$s";
	}
}

sub version()
{
	say "feature-check $version";
}

sub features()
{
	say "${default_prefix}feature-check=$version single=1.0 list=1.0 ".
	    "simple=1.0";
}

sub debug($)
{
	say STDERR "RDBG $_[0]" if $debug;
}

sub help_version_or_features($)
{
	my ($opts) = @_;
	my $has_dash = defined $opts->{'-'};
	my $dash_help = $has_dash && $opts->{'-'} eq 'help';
	my $dash_version = $has_dash && $opts->{'-'} eq 'version';
	my $dash_features = $has_dash && $opts->{'-'} eq 'features';
	
	if ($has_dash && !$dash_help && !$dash_version && !$dash_features) {
		warn "Invalid long option '".$opts->{'-'}."' specified\n";
		usage 1;
	}
	version if $opts->{V} || $dash_version;
	features if $dash_features;
	usage 0 if $opts->{h} || $dash_help;
	exit 0 if $opts->{V} || $opts->{h} || $has_dash;
}

sub get_program_output($)
{
	my ($cmd) = @_;

	my ($stdout_in, $stdout_out);
	pipe $stdout_in, $stdout_out or die "stdout pipe: $!\n";
	my ($stderr_in, $stderr_out);
	pipe $stderr_in, $stderr_out or die "stderr pipe: $!\n";

	my $pid = fork;
	if (!defined $pid) {
		die "Could not fork for '$cmd->[0]': $!\n";
	} elsif ($pid == 0) {
		close $stdout_in;
		close $stderr_in;

		close \*STDIN;
		dup2($stdout_out->fileno, 1) or die "dup stdout: $!\n";
		dup2($stderr_out->fileno, 2) or die "dup stderr: $!\n";

		exec { $cmd->[0] } @{$cmd} or
		    die "exec @{$cmd}: $!\n";
	}

	close $stdout_out;
	close $stderr_out;
	my @output = <$stdout_in>;
	close $stdout_in;
	my @errs = <$stderr_in>;
	close $stderr_in;
	my $npid = waitpid $pid, 0;
	my $status = $?;
	if ($npid != $pid) {
		die "Expected pid $pid, got $npid status $status\n";
	} elsif ($status != 0 || @errs) {
		# die "No features output from '@{$cmd}'\n";
		# Nah, treat this as "too old to support --features", say 'no'.
		return ();
	}
	chomp for @output;
	return @output;
}

sub parse_features($ $)
{
	my ($prefix, $lines) = @_;

	my $re_line = qr/ ^ \Q$prefix\E (?<features> .*) $ /x;
	my $found;
	for (@{$lines}) {
		next unless /$re_line/;
		# die "Duplicate '$prefix' line\n" if defined $found;
		exit(2) if defined $found;
		$found = $+{features};
	}
	# die "No '$prefix' line\n" unless defined $found;
	exit(2) unless defined $found;

	my $re_fields = qr/
		^
		(?<var> $re{var} )
		(?:
			[:\/=]
			(?<value> $re{value} )
		)?
		$
	/x;
	my %features;
	for my $word (split /\s+/, $found) {
		if ($word !~ $re_fields) {
			# die "Invalid word in the '$prefix' line: '$word'\n";
			exit(2);
		}
		$features{$+{var}} = $+{value} // '1.0';
	}
	return %features;
}

sub obtain($)
{
	my ($cfg) = @_;
	my @lines = get_program_output [$cfg->{program}, $cfg->{option}];
	return parse_features $cfg->{prefix}, \@lines;
}

sub output_tsv($)
{
	my ($features) = @_;
	say "$_\t$features->{$_}" for sort keys %{$features};
}

sub output_json($)
{
	my ($features) = @_;
	my $js = JSON::XS->new->pretty->canonical->utf8;
	print $js->encode($features);
}

my %output = (
	tsv => \&output_tsv,
	json => \&output_json,
);

sub process_list($ $)
{
	my ($cfg, $features) = @_;
	$output{$cfg->{output_fmt}}->($features);
}

sub process_single($ $)
{
	my ($cfg, $features) = @_;
	if (defined $features->{$cfg->{feature}}) {
		say $features->{$cfg->{feature}} if $cfg->{opts}{v};
		exit(0);
	} else {
		exit(1);
	}
}

sub version_compare_split($ $);
sub version_compare_split($ $)
{
	my ($va, $vb) = @_;
	my @sa = @{$va};
	my @sb = @{$vb};
	if (!@sa) {
		if (@sb) {
			# letters signify prerelease versions
			return $sb[0] =~ /^[A-Za-z]/ ? 1 : -1;
		} else {
			return 0;
		}
	} elsif (!@sb) {
		return $sa[0] =~ /^[A-Za-z]/ ? -1 : 1;
	}

	my ($fa, $fb) = (shift @sa, shift @sb);
	my ($na, $ra, $nb, $rb);
	if ($fa =~ /^ (?<num> [0-9]+ ) (?<rest> .*) $/x) {
		($na, $ra) = ($+{num}, $+{rest});
	} else {
		($na, $ra) = ('', $fa);
	}
	if ($na eq '' && $ra eq '') {
		die "Internal error: could not split '$fa'\n";
	}
	if ($fb =~ /^ (?<num> [0-9]+ ) (?<rest> .*) $/x) {
		($nb, $rb) = ($+{num}, $+{rest});
	} else {
		($nb, $rb) = ('', $fb);
	}
	if ($nb eq '' && $rb eq '') {
		die "Internal error: could not split '$fb'\n";
	}

	if ($na ne '') {
		if ($nb ne '') {
			if ($nb != $na) {
				return $na <=> $nb;
			}
		} else {
			return 1;
		}
	} elsif ($nb ne '') {
		return -1;
	}

	# So the numeric parts are either missing or the same
	if ($ra ne '') {
		if ($rb ne '') {
			if ($ra ne $rb) {
				return $ra cmp $rb;
			}
		} else {
			return 1;
		}
	} elsif ($rb ne '') {
		return -1;
	}

	return version_compare_split \@sa, \@sb;
}

sub version_compare($ $)
{
	my ($va, $vb) = @_;
	die 'Internal error: version_compare() takes hashrefs, not \"'.
	    ref($va).'" and \"'.ref($vb)."\"\n"
	    unless ref $va eq 'HASH' && ref $vb eq 'HASH';
	die "Internal error: version_compare() takes versions, not ".
	    "'$va->{type}' and '$vb->{type}'\n"
	    unless $va->{type} eq 'version' && $vb->{type} eq 'version';
	my @sa = split /\./, $va->{value};
	my @sb = split /\./, $vb->{value};
	return version_compare_split \@sa, \@sb;
}

my %ops = (
	lt => {
		args => [qw(version version)],
		do => sub {
			my ($va, $vb) = @_;
			{
				type => 'bool',
				value => version_compare($va, $vb) < 0,
			}
		},
	},

	le => {
		args => [qw(version version)],
		do => sub {
			my ($va, $vb) = @_;
			{
				type => 'bool',
				value => version_compare($va, $vb) <= 0,
			}
		},
	},

	eq => {
		args => [qw(version version)],
		do => sub {
			my ($va, $vb) = @_;
			{
				type => 'bool',
				value => version_compare($va, $vb) == 0,
			}
		},
	},

	ge => {
		args => [qw(version version)],
		do => sub {
			my ($va, $vb) = @_;
			{
				type => 'bool',
				value => version_compare($va, $vb) >= 0,
			}
		},
	},

	gt => {
		args => [qw(version version)],
		do => sub {
			my ($va, $vb) = @_;
			{
				type => 'bool',
				value => version_compare($va, $vb) > 0,
			}
		},
	},
);

# Alternate names
my %synonyms = (
	lt => '<',
	le => '<=',
	eq => '=',
	ge => '>=',
	gt => '>',
);
for my $op (keys %synonyms) {
	$ops{$synonyms{$op}} = $ops{$op};
}

sub evaluate($ $ $);
sub evaluate($ $ $)
{
	my ($cfg, $ast, $features) = @_;

	if ($ast->{type} eq 'op') {
		my $name = $ast->{op};
		my $op = $ops{$name};
		if (!defined $op) {
			die "Invalid operator $name\n";
		}

		my @args = map { evaluate $cfg, $_, $features }
		    @{$ast->{args}};
		# TODO: how do we handle "all" and "any"?
		if ($#args != $#{$op->{args}}) {
			die "The '$name' operator expects ".
			    scalar(@{$op->{args}}).' arguments but only '.
			    scalar(@args)." were supplied\n";
		}
		for my $i (0..$#args) {
			my $arg = $args[$i];
			if ($arg->{type} ne $op->{args}[$i]) {
				die "The '$name' operator expects argument ".
				    ($i + 1)." to be a $op->{args}[$i], ".
				    "got $arg->{type} instead\n";
			}
		}
		return $op->{do}(@args);
	} elsif ($ast->{type} eq 'feature') {
		return {
			type => 'version',
			value => $features->{$ast->{name}},
		};
	} elsif ($ast->{type} eq 'version') {
		return {
			type => 'version',
			value => $ast->{value},
		};
	} else {
		die "Internal error: a '$ast->{type}' node in the AST\n";
	}
}

sub process_expr($ $)
{
	my ($cfg, $features) = @_;

	my $result = evaluate $cfg, $cfg->{ast}, $features;
	if ($result->{type} eq 'bool') {
		exit(!$result->{value});
	} else {
		die "FIXME: handle result type '$result->{type}'\n";
	}
}

my %process = (
	list => \&process_list,
	single => \&process_single,
	expr => \&process_expr,
);

MAIN:
{
	my %opts;

	getopts('hlO:o:P:Vv-:', \%opts) or usage 1;
	help_version_or_features \%opts;

	my %cfg = (
		option => $opts{O} // $default_option,
		output_fmt => $opts{o} // $default_output_fmt,
		prefix => $opts{P} // $default_prefix,

		opts => \%opts,
	);
	if (!defined $output{$cfg{output_fmt}}) {
		die "Invalid output format '$cfg{output_fmt}', should be ".
		    "one of ".join(', ', sort keys %output)."\n";
	}

	my ($mode, $program, $feature);
	if ($opts{l}) {
		$cfg{mode} = 'list';
		usage 1 unless @ARGV == 1;
		$cfg{program} = shift;
	} else {
		usage 1 if @ARGV < 2;
		$cfg{program} = shift;
		$cfg{feature} = join ' ', @ARGV;
		if ($cfg{feature} =~ m{^ $re{var} $}x) {
			$cfg{mode} = 'single';
		} elsif ($cfg{feature} =~ m{^ \s*
			(?<var> $re{var} )
			\s*
			(?<op> $re{op} )
			\s*
			(?<value> $re{value} )
			\s*
		}x) {
			$cfg{mode} = 'expr';
			$cfg{ast} = {
				type => 'op',
				op => $+{op},
				args => [
					{
						type => 'feature',
						name => $+{var},
					},
					{
						type => 'version',
						value => $+{value},
					},
				],
			};
		} else {
			usage 1;
		}
	}

	my %features = obtain \%cfg;
	$process{$cfg{mode}}->(\%cfg, \%features);
}
