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