# Copyright (c) 2009, 2010 Zmanda, Inc.  All Rights Reserved.
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License version 2 as published
# by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
#
# Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
# Sunnyvale, CA 94086, USA, or: http://www.zmanda.com

use Test::More tests => 201;
use File::Path;
use Data::Dumper;
use POSIX qw( WIFEXITED );
use warnings;
use strict;

use lib "@amperldir@";
use Installcheck;
use IPC::Open3;
use Amanda::Constants;
use Amanda::Util qw( slurp );

## this is an unusual installcheck, because it does not test anything about
## Amanda itself.  However, it validates the accuracy of our understanding of
## GNU Tar's behavior, as recorded at
##  http://wiki.zmanda.com/index.php/GNU_Tar_Include_and_Exclude_Behavior

my $gnutar = $Amanda::Constants::GNUTAR;
$gnutar = $ENV{'GNUTAR'} if exists $ENV{'GNUTAR'};

## get set up

my @filenames = (qw{A*A AxA B?B BxB C[C CC D]D E\E F'F G"G}, 'H H');

my $tarfile = "$Installcheck::TMP/gnutar-tests.tar";
my $datadir = "$Installcheck::TMP/gnutar-tests";

sub make_tarfile
{
    my @extra_args = @_;

    rmtree($datadir) if -e $datadir;
    mkpath($datadir);

    for my $fn (@filenames) {
	open(my $fh, ">", "$datadir/$fn");
	print $fh "data";
	close($fh);
    }

    system($gnutar, "-C", $datadir, "-cf", $tarfile, @extra_args, '.');
    die "could not run gnutar" unless $? == 0;

    rmtree($datadir) if -e $datadir;
}

## gnutar version

my ($v, $numeric_version);
{
    my $verstring = `$gnutar --version`;
    die "could not run gnutar" unless $? == 0;
    ($v) = ($verstring =~ /tar \(GNU tar\) *([0-9.]+)/);
    my ($maj, $min, $mic) = ($v =~ /([0-9]+)\.([0-9]+)(?:\.([0-9]+))?/);

    $numeric_version = 0;
    $numeric_version += $maj * 10000 if $maj;
    $numeric_version += $min * 100 if $min;
    $numeric_version += $mic if $mic;
}

# see if the default for --wildcards during inclusion has been changed
my $wc_default_changed = 0;
{
    my $help_output = `$gnutar --help`;
    # redhatty patches helpfully change the help message
    if ($help_output =~ /--wildcards\s*use wildcards \(default\)$/m) {
	$wc_default_changed = 1;
    }
}

my %version_classes = (
    '<1.16' => $numeric_version < 11591,
    '>=1.16' => $numeric_version >= 11591,
    '>=1.16-no-wc' => $numeric_version >= 11591 && !$wc_default_changed, # normal
    '>=1.16-wc' => $numeric_version >= 11591 && $wc_default_changed, # stupid distros screw things up!

    '<1.23' => $numeric_version < 12300,
    '>=1.23' => $numeric_version >= 12300,
    '*' => 1,
    '1.23' => ($numeric_version >= 12290 and $numeric_version <= 12300),
    '!1.23' => ($numeric_version < 12290 || $numeric_version > 12300),
);

# include and exclude all use the same set of patterns and filenames
my $patterns = [
	'./A*A' =>	'A*A',
	'./A*A' =>	'AxA',
	'./B?B' =>	'B?B',
	'./B?B' =>	'BxB',
	'./C[C' =>	'C[C',
	'./D]D' =>	'D]D',
	'./E\\E' =>	'E\\E',
	'./F\'F' =>	'F\'F',
	'./G"G' =>	'G"G',
	'./H H' =>	'H H',
	'./A\\*A' =>	'A*A',
	'./A\\*A' =>	'AxA',
	'./B\\?B' =>	'B?B',
	'./B\\?B' =>	'BxB',
	'./C\\[C' =>	'C[C',
	'./D\\]D' =>	'D]D',
	'./E\\\\E' =>	'E\\E',
	'./F\\\'F' =>	'F\'F',
	'./G\\"G' =>	'G"G',
	'./H\\ H' =>	'H H',
];

my $named_expectations = [
    [ 'alpha',
         'beta',
	    'gamma',
	       'delta',
	          'epsilon',
		     'empty', ],
    #  al be ga de ep empty
    [  1, 1, 1, 1, 1, 1,     ], # './A*A' =>	'A*A',
    [  1, 1, 1, 1, 0, 0,     ], # './A*A' =>	'AxA',
    [  1, 1, 1, 1, 1, 1,     ], # './B?B' =>	'B?B',
    [  1, 1, 1, 1, 0, 0,     ], # './B?B' =>	'BxB',
    [  0, 0, 0, 0, 1, 1,     ], # './C[C' =>	'C[C',
    [  1, 1, 1, 1, 1, 1,     ], # './D]D' =>	'D]D',
    [  1, 0, 0, 1, 1, 1,     ], # './E\\E' =>	'E\\E',
    [  1, 1, 1, 1, 1, 1,     ], # './F\'F' =>	'F\'F',
    [  1, 1, 1, 1, 1, 1,     ], # './G"G' =>	'G"G',
    [  1, 1, 1, 1, 1, 1,     ], # './H H' =>	'H H',
    [  1, 1, 1, 0, 0, 0,     ], # './A\\*A' =>	'A*A',
    [  0, 0, 0, 0, 0, 0,     ], # './A\\*A' =>	'AxA',
    [  0, 0, 1, 0, 0, 0,     ], # './B\\?B' =>	'B?B',
    [  0, 0, 0, 0, 0, 0,     ], # './B\\?B' =>	'BxB',
    [  1, 1, 1, 0, 0, 0,     ], # './C\\[C' =>	'C[C',
    [  0, 1, 1, 0, 0, 0,     ], # './D\\]D' =>	'D]D',
    [  1, 0, 1, 0, 1, 0,     ], # './E\\\\E' =>	'E\\E',
    [  0, 1, 1, 0, 0, 0,     ], # './F\\\'F' =>	'F\'F',
    [  0, 1, 1, 0, 0, 0,     ], # './G\\"G' =>	'G"G',
    [  0, 1, 1, 0, 0, 0,     ], # './H\\ H' =>	'H H',
];

sub get_expectation {
    my ($name) = @_;
    my @names = @{$named_expectations->[0]};

    # get the index for that greek letter
    my $i;
    for (0 .. $#names) {
	if ($names[$_] eq $name) {
	    $i = $_;
	    last;
	}
    }

    # then assemble the result
    my @rv;
    my @exps = @$named_expectations;
    shift @exps;
    for (@exps) {
	push @rv, $_->[$i];
    }

    return @rv;
}

sub get_matching_type {
    my ($expectations) = @_;

    # find the type for the first matching version
    for (keys %$expectations) {
	if ($version_classes{$_}) {
	    return $expectations->{$_};
	}
    }
    return undef;
}

sub get_version_index {
    my @versions = @{$_[0]};

    my $vi;
    for (0 .. $#versions) {
	if ($version_classes{$versions[$_]}) {
	    return $_;
	}
    }
    return undef;
}

## utils

my ($stderr, $stdout, $exit_code);
sub run_gnutar {
    my %params = @_;
    my @args = @{ $params{'args'} };

    my $errtempfile = "$Installcheck::TMP/stderr$$.out";

    # use a temporary file for error output -- this eliminates synchronization
    # problems between reading stderr and stdout
    local (*INFH, *OUTFH, *ERRFH);
    open(ERRFH, ">", $errtempfile);

    local %ENV;
    if ($params{'env'}) {
	my %env = %{$params{'env'}};
	for (keys %env) {
	    $ENV{$_} = $env{$_};
	}
    }

    my $pid = IPC::Open3::open3("INFH", "OUTFH", ">&ERRFH", $gnutar, @args);
    my $cmdline = "$gnutar " . join(' ', @args);

    # immediately close the child's stdin
    close(INFH);

    # read from stdout until it's closed
    $stdout = do { local $/; <OUTFH> };
    close(OUTFH);

    # and wait for the kid to die
    waitpid $pid, 0 or croak("Error waiting for gnutar die: $@");
    my $status = $?;
    close(ERRFH);

    # fetch stderr from the temporary file
    $stderr = slurp($errtempfile);
    unlink($errtempfile);

    # get the exit status
    $exit_code = WIFEXITED($status)? ($status >> 8) : 0xffff;

    if ($exit_code != 0) {
	return 0;
    } else {
	return 1;
    }
}

## inclusion tests (using -x and filenames on the command line)

sub test_gnutar_inclusion {
    my %params = @_;

    my $matching_type = get_matching_type($params{'expectations'});

    # skip these tests if there's no matching version
    if (!defined $matching_type) {
	SKIP: {
	    my $msg = (join " ", @{$params{'extra_args'}}) .
			" not supported in version $v";
	    my $count = @$patterns / 2;
	    skip $msg, $count;
	}
	return;
    }

    make_tarfile();
    my @patterns = @$patterns;
    my @expectations = get_expectation($matching_type);
    while (@patterns) {
	my $pat = shift @patterns;
	my $file = shift @patterns;
	my $exp = shift @expectations;

	my $eargs = '';
	$eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
	my $match = $exp? "matches" : "does not match";
	my $msg = "inclusion$eargs, pattern $pat $match file $file";

	rmtree($datadir) if -e $datadir;
	mkpath($datadir);

	my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, $pat ]);
	$ok = 0 unless -f "$datadir/$file";
	if ($ok and !$exp) {
	    fail($msg);
	    diag("  unexpected success with version $v");
	} elsif (!$ok and $exp) {
	    fail($msg);
	    diag("  unexpected failure with version $v:\n$stderr");
	} else {
	    pass($msg);
	}
    }
    rmtree($datadir) if -e $datadir;
}

# We'll trust that the following logic is implemented correctly in GNU Tar
# --no-wildcards is the default (same as no args) (but not everywhere!!)
# --unquote is the default (same as no args) (this seems true universally)

test_gnutar_inclusion(
    extra_args => [],
    expectations => {
	'<1.16' => 'alpha',
	'>=1.16-no-wc' => 'epsilon',
	'>=1.16-wc' => 'beta', # acts like --wildcards
    },
);

test_gnutar_inclusion(
    extra_args => [ '--no-wildcards' ],
    expectations => {
	'<1.16' => 'alpha',
	'>=1.16' => 'epsilon',
    },
);

test_gnutar_inclusion(
    extra_args => [ '--no-unquote' ],
    expectations => {
	'<1.16' => undef,
	'>=1.16-no-wc' => 'empty',
	'>=1.16-wc' => 'gamma', # acts like --wildcards --no-unquote
    },
);

test_gnutar_inclusion(
    extra_args => [ '--no-wildcards', '--no-unquote' ],
    expectations => {
	'<1.16' => undef,
	'>=1.16' => 'empty',
    },
);

test_gnutar_inclusion(
    extra_args => [ '--wildcards' ],
    expectations => {
	'<1.16' => 'alpha',
	'>=1.16' => 'beta',
    },
);

test_gnutar_inclusion(
    extra_args => [ '--wildcards', '--no-unquote' ],
    expectations => {
	'<1.16' => undef,
	'>=1.16' => 'gamma',
    },
);

## exclusion tests (using -t and filenames on the command line)

sub test_gnutar_exclusion {
    my %params = @_;

    my $matching_type = get_matching_type($params{'expectations'});

    # skip these tests if there's no matching version
    if (!defined $matching_type) {
	SKIP: {
	    my $msg = (join " ", @{$params{'extra_args'}}) .
			" not supported in version $v";
	    my $count = @$patterns; # two elements per test, but we run each one twice
	    skip $msg, $count;
	}
	return;
    }

    make_tarfile();
    my @patterns = @$patterns;
    my @expectations = get_expectation($matching_type);
    while (@patterns) {
	my $pat = shift @patterns;
	my $file = shift @patterns;
	my $exp = shift @expectations;

	my $eargs = '';
	$eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
	my $match = $exp? "matches" : "does not match";
	my $msg = "exclusion$eargs, extract, pattern $pat $match $file";

	rmtree($datadir) if -e $datadir;
	mkpath($datadir);

	my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, "--exclude=$pat" ]);

	# fail if the excluded file was extracted anyway..
	if ($ok) {
	    my $excluded_ok = ! -f "$datadir/$file";
	    if ($excluded_ok and !$exp) {
		fail($msg);
		diag("  exclusion unexpectedly worked with version $v");
	    } elsif (!$excluded_ok and $exp) {
		fail($msg);
		diag("  exclusion unexpectedly failed with version $v");
	    } else {
		pass($msg);
	    }
	} else {
	    fail($msg);
	    diag("  unexpected error exit with version $v:\n$stderr");
	}
    }

    # test again, but this time during a 'c'reate operation
    @patterns = @$patterns;
    @expectations = get_expectation($matching_type);
    while (@patterns) {
	my $pat = shift @patterns;
	my $file = shift @patterns;
	my $exp = shift @expectations;

	my $eargs = '';
	$eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
	my $match = $exp? "matches" : "does not match";
	my $msg = "exclusion$eargs, create, pattern $pat $match $file";

	# this time around, we create the tarball with the exclude, then extract the whole
	# thing.  We extract rather than using 't' because 't' has a funny habit of backslashing
	# its output that we don't want to deal with here.
	make_tarfile(@{$params{'extra_args'}}, "--exclude=$pat");

	rmtree($datadir) if -e $datadir;
	mkpath($datadir);
	my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile]);

	# fail if the excluded file was extracted anyway..
	if ($ok) {
	    my $excluded_ok = ! -f "$datadir/$file";
	    if ($excluded_ok and !$exp) {
		fail($msg);
		diag("  exclusion unexpectedly worked with version $v");
	    } elsif (!$excluded_ok and $exp) {
		fail($msg);
		diag("  exclusion unexpectedly failed with version $v");
	    } else {
		pass($msg);
	    }
	} else {
	    fail($msg);
	    diag("  unexpected error exit with version $v:\n$stderr");
	}
    }

    rmtree($datadir) if -e $datadir;
}

# We'll trust that the following logic is implemented correctly in GNU Tar
# --wildcards is the default (same as no args)
# --no-unquote / --unquote has no effect

# --wildcards
test_gnutar_exclusion(
    extra_args => [],
    expectations => {
	'!1.23' => 'gamma',
	'1.23' => 'delta',
    },
);

# --no-wildcards
test_gnutar_exclusion(
    extra_args => [ '--no-wildcards' ],
    expectations => {
	'*' => 'empty',
    },
);

## list (-t)

sub test_gnutar_toc {
    my %params = @_;

    my $vi = get_version_index($params{'versions'});

    my @patterns = @{ $params{'patterns'} };
    my @filenames;
    my @expectations;
    while (@patterns) {
	my $file = shift @patterns;
	my $exp = shift @patterns;
	$exp = $exp->[$vi];

	push @filenames, $file;
	push @expectations, $exp;
    }

    my $eargs = '';
    $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
    my $msg = "list$eargs, with lots of funny characters";

    # make a tarfile containing the filenames, then run -t over it
    rmtree($datadir) if -e $datadir;
    mkpath($datadir);

    for my $fn (@filenames) {
	open(my $fh, ">", "$datadir/$fn")
	    or die("opening $datadir/$fn: $!");
	print $fh "data";
	close($fh);
    }

    system($gnutar, "-C", $datadir, "-cf", $tarfile, '.');
    die "could not run gnutar" unless $? == 0;

    rmtree($datadir) if -e $datadir;
    my %env;
    if ($params{'env'}) {
	%env = %{$params{'env'}};
    }
    my $ok = run_gnutar(args => [ '-t', '-f', $tarfile, @{$params{'extra_args'}}],
			env => \%env);
    if (!$ok) {
	fail($msg);
	diag("gnutar exited with nonzero status for version $v");
    }

    my @toc_members = sort split(/\n/, $stdout);
    shift @toc_members; # strip off './'
    is_deeply([ @toc_members ], [ @expectations ], $msg);
}

# there are no extra_args that seem to affect this behavior
test_gnutar_toc(
    extra_args => [],
    env => { LC_CTYPE => 'C' }, # avoid any funniness with ctypes
    versions =>  [ '*' ],
    patterns => [
	"A\007", [ './A\a' ],
	"B\010", [ './B\b' ],
	"C\011", [ './C\t' ],
	"D\012", [ './D\n' ],
	"E\013", [ './E\v' ],
	"F\014", [ './F\f' ],
	"G\015", [ './G\r' ],
	"H\\",   [ './H\\\\' ], # H\ -> H\\
	"I\177", [ './I\\177' ],
	"J\317\264", [ './J\\317\\264' ], # use legitimate utf-8, for mac os fs
	"K\\x",  [ './K\\\\x' ],
	"L\\\\", [ './L\\\\\\\\' ],
    ],
);

unlink($tarfile);
