git.gag.com Git - debian/amanda/blob - installcheck/gnutar.pl

   1 # Copyright (c) 2009-2012 Zmanda, Inc.  All Rights Reserved.
   2 #
   3 # This program is free software; you can redistribute it and/or modify it
   4 # under the terms of the GNU General Public License version 2 as published
   5 # by the Free Software Foundation.
   6 #
   7 # This program is distributed in the hope that it will be useful, but
   8 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
   9 # or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  10 # for more details.
  11 #
  12 # You should have received a copy of the GNU General Public License along
  13 # with this program; if not, write to the Free Software Foundation, Inc.,
  14 # 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
  15 #
  16 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
  17 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
  18
  19 use Test::More tests => 201;
  20 use File::Path;
  21 use Data::Dumper;
  22 use POSIX qw( WIFEXITED );
  23 use warnings;
  24 use strict;
  25
  26 use lib "@amperldir@";
  27 use Installcheck;
  28 use IPC::Open3;
  29 use Amanda::Constants;
  30 use Amanda::Util qw( slurp );
  31
  32 ## this is an unusual installcheck, because it does not test anything about
  33 ## Amanda itself.  However, it validates the accuracy of our understanding of
  34 ## GNU Tar's behavior, as recorded at
  35 ##  http://wiki.zmanda.com/index.php/GNU_Tar_Include_and_Exclude_Behavior
  36
  37 my $gnutar = $Amanda::Constants::GNUTAR;
  38 $gnutar = $ENV{'GNUTAR'} if exists $ENV{'GNUTAR'};
  39
  40 ## get set up
  41
  42 my @filenames = (qw{A*A AxA B?B BxB C[C CC D]D E\E F'F G"G}, 'H H');
  43
  44 my $tarfile = "$Installcheck::TMP/gnutar-tests.tar";
  45 my $datadir = "$Installcheck::TMP/gnutar-tests";
  46
  47 sub make_tarfile
  48 {
  49     my @extra_args = @_;
  50
  51     rmtree($datadir) if -e $datadir;
  52     mkpath($datadir);
  53
  54     for my $fn (@filenames) {
  55         open(my $fh, ">", "$datadir/$fn");
  56         print $fh "data";
  57         close($fh);
  58     }
  59
  60     system($gnutar, "-C", $datadir, "-cf", $tarfile, @extra_args, '.');
  61     die "could not run gnutar" unless $? == 0;
  62
  63     rmtree($datadir) if -e $datadir;
  64 }
  65
  66 ## gnutar version
  67
  68 my ($v, $numeric_version);
  69 {
  70     my $verstring = `$gnutar --version`;
  71     die "could not run gnutar" unless $? == 0;
  72     ($v) = ($verstring =~ /tar \(GNU tar\) *([0-9.]+)/);
  73     my ($maj, $min, $mic) = ($v =~ /([0-9]+)\.([0-9]+)(?:\.([0-9]+))?/);
  74
  75     $numeric_version = 0;
  76     $numeric_version += $maj * 10000 if $maj;
  77     $numeric_version += $min * 100 if $min;
  78     $numeric_version += $mic if $mic;
  79
  80 }
  81
  82 my ($fc14, $fc15);
  83 {
  84     my $uname = `uname -a`;
  85     if ($uname =~ /\.fc14\./) {
  86         $fc14 = 1;
  87     }
  88     if ($uname =~ /\.fc15\./) {
  89         $fc15 = 1;
  90     }
  91     if ($uname =~ /\.fc16\./) { #like fc15
  92         $fc15 = 1;
  93     }
  94 }
  95
  96 # see if the default for --wildcards during inclusion has been changed
  97 my $wc_default_changed = 0;
  98 {
  99     my $help_output = `$gnutar --help`;
 100     # redhatty patches helpfully change the help message
 101     if ($help_output =~ /--wildcards\s*use wildcards \(default\)$/m) {
 102         $wc_default_changed = 1;
 103     }
 104 }
 105
 106 my %version_classes = (
 107     '<1.16' => $numeric_version < 11591,
 108     '>=1.16' => $numeric_version >= 11591,
 109     '>=1.16-no-wc' => $numeric_version >= 11591 && !$wc_default_changed, # normal
 110     '>=1.16-wc' => $numeric_version >= 11591 && $wc_default_changed, # stupid distros screw things up!
 111     '1.16..<1.25' => $numeric_version >= 11591 && $numeric_version < 12500,
 112
 113     '<1.23' => $numeric_version < 12300,
 114     '>=1.23' => $numeric_version >= 12300,
 115     '*' => 1,
 116     '1.23' => ($numeric_version >= 12290 and $numeric_version <= 12300),
 117     '1.23fc14' => ($numeric_version == 12300 and $fc14),
 118     '!1.23' => ($numeric_version < 12290 || ($numeric_version > 12300 && $numeric_version < 12500)),
 119     '>=1.25' => $numeric_version >= 12500,
 120     'fc15' => ($numeric_version >= 12500 and $fc15),
 121 );
 122
 123 # include and exclude all use the same set of patterns and filenames
 124 my $patterns = [
 125         './A*A' =>      'A*A',
 126         './A*A' =>      'AxA',
 127         './B?B' =>      'B?B',
 128         './B?B' =>      'BxB',
 129         './C[C' =>      'C[C',
 130         './D]D' =>      'D]D',
 131         './E\\E' =>     'E\\E',
 132         './F\'F' =>     'F\'F',
 133         './G"G' =>      'G"G',
 134         './H H' =>      'H H',
 135         './A\\*A' =>    'A*A',
 136         './A\\*A' =>    'AxA',
 137         './B\\?B' =>    'B?B',
 138         './B\\?B' =>    'BxB',
 139         './C\\[C' =>    'C[C',
 140         './D\\]D' =>    'D]D',
 141         './E\\\\E' =>   'E\\E',
 142         './F\\\'F' =>   'F\'F',
 143         './G\\"G' =>    'G"G',
 144         './H\\ H' =>    'H H',
 145 ];
 146
 147 my $named_expectations = [
 148     [ 'alpha',
 149          'beta',
 150             'gamma',
 151                'delta',
 152                   'epsilon',
 153                      'zeta',
 154                         'eta',
 155                            'iota',
 156                               'empty', ],
 157     #  al be ga de ep ze et io empty
 158     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './A*A' =>   'A*A',
 159     [  1, 1, 1, 1, 0, 1, 1, 1, 0,     ], # './A*A' =>   'AxA',
 160     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './B?B' =>   'B?B',
 161     [  1, 1, 1, 1, 0, 1, 1, 1, 0,     ], # './B?B' =>   'BxB',
 162     [  0, 0, 0, 0, 1, 1, 1, 1, 1,     ], # './C[C' =>   'C[C',
 163     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './D]D' =>   'D]D',
 164     [  1, 0, 0, 1, 1, 0, 0, 1, 1,     ], # './E\\E' =>  'E\\E',
 165     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './F\'F' =>  'F\'F',
 166     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './G"G' =>   'G"G',
 167     [  1, 1, 1, 1, 1, 1, 1, 1, 1,     ], # './H H' =>   'H H',
 168     [  1, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './A\\*A' => 'A*A',
 169     [  0, 0, 0, 0, 0, 0, 0, 0, 0,     ], # './A\\*A' => 'AxA',
 170     [  0, 0, 1, 0, 0, 0, 1, 0, 0,     ], # './B\\?B' => 'B?B',
 171     [  0, 0, 0, 0, 0, 0, 0, 0, 0,     ], # './B\\?B' => 'BxB',
 172     [  1, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './C\\[C' => 'C[C',
 173     [  0, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './D\\]D' => 'D]D',
 174     [  1, 0, 1, 0, 1, 0, 1, 0, 0,     ], # './E\\\\E' =>        'E\\E',
 175     [  0, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './F\\\'F' =>        'F\'F',
 176     [  0, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './G\\"G' => 'G"G',
 177     [  0, 1, 1, 0, 0, 1, 1, 0, 0,     ], # './H\\ H' => 'H H',
 178 ];
 179
 180 sub get_expectation {
 181     my ($name) = @_;
 182     my @names = @{$named_expectations->[0]};
 183
 184     # get the index for that greek letter
 185     my $i;
 186     for (0 .. $#names) {
 187         if ($names[$_] eq $name) {
 188             $i = $_;
 189             last;
 190         }
 191     }
 192
 193     # then assemble the result
 194     my @rv;
 195     my @exps = @$named_expectations;
 196     shift @exps;
 197     for (@exps) {
 198         push @rv, $_->[$i];
 199     }
 200
 201     return @rv;
 202 }
 203
 204 sub get_matching_type {
 205     my ($expectations) = @_;
 206
 207     # find the type for the first matching version
 208     foreach my $exp (@$expectations) {
 209         foreach (keys %$exp) {
 210             if ($version_classes{$_}) {
 211                 return $exp->{$_};
 212             }
 213         }
 214     }
 215     return undef;
 216 }
 217
 218 sub get_version_index {
 219     my @versions = @{$_[0]};
 220
 221     my $vi;
 222     for (0 .. $#versions) {
 223         if ($version_classes{$versions[$_]}) {
 224             return $_;
 225         }
 226     }
 227     return undef;
 228 }
 229
 230 ## utils
 231
 232 my ($stderr, $stdout, $exit_code);
 233 sub run_gnutar {
 234     my %params = @_;
 235     my @args = @{ $params{'args'} };
 236
 237     my $errtempfile = "$Installcheck::TMP/stderr$$.out";
 238
 239     # use a temporary file for error output -- this eliminates synchronization
 240     # problems between reading stderr and stdout
 241     local (*INFH, *OUTFH, *ERRFH);
 242     open(ERRFH, ">", $errtempfile);
 243
 244     local %ENV;
 245     if ($params{'env'}) {
 246         my %env = %{$params{'env'}};
 247         for (keys %env) {
 248             $ENV{$_} = $env{$_};
 249         }
 250     }
 251
 252     my $pid = IPC::Open3::open3("INFH", "OUTFH", ">&ERRFH", $gnutar, @args);
 253     my $cmdline = "$gnutar " . join(' ', @args);
 254
 255     # immediately close the child's stdin
 256     close(INFH);
 257
 258     # read from stdout until it's closed
 259     $stdout = do { local $/; <OUTFH> };
 260     close(OUTFH);
 261
 262     # and wait for the kid to die
 263     waitpid $pid, 0 or croak("Error waiting for gnutar die: $@");
 264     my $status = $?;
 265     close(ERRFH);
 266
 267     # fetch stderr from the temporary file
 268     $stderr = slurp($errtempfile);
 269     unlink($errtempfile);
 270
 271     # get the exit status
 272     $exit_code = WIFEXITED($status)? ($status >> 8) : 0xffff;
 273
 274     if ($exit_code != 0) {
 275         return 0;
 276     } else {
 277         return 1;
 278     }
 279 }
 280
 281 ## inclusion tests (using -x and filenames on the command line)
 282
 283 sub test_gnutar_inclusion {
 284     my %params = @_;
 285
 286     my $matching_type = get_matching_type($params{'expectations'});
 287
 288     # skip these tests if there's no matching version
 289     if (!defined $matching_type) {
 290         SKIP: {
 291             my $msg = (join " ", @{$params{'extra_args'}}) .
 292                         " not supported in version $v";
 293             my $count = @$patterns / 2;
 294             skip $msg, $count;
 295         }
 296         return;
 297     }
 298
 299     make_tarfile();
 300     my @patterns = @$patterns;
 301     my @expectations = get_expectation($matching_type);
 302     while (@patterns) {
 303         my $pat = shift @patterns;
 304         my $file = shift @patterns;
 305         my $exp = shift @expectations;
 306
 307         my $eargs = '';
 308         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 309         my $match = $exp? "matches" : "does not match";
 310         my $msg = "inclusion$eargs, pattern $pat $match file $file";
 311
 312         rmtree($datadir) if -e $datadir;
 313         mkpath($datadir);
 314
 315         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, $pat ]);
 316         $ok = 0 unless -f "$datadir/$file";
 317         if ($ok and !$exp) {
 318             fail($msg);
 319             diag("  unexpected success with version $v");
 320         } elsif (!$ok and $exp) {
 321             fail($msg);
 322             diag("  unexpected failure with version $v:\n$stderr");
 323         } else {
 324             pass($msg);
 325         }
 326     }
 327     rmtree($datadir) if -e $datadir;
 328 }
 329
 330 # We'll trust that the following logic is implemented correctly in GNU Tar
 331 # --no-wildcards is the default (same as no args) (but not everywhere!!)
 332 # --unquote is the default (same as no args) (this seems true universally)
 333
 334 test_gnutar_inclusion(
 335     extra_args => [],
 336     expectations => [
 337         {'<1.16' => 'alpha'},
 338         {'1.23fc14' => 'zeta'},
 339         {'fc15' => 'zeta'},
 340         {'>=1.16-no-wc' => 'epsilon'},
 341         {'>=1.16-wc' => 'beta'}, # acts like --wildcards
 342     ],
 343 );
 344
 345 test_gnutar_inclusion(
 346     extra_args => [ '--no-wildcards' ],
 347     expectations => [
 348         {'<1.16' => 'alpha'},
 349         {'>=1.16' => 'epsilon'},
 350     ],
 351 );
 352
 353 test_gnutar_inclusion(
 354     extra_args => [ '--no-unquote' ],
 355     expectations => [
 356         {'<1.16' => undef},
 357         {'1.23fc14' => 'eta'},
 358         {'fc15' => 'eta'},
 359         {'>=1.16-no-wc' => 'empty'},
 360         {'>=1.16-wc' => 'gamma'}, # acts like --wildcards --no-unquote
 361     ],
 362 );
 363
 364 test_gnutar_inclusion(
 365     extra_args => [ '--no-wildcards', '--no-unquote' ],
 366     expectations => [
 367         {'<1.16' => undef},
 368         {'>=1.16' => 'empty'},
 369     ],
 370 );
 371
 372 test_gnutar_inclusion(
 373     extra_args => [ '--wildcards' ],
 374     expectations => [
 375         {'<1.16' => 'alpha'},
 376         {'1.23fc14' => 'zeta'},
 377         {'1.16..<1.25' => 'beta'},
 378         {'>=1.25' => 'zeta'},
 379     ],
 380 );
 381
 382 test_gnutar_inclusion(
 383     extra_args => [ '--wildcards', '--no-unquote' ],
 384     expectations => [
 385         {'<1.16' => undef},
 386         {'1.23fc14' => 'eta'},
 387         {'1.16..<1.25' => 'gamma'},
 388         {'>=1.25' => 'eta'},
 389     ],
 390 );
 391
 392 ## exclusion tests (using -t and filenames on the command line)
 393
 394 sub test_gnutar_exclusion {
 395     my %params = @_;
 396
 397     my $matching_type = get_matching_type($params{'expectations'});
 398
 399     # skip these tests if there's no matching version
 400     if (!defined $matching_type) {
 401         SKIP: {
 402             my $msg = (join " ", @{$params{'extra_args'}}) .
 403                         " not supported in version $v";
 404             my $count = @$patterns; # two elements per test, but we run each one twice
 405             skip $msg, $count;
 406         }
 407         return;
 408     }
 409
 410     make_tarfile();
 411     my @patterns = @$patterns;
 412     my @expectations = get_expectation($matching_type);
 413     while (@patterns) {
 414         my $pat = shift @patterns;
 415         my $file = shift @patterns;
 416         my $exp = shift @expectations;
 417
 418         my $eargs = '';
 419         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 420         my $match = $exp? "matches" : "does not match";
 421         my $msg = "exclusion$eargs, extract, pattern $pat $match $file";
 422
 423         rmtree($datadir) if -e $datadir;
 424         mkpath($datadir);
 425
 426         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, "--exclude=$pat" ]);
 427
 428         # fail if the excluded file was extracted anyway..
 429         if ($ok) {
 430             my $excluded_ok = ! -f "$datadir/$file";
 431             if ($excluded_ok and !$exp) {
 432                 fail($msg);
 433                 diag("  exclusion unexpectedly worked with version $v");
 434             } elsif (!$excluded_ok and $exp) {
 435                 fail($msg);
 436                 diag("  exclusion unexpectedly failed with version $v");
 437             } else {
 438                 pass($msg);
 439             }
 440         } else {
 441             fail($msg);
 442             diag("  unexpected error exit with version $v:\n$stderr");
 443         }
 444     }
 445
 446     # test again, but this time during a 'c'reate operation
 447     @patterns = @$patterns;
 448     @expectations = get_expectation($matching_type);
 449     while (@patterns) {
 450         my $pat = shift @patterns;
 451         my $file = shift @patterns;
 452         my $exp = shift @expectations;
 453
 454         my $eargs = '';
 455         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 456         my $match = $exp? "matches" : "does not match";
 457         my $msg = "exclusion$eargs, create, pattern $pat $match $file";
 458
 459         # this time around, we create the tarball with the exclude, then extract the whole
 460         # thing.  We extract rather than using 't' because 't' has a funny habit of backslashing
 461         # its output that we don't want to deal with here.
 462         make_tarfile(@{$params{'extra_args'}}, "--exclude=$pat");
 463
 464         rmtree($datadir) if -e $datadir;
 465         mkpath($datadir);
 466         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile]);
 467
 468         # fail if the excluded file was extracted anyway..
 469         if ($ok) {
 470             my $excluded_ok = ! -f "$datadir/$file";
 471             if ($excluded_ok and !$exp) {
 472                 fail($msg);
 473                 diag("  exclusion unexpectedly worked with version $v");
 474             } elsif (!$excluded_ok and $exp) {
 475                 fail($msg);
 476                 diag("  exclusion unexpectedly failed with version $v");
 477             } else {
 478                 pass($msg);
 479             }
 480         } else {
 481             fail($msg);
 482             diag("  unexpected error exit with version $v:\n$stderr");
 483         }
 484     }
 485
 486     rmtree($datadir) if -e $datadir;
 487 }
 488
 489 # We'll trust that the following logic is implemented correctly in GNU Tar
 490 # --wildcards is the default (same as no args)
 491 # --no-unquote / --unquote has no effect
 492
 493 # --wildcards
 494 test_gnutar_exclusion(
 495     extra_args => [],
 496     expectations => [
 497         {'!1.23' => 'gamma'},
 498         {'1.23fc14' => 'iota'},
 499         {'1.23' => 'delta'},
 500         {'>=1.25' => 'eta'},
 501     ],
 502 );
 503
 504 # --no-wildcards
 505 test_gnutar_exclusion(
 506     extra_args => [ '--no-wildcards' ],
 507     expectations => [
 508         {'*' => 'empty'},
 509     ],
 510 );
 511
 512 ## list (-t)
 513
 514 sub test_gnutar_toc {
 515     my %params = @_;
 516
 517     my $vi = get_version_index($params{'versions'});
 518
 519     my @patterns = @{ $params{'patterns'} };
 520     my @filenames;
 521     my @expectations;
 522     while (@patterns) {
 523         my $file = shift @patterns;
 524         my $exp = shift @patterns;
 525         $exp = $exp->[$vi];
 526
 527         push @filenames, $file;
 528         push @expectations, $exp;
 529     }
 530
 531     my $eargs = '';
 532     $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 533     my $msg = "list$eargs, with lots of funny characters";
 534
 535     # make a tarfile containing the filenames, then run -t over it
 536     rmtree($datadir) if -e $datadir;
 537     mkpath($datadir);
 538
 539     for my $fn (@filenames) {
 540         open(my $fh, ">", "$datadir/$fn")
 541             or die("opening $datadir/$fn: $!");
 542         print $fh "data";
 543         close($fh);
 544     }
 545
 546     system($gnutar, "-C", $datadir, "-cf", $tarfile, '.');
 547     die "could not run gnutar" unless $? == 0;
 548
 549     rmtree($datadir) if -e $datadir;
 550     my %env;
 551     if ($params{'env'}) {
 552         %env = %{$params{'env'}};
 553     }
 554     my $ok = run_gnutar(args => [ '-t', '-f', $tarfile, @{$params{'extra_args'}}],
 555                         env => \%env);
 556     if (!$ok) {
 557         fail($msg);
 558         diag("gnutar exited with nonzero status for version $v");
 559     }
 560
 561     my @toc_members = sort split(/\n/, $stdout);
 562     shift @toc_members; # strip off './'
 563     is_deeply([ @toc_members ], [ @expectations ], $msg);
 564 }
 565
 566 # there are no extra_args that seem to affect this behavior
 567 test_gnutar_toc(
 568     extra_args => [],
 569     env => { LC_CTYPE => 'C' }, # avoid any funniness with ctypes
 570     versions =>  [ '*' ],
 571     patterns => [
 572         "A\007", [ './A\a' ],
 573         "B\010", [ './B\b' ],
 574         "C\011", [ './C\t' ],
 575         "D\012", [ './D\n' ],
 576         "E\013", [ './E\v' ],
 577         "F\014", [ './F\f' ],
 578         "G\015", [ './G\r' ],
 579         "H\\",   [ './H\\\\' ], # H\ -> H\\
 580         "I\177", [ './I\\177' ],
 581         "J\317\264", [ './J\\317\\264' ], # use legitimate utf-8, for mac os fs
 582         "K\\x",  [ './K\\\\x' ],
 583         "L\\\\", [ './L\\\\\\\\' ],
 584     ],
 585 );
 586
 587 unlink($tarfile);