Imported Upstream version 3.2.0
[debian/amanda] / installcheck / gnutar.pl
diff --git a/installcheck/gnutar.pl b/installcheck/gnutar.pl
new file mode 100644 (file)
index 0000000..a7eaecd
--- /dev/null
@@ -0,0 +1,553 @@
+# 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);