#!/usr/bin/perl -w

# Copyright 2020 The LumoSQL Authors, see LICENSES/MIT
#
# SPDX-License-Identifier: MIT
# SPDX-FileCopyrightText: 2020 The LumoSQL Authors
# SPDX-ArtifactOfProjectName: not-forking
# SPDX-FileType: Code
# SPDX-FileComment: Original by Claudio Calvelli, 2020

# LumoSQL "not-fork" tool: track upstream changes to other packages
# with consistent local modifications (没叉 or 不叉)

# Requires integration between version control systems used and perl,
# for example to use git it needs to be built with perl support, which
# is the default; other VCSs may need to install perl modules.

# See the /doc directory for more information about this tool

use strict;
use FindBin qw($Script);
use Getopt::Long qw(GetOptions GetOptionsFromArray);

# modules may be inside the working copy rather than installed
#use FindBin;
#use lib "$FindBin::Bin/../lib";

BEGIN {
    eval {
        require NotFork::Hash;
        NotFork::Hash->import;
        require NotFork::Get;
        NotFork::Get->import(qw(
            set_input
            set_cache
            set_output
            get_output
            all_names
            version_atleast
            recommend
            cache_list
            remove_cache
        ));
        1;
    } or do {
        my $err = $@ || 'unknown error';
        if ($err =~ /Can't locate NotFork\b/) {
            my $bin   = $0;
            (my $base = $bin) =~ s{/bin/[^/]+\z}{};
            my $guess = "$base/lib/perl5";
            print STDERR <<"END_HINT";
$0: cannot find the NotFork::* Perl modules in \@INC.

If you installed not-fork with INSTALL_BASE=$base (or similar),
the libraries are in $guess but Perl is not looking there.

Set PERL5LIB before running not-fork, e.g.:
        export PERL5LIB="$guess"

Original error follows:
$err
END_HINT
            exit 2;
        }
        die $err;
    };
}

our $VERSION = '0.7';

my ($src_version, $src_commit, $query, $help, $noupdate, $check_version, $list_versions);
my ($offline, $my_version, $check_prereq, $check_recommend, $find_version, @names);
my ($use_version, $ignore, $test_version, @error_option, $version_range);
my ($list_cache, @remove_cache, @local_mirror, $build_upstream_lock, $use_upstream_lock);
my ($build_json_lock, $prefer_tarball, $distribution, $hash);
my $verbose = 1;

# some variables are set per source rather than globally:
my %per_source = (
    version        => \$src_version,
    commit         => \$src_commit,
    prefer_tarball => \$prefer_tarball,
    distribution   => \$distribution,
    hash           => \$hash,
);

my @options = (
    'c|commit=s'           => \$src_commit,
    'h|?|help'             => \$help,
    'i|input=s'            => sub { set_input($_[1]) },
    'k|cache=s'            => sub { set_cache($_[1]) },
    'n|no-update'          => \$noupdate,
    'update'               => sub { $noupdate = 0 },
    'o|output=s'           => sub { set_output($_[1]) },
    'q|query'              => \$query,
    'verbose=i'            => \$verbose,
    'quiet'                => sub { $verbose = 0 },
    'online'               => sub { $offline = 0 },
    'offline'              => \$offline,
    'v|version=s'          => \$src_version,
    'list-versions'        => \$list_versions,
    'metadata'             => sub { $list_versions = 2 },
    'version-range=s'      => \$version_range,
    'check-version=s'      => \$check_version,
    'check-prereq'         => \$check_prereq,
    'check-recommend'      => \$check_recommend,
    'V|my-version'         => \$my_version,
    'find-version=s'       => \$find_version,
    'use-version=s'        => \$use_version,
    'list-cache'           => \$list_cache,
    'remove-cache=s'       => \@remove_cache,
    'local-mirror=s'       => \@local_mirror,
    'build-upstream-lock'  => \$build_upstream_lock,
    'use-upstream-lock'    => \$use_upstream_lock,
    'build-json-lock=s'    => \$build_json_lock,
    'prefer-tarball=s'     => \$prefer_tarball,
    'distribution=s'       => \$distribution,
    'filehash=s'           => sub { $hash = new NotFork::Hash($_[1], 0) },
    'dirhash=s'            => sub { $hash = new NotFork::Hash($_[1], 1) },
    '<>'                   => sub { add_name($_[0], 1) },
);
Getopt::Long::Configure(qw(bundling));

# if *first* option is --config, read it now
my ($config_shift, $config_file) = (0, undef);
if (@ARGV > 0 && $ARGV[0] =~ /^--config=(.*)$/) {
    $config_file = $1;
    $config_shift = 1;
} elsif (@ARGV > 1 && $ARGV[0] eq '--config') {
    $config_file = $ARGV[1];
    $config_shift = 2;
} elsif (defined (my $home = $ENV{HOME})) {
    my $cfile = "$home/.config/LumoSQL/not-fork.conf";
    -f $cfile and $config_file = $cfile;
}

# if we found a configuration file in some way, use it
if (defined $config_file) {
    open (my $cfh, '<', $config_file) or die "$config_file: $!\n";
    my @config = ();
    while (defined (my $line = <$cfh>)) {
	$line =~ /^\s*$/ and next;
	$line =~ /^\s*#/ and next;
	chomp $line;
	$line =~ s/\s*=\s*/=/;
	push @config, '--' . $line;
    }
    close $cfh;
    my $test_version;
    my $error_index = @error_option;
    push @error_option, '';
    local $SIG{__WARN__} = sub { push @error_option, $_[0]; };
    GetOptionsFromArray(\@config,
	@options,
	'test-version=s'   => \$test_version,
    ) or $error_option[$error_index] = "Error processing configuration file $config_file:\n";
    # test-version can only appear in the configuration file and it
    # contains a path to a working copy: this helps testing new
    # uninstalled versions; so check if we actually are that working
    # copy and if not switch to it
    if (defined $test_version && $0 ne "$test_version/bin/not-fork") {
	exec $^X, "-I$test_version/lib", "$test_version/bin/not-fork", @ARGV;
	die "Cannot exec tool in $test_version\n";
    }
}

# if we see a --use-version we'll need to re-parse @ARGV so make a copy
my @save_argv = @ARGV;
splice(@ARGV, 0, $config_shift);
{
    my $error_index = @error_option;
    push @error_option, '';
    while (@ARGV) {
	local $SIG{__WARN__} = sub { push @error_option, $_[0]; };
	GetOptions(@options) or $error_option[$error_index] = "Error processing command-line options:\n";
	# a "--" will terminate option processing, but we don't really want that
	# and our non-option arguments cannot start with a "-" so it is not needed
	@ARGV && $ARGV[0] eq '--' and shift @ARGV;
    }
}

# if they asked for --use-version we'll call that version...
if (defined $use_version) {
    my @tool = find_version($use_version);
    if (@tool) {
	# we need to run something else; remove the --use-version from it first
	for (my $i = 0; $i < @save_argv; $i++) {
	    if (lc($save_argv[$i]) eq '--use-version') {
		splice(@save_argv, $i, 2);
		redo;
	    }
	    if ($save_argv[$i] =~ /^--use-version=/) {
		splice(@save_argv, $i, 1);
		redo;
	    }
	}
	exec @tool, @save_argv;
	die "Cannot exec $tool[0]: $!\n";
    }
    # our version is OK, so continue as normal
}

# if they specified an unknown option and we haven't changed our own
# version, report it now
if (@error_option) {
    my $error = join('', @error_option);
    if ($error ne '') {
	print STDERR "$error\n";
	usage(1);
    }
}

$help and usage(0);

if (defined $my_version) {
    print "$VERSION\n";
    exit 0;
}

if (defined $check_version) {
    version_atleast($VERSION, $check_version) and exit 0;
    print "$VERSION\n";
    exit 1;
}

if (defined $find_version) {
    my @tool = find_version($find_version);
    if (! @tool) {
	# this version is acceptable, and now we need to figure out how
	# we were called
	(my $lib = $FindBin::Bin) =~ s|/[^/]+$|/lib|;
	-d "$lib/NotFork" and push @tool, $^X, "-I$lib";
	push @tool, $0;
    }
    print "$_\n" for @tool;
    exit 0;
}

my %prereq;
if (defined $check_recommend) {
    %prereq = recommend();
    my $found_all = list_prereq();
    exit($found_all ? 0 : 1);
}

if (defined $list_cache) {
    my %list = cache_list;
    for my $hash (sort keys %list) {
	print "$hash  $list{$hash}\n";
    }
    exit 0;
}

if (@remove_cache) {
    my %list = cache_list;
    my %index = reverse %list;
    my $ok = 1;
    my @rm;
    for my $rm (@remove_cache) {
	if (exists $list{$rm}) {
	    push @rm, $rm;
	} elsif (exists $index{$rm}) {
	    push @rm, $index{$rm};
	} else {
	    warn "Unknown cache element: $rm\n";
	    $ok = 0;
	}
    }
    $ok or exit 1;
    for my $rm (@rm) {
	print "Removing   $rm  $list{$rm}\n";
	remove_cache($rm);
    }
    exit 0
}

if (! @names) {
    for my $name (all_names()) {
	add_name($name, 0);
    }
}

my $nlfh;
if (defined $build_json_lock) {
    open($nlfh, '>', $build_json_lock) or die "$build_json_lock: $!\n";
    print $nlfh "{\n" or die "$build_json_lock: $!\n";
}
%prereq = ();
for my $np (@names) {
    my ($name, $data) = @$np;
    my $nfobj = new NotFork::Get($name, $data->{version}, $data->{commit},
				 $use_upstream_lock &&
				 ! defined $build_upstream_lock &&
				 ! defined $build_json_lock);
    defined $verbose and $nfobj->verbose($verbose);
    defined $offline and $nfobj->offline($offline);
    @local_mirror and $nfobj->local_mirror(@local_mirror);
    if ($check_prereq) {
	$nfobj->check_prereq(\%prereq);
    } else {
	# Detect missing prerequisites (e.g. `fossil`, `git`, `patch`)
	# before we fork/exec the. This is the same check the user can run
	# manually with --check-prereq
	my %this_prereq;
	$nfobj->check_prereq(\%this_prereq);
	my @missing = grep { ! $this_prereq{$_}[0] } keys %this_prereq;
	if (@missing) {
	    # Merge into %prereq so list_prereq() formats the output
	    # identically to `not-fork --check-prereq`, then exit.
	    %prereq = %this_prereq;
	    print STDERR
		"$Script: missing prerequisite(s) for \"$name\"; ",
		"re-run with --check-prereq for the full list.\n";
	    list_prereq();
	    exit 1;
	}
	$nfobj->get($noupdate);
	if ($list_versions ||
	    $query ||
	    $version_range ||
	    defined $build_upstream_lock ||
	    defined $build_json_lock)
	{
	    $query and $nfobj->info(\*STDOUT);
	    defined $build_upstream_lock and $nfobj->build_upstream_lock;
	    defined $build_json_lock
		and $nfobj->build_json_lock($nlfh, $data);
	    if ($version_range) {
		my ($min, $max);
		if ($version_range =~ /^([^:]*):([^:]*)$/) {
		    $1 eq '' or $min = $1;
		    $2 eq '' or $max = $2;
		} elsif ($version_range =~ /:/) {
		    die "Invalid --version-range: \"$version_range\"\n";
		} else {
		    $min = $max = $version_range;
		}
		print map { "$_\n" } $nfobj->all_versions($min, $max);
	    } elsif ($list_versions) {
		if ($list_versions > 1) {
		    for my $version ($nfobj->all_versions) {
			my ($commit, $timestamp, $vcs, $url) = $nfobj->version_info($version);
			print "$name $version $vcs $url $commit $timestamp\n";
		    }
		} else {
		    print map { "$_\n" } $nfobj->all_versions;
		}
	    }
	} else {
	    $nfobj->install();
	}
    }
}
if (defined $build_json_lock) {
    print $nlfh "  \"version\": 1\n}\n" or die "$build_json_lock: $!\n";
    close $nlfh or die "$build_json_lock: $!\n";
}

if ($check_prereq) {
    my $found_all = list_prereq();
    exit($found_all ? 0 : 1);
}

sub add_name {
    my ($name, $clear) = @_;
    defined $src_version && defined $src_commit
	and usage(1, "Cannot provide both VERSION and COMMIT\n");
    my %data;
    for my $key (keys %per_source) {
	my $ptr = $per_source{$key};
	$data{$key} = $$ptr;
	$clear and undef $$ptr;
    }
    push @names, [$name, \%data];
}

sub usage {
    my ($code, @msgs) = @_;
    my $fh = $code ? \*STDERR : \*STDOUT;
    print $fh @msgs;
    print $fh "This is $Script version $VERSION\n\n";
    print $fh "Usage: $Script [options] [NAME]...\n";
    print $fh "\n";
    print $fh "-iDIR --input=DIR\n";
    print $fh "    Specify configuration directory, default: ./not-fork.d\n";
    print $fh "-oDIR --output=DIR\n";
    print $fh "    Specify output directory, default: ./sources\n";
    print $fh "-vVERSION --version=VERSION | -cID --commit=ID\n";
    print $fh "    Specify what version or commit ID (if supported) to obtain,\n";
    print $fh "    the two are mutually exclusive, default: latest available\n";
    print $fh "--list-versions\n";
    print $fh "    List all known versions of the NAMEs specified\n";
    print $fh "-kDIR --cache=DIR\n";
    print $fh "    Specify download cache directory, default: \$HOME/.cache/LumoSQL/not-fork\n";
    print $fh "-q --query\n";
    print $fh "    Obtain upstream sources but do not extract them and instead\n";
    print $fh "    show information about them and which version would be selected\n";
    print $fh "--verbose=LEVEL | --quiet\n";
    print $fh "    Ask to show more information about the processing; default is 1\n";
    print $fh "    which just summarises what's going on; 0 disables all output except\n";
    print $fh "    error messages; higher number are only useful for debugging or to\n";
    print $fh "    know exactly what the program does; --quiet is the same as\n";
    print $fh "    --verbose=0\n";
    print $fh "--update | -n --no-update\n";
    print $fh "    --no-update skips updates from upstream if there is already a cached\n";
    print $fh "    version; --update is the default action of checking for upstream\n";
    print $fh "    updates before extracting the sources (-n is equivalent to --no-update)\n";
    print $fh "--online | --offline\n";
    print $fh "    --offline skips any operation which needs to access the network;\n";
    print $fh "    this may result in the program stopping with an error if the data\n";
    print $fh "    is not available on a local cache; --online is the default where the\n";
    print $fh "    network can be accessed if required\n";
    print $fh "-V --my-version\n";
    print $fh "    Print version number of not-fork\n";
    print $fh "--check_version=NUMBER\n";
    print $fh "    If the version of not-fork is NUMBER or later, exit with a success\n";
    print $fh "    code; if it's older, print the current version and exit with failure\n";
    print $fh "--check-prereq\n";
    print $fh "    check that all dependencies are installed; if so, exit with a\n";
    print $fh "    success code; otherwise print what's missing and fail\n";
    print $fh "--check-recommend\n";
    print $fh "    like --check-prereq however it lists all possible dependencies\n";
    print $fh "    whether they are used for this particular project or not\n";
    print $fh "--list-cache\n";
    print $fh "    lists a summary of what is in the cache\n";
    print $fh "--remove-cache=NAME\n";
    print $fh "    removes an item from the cache; NAME can be a cache hash or a URL\n";
    print $fh "    (respectively first and second column of the --list-cache output)\n";
    print $fh "\n";
    print $fh "-c/-v needs to be specified before each NAME, after a NAME has\n";
    print $fh "been processed, these options revert to the default.\n";
    print $fh "\n";
    print $fh "See also the documentation for other options and special cases.\n";
    exit $code;
}

sub list_prereq {
    my $title = 1;
    my $found_all = 1;
    my @prereq = sort { lc($a) cmp lc($b) || $a cmp $b } keys %prereq;
    my $maxv = 0;
    for my $name (@prereq) {
	my ($ok, $version) = @{$prereq{$name}};
	$ok && $verbose < 1 and next;
	defined $version && $maxv < length($version) and $maxv = length($version);
    }
    for my $name (@prereq) {
	my ($ok, $version) = @{$prereq{$name}};
	$ok && $verbose < 1 and next;
	$ok or $found_all = 0;
	if ($verbose < 1) {
	    if ($title) {
		$title = 0;
		print "\nWARNING - recommended program and/or perl modules not found\n";
	    }
	    if (defined $version && $version ne '') {
		print "$name >= $version\n";
	    } else {
		print "$name\n";
	    }
	} else {
	    if ($title) {
		$title = 0;
		print "Recommended programs and perl modules\n";
	    }
	    defined $version or $version = '';
	    printf "%-9s %-${maxv}s %s\n", $ok ? 'OK' : 'NOT FOUND', $version, $name;
	}
    }
}

# find a version of the tool in the specified range and return a command
# (and arguments) to run to use that version;
# if *this* version is in range, return an empty list
sub find_version {
    my ($min_version) = @_;
    my $max_version;
    my $ok = 1;
    if ($min_version =~ s/:(.*)$//) {
	$max_version = $1;
	$ok = version_atleast($max_version, $VERSION);
    }
    $ok &&= version_atleast($VERSION, $min_version);
    # if the running version is OK, return an empty list
    $ok and return ();
    # we are not in the required range, but we can not-fork ourselves
    # to find it; we start by finding the appropriate configuration
    for my $inc (@INC, undef) {
	-f "$inc/NotFork/not-fork.d/not-fork/upstream.conf" or next;
	# load our own not-forking configuration
	set_input("$inc/NotFork/not-fork.d");
	my $nfobj = new NotFork::Get('not-fork', undef, undef);
	$nfobj->verbose(0);
	defined $offline and $nfobj->offline($offline);
	$nfobj->get($noupdate);
	my @v = grep { version_atleast($_, $min_version) } $nfobj->all_versions;
	defined $max_version and @v = grep { version_atleast($max_version, $_) } @v;
	@v or die "No suitable versions found\n";
	# great, just get the latest in range and we're done; we'll reload the
	# configuration with the correct version number
	my $v = pop @v;
	$nfobj = new NotFork::Get('not-fork', $v, undef);
	$nfobj->verbose(0);
	defined $offline and $nfobj->offline($offline);
	$nfobj->get(1);
	$nfobj->install();
	my $dir = get_output() . '/not-fork';
	-f "$dir/bin/not-fork" or die "Internal error, sources not in $dir\n";
	return ($^X, "-I$dir/lib", "$dir/bin/not-fork");
    }
    die "Cannot find not-forking configuration\n";
}

