tools/git-if-needed/tests/gifn-test.pl

#!/usr/bin/perl
#
# Copyright (c) 2019  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 File::Temp;
use Getopt::Std;
use List::Util qw(all);
use Path::Tiny;

use constant VERSION_STRING => '0.1.0';

use constant RE_CHANGE_ID => qr{
	^ \s* Change-Id: \s* (?<id> I[0-9a-f]+ ) \s* $
}xi;

use constant PATCHFILES => {
	initial => [qw(add modify)],
	conflict => [qw(conflict)],
	more => [qw(another)],

	all => {
		add => 'add-readme.patch',
		modify => 'modify-readme.patch',
		conflict => 'conflict-in-readme.patch',
		another => 'another-file.patch',
	},
};

my $debug = 0;

sub usage($)
{
	my ($err) = @_;
	my $s = <<EOUSAGE
Usage:	gifn-test [-Nv] cmd [arg...]
	gifn-test -V | -h | --version | --help
	gifn-test --features

	-h	display program usage information and exit
	-N	no-operation mode
	-V	display program version information and exit
	-v	verbose operation; display diagnostic output
EOUSAGE
	;

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

sub version()
{
	say 'gifn-test '.VERSION_STRING;
}

sub features()
{
	say 'Features: gifn_test='.VERSION_STRING;
}

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

sub check_wait_result($ $ $)
{
	my ($stat, $pid, $name) = @_;
	my $sig = $stat & 127;
	if ($sig != 0) {
		die "Program '$name' (pid $pid) was killed by signal $sig\n";
	} else {
		my $code = $stat >> 8;
		if ($code != 0) {
			die "Program '$name' (pid $pid) exited with non-zero status $code\n";
		}
	}
}

sub run_command_unchomped(@)
{
	my (@cmd) = @_;
	my $name = $cmd[0];

	my $pid = open my $f, '-|';
	if (!defined $pid) {
		die "Could not fork for $name: $!\n";
	} elsif ($pid == 0) {
		debug "About to run '@cmd'";
		exec { $name } @cmd;
		die "Could not execute '$name': $!\n";
	}
	my @res = <$f>;
	close $f;
	check_wait_result $?, $pid, $name;
	return @res;
}

sub run_command(@)
{
	my (@cmd) = @_;
	my @lines = run_command_unchomped @cmd;
	chomp for @lines;
	return @lines;
}

sub run_failing_command(@)
{
	my (@cmd) = @_;

	my @lines = eval {
		run_command @cmd;
	};
	my $err = $@;
	if (!defined $err) {
		die "The '@cmd' command did not fail and output ".
		    scalar(@lines)." lines of text\n";
	}
	return $err;
}

sub help_or_version($)
{
	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;
	usage 0 if $opts->{h} || $dash_help;
	features if $dash_features;
	exit 0 if $opts->{V} || $opts->{h} || $has_dash;
}

sub detect_utf8_locale()
{
	my @lines = run_command 'locale', '-a';
	my %avail = map { $_ => 1 } @lines;
	for my $pref (qw(POSIX C en_US en_CA en_GB en_AU en)) {
		for my $ext (qw(UTF-8 utf8)) {
			my $value = "$pref.$ext";
			return $value if $avail{$value};
		}
	}
	die "Could not find a suitable UTF-8 output locale\n";
}

sub git_status_ok($)
{
	my ($cfg) = @_;

	my @lines = run_command @{$cfg->{git}}, 'status', '--short';
	die "git status --short returned @lines\n" if @lines;
}

sub run_gifn_am($ $)
{
	my ($cfg, $short) = @_;

	my @lines = run_command @{$cfg->{gifn}}, 'am',
	    $cfg->{patches}->{$short}->{patch};
	git_status_ok $cfg;
	return @lines;
}

sub run_failing_gifn_am($ $)
{
	my ($cfg, $short) = @_;

	return run_failing_command @{$cfg->{gifn}}, 'am',
	    $cfg->{patches}->{$short}->{patch};
}

sub get_current_changes($)
{
	my ($cfg) = @_;

	return map {
		$_ =~ RE_CHANGE_ID ? ($+{id}) : ()
	} run_command @{$cfg->{git}}, 'log', '--reverse';
}

sub equal_lists($ $)
{
	my ($expected, $got) = @_;

	return @{$expected} == @{$got} && all { $expected->[$_] eq $got->[$_] } 0..$#{$expected};
}

sub git_init($)
{
	my ($cfg) = @_;

	run_command @{$cfg->{git}}, 'init';
	run_command @{$cfg->{git}}, 'config', '--local',
	    'user.name', 'Somebody';
	run_command @{$cfg->{git}}, 'config', '--local',
	    'user.email', 'someone@example.com';
}

sub setup_repo($)
{
	my ($cfg) = @_;

	chdir $cfg->{repo} or die "Could not change into $cfg->{repo}: $!\n";
	git_init $cfg;
	git_status_ok $cfg;

	while (my ($short, $fname) = each %{PATCHFILES->{all}}) {
		my $patch = $cfg->{data}->child($fname);
		my @lines = $patch->lines_utf8({ chomp => 1 });
		my @id = map { $_ =~ RE_CHANGE_ID ? ($+{id}): () } @lines;
		die "No Change-Id line in $fname\n" unless @id;
		die "Duplicate Change-Id line in $fname\n" if @id > 1;
		$cfg->{patches}->{$short} = {
			short => $short,
			fname => $fname,
			patch => $patch,
			id => $id[0],
		};
	}

	run_gifn_am $cfg, $_ for @{PATCHFILES->{initial}};

	my @lines = get_current_changes $cfg;
	my @expected = map {
		$cfg->{patches}->{$_}->{id}
	} @{PATCHFILES->{initial}};
	die "Could not apply the initial patches: ".
	    "got [@lines], expected [@expected]\n" unless
	    equal_lists \@expected, \@lines;
}

sub test_bad_cmdline($)
{
	my ($cfg) = @_;

	say "\ntest-bad-cmdline\n";
	my @before = get_current_changes $cfg;

	run_failing_command @{$cfg->{gifn}}, '-X', '-Y', '-Z';
	git_status_ok $cfg;

	run_failing_command @{$cfg->{gifn}}, 'am';
	git_status_ok $cfg;
	run_failing_command @{$cfg->{gifn}}, 'am', 'a', 'b';
	git_status_ok $cfg;
	run_failing_command @{$cfg->{gifn}}, 'am', 'a', 'b', 'c';
	git_status_ok $cfg;

	run_failing_command @{$cfg->{gifn}}, 'am', '/nonexistent';
	git_status_ok $cfg;

	my @after = get_current_changes $cfg;
	die "The bad command-line invocations caused a changes change: ".
	    "before: [@before], after: [@after]\n" unless
	    equal_lists \@before, \@after;
}

sub test_already_applied($ @)
{
	my ($cfg, @patches) = @_;

	say "\ntest-already-applied @patches\n";
	for my $short (@patches) {
		my @before = get_current_changes $cfg;
		my $id = $cfg->{patches}->{$short}->{id};
		debug "Should not try to apply $id again over @before";

		my @lines = run_gifn_am $cfg, $short;
		my $seek = qr{^ [#] .* \Q$id\E .* already \s+ present }xi;
		my @found = grep { $_ =~ $seek } @lines;
		die join '', map "$_\n", (
			"Tried to apply change $id again:",
			@lines,
		) unless @found;

		my @after = get_current_changes $cfg;
		die "Not even applying $id caused a changes change: ".
		    "before: [@before], after: [@after]\n" unless
		    equal_lists \@before, \@after;
	}
}

sub test_fail_to_apply($ @)
{
	my ($cfg, @patches) = @_;

	say "\ntest-fail-to-apply @patches\n";
	for my $short (@patches) {
		my @before = get_current_changes $cfg;
		my $id = $cfg->{patches}->{$short}->{id};
		debug "Should not be able to apply $id right now over @before";

		run_failing_gifn_am $cfg, $short;
		debug "Should be able to recover after a failed 'git am'";
		run_command @{$cfg->{git}}, 'am', '--abort';
		git_status_ok $cfg;

		my @after = get_current_changes $cfg;
		die "Failing to apply $id caused a changes change: ".
		    "before: [@before], after: [@after]\n" unless
		    equal_lists \@before, \@after;
	}
}

sub test_apply($ @)
{
	my ($cfg, @patches) = @_;
	
	say "\ntest-apply @patches\n";
	for my $short (@patches) {
		my @before = get_current_changes $cfg;
		my $id = $cfg->{patches}->{$short}->{id};
		debug "Should be able to apply $id over @before";

		run_gifn_am $cfg, $short;

		my @after = get_current_changes $cfg;
		my @expected = (@before, $id);
		die "Did not get the expected changes after applying $id: ".
		    "expected [@expected], got [@after]\n" unless
		    equal_lists \@expected, \@after;
	}
}

sub setup_subdir_repos($)
{
	my ($cfg) = @_;

	$cfg->{sub}->{full}->{base} = $cfg->{subrepo}->child('full');
	$cfg->{sub}->{full}->{cinder} =
	    $cfg->{sub}->{full}->{base}->
	    child('openstack')->child('cinder');
	$cfg->{sub}->{full}->{nova} =
	    $cfg->{sub}->{full}->{base}->
	    child('openstack')->child('nova');
	$cfg->{sub}->{full}->{cinder}->mkpath({ mode => 0755 });
	$cfg->{sub}->{full}->{nova}->mkpath({ mode => 0755 });

	$cfg->{sub}->{short}->{base} = $cfg->{subrepo}->child('short');
	$cfg->{sub}->{short}->{cinder} =
	    $cfg->{sub}->{short}->{base}->child('cinder');
	$cfg->{sub}->{short}->{nova} =
	    $cfg->{sub}->{short}->{base}->child('nova');
	$cfg->{sub}->{short}->{cinder}->mkpath({ mode => 0755 });
	$cfg->{sub}->{short}->{nova}->mkpath({ mode => 0755 });

	for my $part (qw(full short)) {
		for my $comp (qw(cinder nova)) {
			my $dir = $cfg->{sub}->{$part}->{$comp};
			chdir($dir) or die "Could not change into $dir: $!\n";
			git_init $cfg;
			git_status_ok $cfg;
		}
	}
}

sub test_subdir($ $ $ $)
{
	my ($cfg, $part, $expected, $opt) = @_;
	my $run = $expected ? 'second' : 'first';
	my $sub = $cfg->{sub}->{$part};

	say "\ntest-subdir $part $run\n";

	my $any = sub {
	    $sub->{cinder}->child('README.txt')->exists ||
	    $sub->{nova}->child('README.txt')->exists
	};
	my $all = sub {
	    $sub->{cinder}->child('README.txt')->exists &&
	    $sub->{nova}->child('README.txt')->exists
	};

	chdir $sub->{base} or die "Could not change into $sub->{base}: $!\n";
	if ($expected && !$all->()) {
		die "No $part files before the second run in $sub->{base}\n";
	} elsif (!$expected && $any->()) {
		die "Unexpected $part files in $sub->{base}\n";
	}

	run_command @{$cfg->{gifn}}, '-s', $cfg->{data}->child('series'),
	    @{$opt}, 'am';

	if (!$all->()) {
		my $run = $expected ? 'second' : 'first';
		die "No $part files after the $run run in $sub->{base}\n";
	}

	for my $comp (qw(cinder nova)) {
		chdir $sub->{$comp} or
		    die "Could not change into $sub->{comp}: $!\n";
		git_status_ok $cfg;
	}
}

MAIN:
{
	my %opts;

	getopts('hNVv-:', \%opts) or usage 1;
	help_or_version \%opts;
	$debug = $opts{v};

	usage 1 unless @ARGV;

	my $cwd = path('.')->absolute;
	my $locale = detect_utf8_locale;
	my $repodir = File::Temp->newdir(
	    TEMPLATE => 'gifn-test.XXXXXX',
	    TMPDIR => 1);
	my $subrepodir = File::Temp->newdir(
	    TEMPLATE => 'gifn-test.XXXXXX',
	    TMPDIR => 1);

	my @gifn_cmd = @ARGV;
	$gifn_cmd[0] = path($gifn_cmd[0])->absolute;

	my $cfg = {
		cwd => $cwd,
		data => $cwd->child('tests')->child('data'),
		gifn => ['env', "LC_MESSAGES=$locale", @gifn_cmd],
		git => ['env', "LC_MESSAGES=$locale", 'git', '--no-pager'],
		repo => path($repodir),
		subrepo => path($subrepodir),
	};

	eval {
		setup_repo $cfg;

		test_bad_cmdline $cfg;
		test_already_applied $cfg, @{PATCHFILES->{initial}};
		test_fail_to_apply $cfg, @{PATCHFILES->{conflict}};
		test_apply $cfg, @{PATCHFILES->{more}};
		test_already_applied $cfg, (@{PATCHFILES->{initial}}, @{PATCHFILES->{more}});
		test_fail_to_apply $cfg, @{PATCHFILES->{conflict}};

		setup_subdir_repos $cfg;

		test_subdir $cfg, 'full', 0, [];
		test_subdir $cfg, 'short', 0, ['-S'];
		test_subdir $cfg, 'full', 1, [];
		test_subdir $cfg, 'short', 1, ['-S'];
	};
	my $err = $@;
	chdir $cwd;
	die $err if $err;

	say 'OK';
}