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

   1 # Copyright (c) 2009, 2010 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 # see if the default for --wildcards during inclusion has been changed
  82 my $wc_default_changed = 0;
  83 {
  84     my $help_output = `$gnutar --help`;
  85     # redhatty patches helpfully change the help message
  86     if ($help_output =~ /--wildcards\s*use wildcards \(default\)$/m) {
  87         $wc_default_changed = 1;
  88     }
  89 }
  90
  91 my %version_classes = (
  92     '<1.16' => $numeric_version < 11591,
  93     '>=1.16' => $numeric_version >= 11591,
  94     '>=1.16-no-wc' => $numeric_version >= 11591 && !$wc_default_changed, # normal
  95     '>=1.16-wc' => $numeric_version >= 11591 && $wc_default_changed, # stupid distros screw things up!
  96     '1.16..<1.25' => $numeric_version >= 11591 && $numeric_version < 12500,
  97
  98     '<1.23' => $numeric_version < 12300,
  99     '>=1.23' => $numeric_version >= 12300,
 100     '*' => 1,
 101     '1.23' => ($numeric_version >= 12290 and $numeric_version <= 12300),
 102     '!1.23' => ($numeric_version < 12290 || ($numeric_version > 12300 && $numeric_version < 12500)),
 103     '>=1.25' => $numeric_version >= 12500.
 104 );
 105
 106 # include and exclude all use the same set of patterns and filenames
 107 my $patterns = [
 108         './A*A' =>      'A*A',
 109         './A*A' =>      'AxA',
 110         './B?B' =>      'B?B',
 111         './B?B' =>      'BxB',
 112         './C[C' =>      'C[C',
 113         './D]D' =>      'D]D',
 114         './E\\E' =>     'E\\E',
 115         './F\'F' =>     'F\'F',
 116         './G"G' =>      'G"G',
 117         './H H' =>      'H H',
 118         './A\\*A' =>    'A*A',
 119         './A\\*A' =>    'AxA',
 120         './B\\?B' =>    'B?B',
 121         './B\\?B' =>    'BxB',
 122         './C\\[C' =>    'C[C',
 123         './D\\]D' =>    'D]D',
 124         './E\\\\E' =>   'E\\E',
 125         './F\\\'F' =>   'F\'F',
 126         './G\\"G' =>    'G"G',
 127         './H\\ H' =>    'H H',
 128 ];
 129
 130 my $named_expectations = [
 131     [ 'alpha',
 132          'beta',
 133             'gamma',
 134                'delta',
 135                   'epsilon',
 136                      'zeta',
 137                         'eta',
 138                            'empty', ],
 139     #  al be ga de ep ze et empty
 140     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './A*A' =>      'A*A',
 141     [  1, 1, 1, 1, 0, 1, 1, 0,     ], # './A*A' =>      'AxA',
 142     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './B?B' =>      'B?B',
 143     [  1, 1, 1, 1, 0, 1, 1, 0,     ], # './B?B' =>      'BxB',
 144     [  0, 0, 0, 0, 1, 1, 1, 1,     ], # './C[C' =>      'C[C',
 145     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './D]D' =>      'D]D',
 146     [  1, 0, 0, 1, 1, 0, 0, 1,     ], # './E\\E' =>     'E\\E',
 147     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './F\'F' =>     'F\'F',
 148     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './G"G' =>      'G"G',
 149     [  1, 1, 1, 1, 1, 1, 1, 1,     ], # './H H' =>      'H H',
 150     [  1, 1, 1, 0, 0, 1, 1, 0,     ], # './A\\*A' =>    'A*A',
 151     [  0, 0, 0, 0, 0, 0, 0, 0,     ], # './A\\*A' =>    'AxA',
 152     [  0, 0, 1, 0, 0, 0, 1, 0,     ], # './B\\?B' =>    'B?B',
 153     [  0, 0, 0, 0, 0, 0, 0, 0,     ], # './B\\?B' =>    'BxB',
 154     [  1, 1, 1, 0, 0, 1, 1, 0,     ], # './C\\[C' =>    'C[C',
 155     [  0, 1, 1, 0, 0, 1, 1, 0,     ], # './D\\]D' =>    'D]D',
 156     [  1, 0, 1, 0, 1, 0, 1, 0,     ], # './E\\\\E' =>   'E\\E',
 157     [  0, 1, 1, 0, 0, 1, 1, 0,     ], # './F\\\'F' =>   'F\'F',
 158     [  0, 1, 1, 0, 0, 1, 1, 0,     ], # './G\\"G' =>    'G"G',
 159     [  0, 1, 1, 0, 0, 1, 1, 0,     ], # './H\\ H' =>    'H H',
 160 ];
 161
 162 sub get_expectation {
 163     my ($name) = @_;
 164     my @names = @{$named_expectations->[0]};
 165
 166     # get the index for that greek letter
 167     my $i;
 168     for (0 .. $#names) {
 169         if ($names[$_] eq $name) {
 170             $i = $_;
 171             last;
 172         }
 173     }
 174
 175     # then assemble the result
 176     my @rv;
 177     my @exps = @$named_expectations;
 178     shift @exps;
 179     for (@exps) {
 180         push @rv, $_->[$i];
 181     }
 182
 183     return @rv;
 184 }
 185
 186 sub get_matching_type {
 187     my ($expectations) = @_;
 188
 189     # find the type for the first matching version
 190     for (keys %$expectations) {
 191         if ($version_classes{$_}) {
 192             return $expectations->{$_};
 193         }
 194     }
 195     return undef;
 196 }
 197
 198 sub get_version_index {
 199     my @versions = @{$_[0]};
 200
 201     my $vi;
 202     for (0 .. $#versions) {
 203         if ($version_classes{$versions[$_]}) {
 204             return $_;
 205         }
 206     }
 207     return undef;
 208 }
 209
 210 ## utils
 211
 212 my ($stderr, $stdout, $exit_code);
 213 sub run_gnutar {
 214     my %params = @_;
 215     my @args = @{ $params{'args'} };
 216
 217     my $errtempfile = "$Installcheck::TMP/stderr$$.out";
 218
 219     # use a temporary file for error output -- this eliminates synchronization
 220     # problems between reading stderr and stdout
 221     local (*INFH, *OUTFH, *ERRFH);
 222     open(ERRFH, ">", $errtempfile);
 223
 224     local %ENV;
 225     if ($params{'env'}) {
 226         my %env = %{$params{'env'}};
 227         for (keys %env) {
 228             $ENV{$_} = $env{$_};
 229         }
 230     }
 231
 232     my $pid = IPC::Open3::open3("INFH", "OUTFH", ">&ERRFH", $gnutar, @args);
 233     my $cmdline = "$gnutar " . join(' ', @args);
 234
 235     # immediately close the child's stdin
 236     close(INFH);
 237
 238     # read from stdout until it's closed
 239     $stdout = do { local $/; <OUTFH> };
 240     close(OUTFH);
 241
 242     # and wait for the kid to die
 243     waitpid $pid, 0 or croak("Error waiting for gnutar die: $@");
 244     my $status = $?;
 245     close(ERRFH);
 246
 247     # fetch stderr from the temporary file
 248     $stderr = slurp($errtempfile);
 249     unlink($errtempfile);
 250
 251     # get the exit status
 252     $exit_code = WIFEXITED($status)? ($status >> 8) : 0xffff;
 253
 254     if ($exit_code != 0) {
 255         return 0;
 256     } else {
 257         return 1;
 258     }
 259 }
 260
 261 ## inclusion tests (using -x and filenames on the command line)
 262
 263 sub test_gnutar_inclusion {
 264     my %params = @_;
 265
 266     my $matching_type = get_matching_type($params{'expectations'});
 267
 268     # skip these tests if there's no matching version
 269     if (!defined $matching_type) {
 270         SKIP: {
 271             my $msg = (join " ", @{$params{'extra_args'}}) .
 272                         " not supported in version $v";
 273             my $count = @$patterns / 2;
 274             skip $msg, $count;
 275         }
 276         return;
 277     }
 278
 279     make_tarfile();
 280     my @patterns = @$patterns;
 281     my @expectations = get_expectation($matching_type);
 282     while (@patterns) {
 283         my $pat = shift @patterns;
 284         my $file = shift @patterns;
 285         my $exp = shift @expectations;
 286
 287         my $eargs = '';
 288         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 289         my $match = $exp? "matches" : "does not match";
 290         my $msg = "inclusion$eargs, pattern $pat $match file $file";
 291
 292         rmtree($datadir) if -e $datadir;
 293         mkpath($datadir);
 294
 295         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, $pat ]);
 296         $ok = 0 unless -f "$datadir/$file";
 297         if ($ok and !$exp) {
 298             fail($msg);
 299             diag("  unexpected success with version $v");
 300         } elsif (!$ok and $exp) {
 301             fail($msg);
 302             diag("  unexpected failure with version $v:\n$stderr");
 303         } else {
 304             pass($msg);
 305         }
 306     }
 307     rmtree($datadir) if -e $datadir;
 308 }
 309
 310 # We'll trust that the following logic is implemented correctly in GNU Tar
 311 # --no-wildcards is the default (same as no args) (but not everywhere!!)
 312 # --unquote is the default (same as no args) (this seems true universally)
 313
 314 test_gnutar_inclusion(
 315     extra_args => [],
 316     expectations => {
 317         '<1.16' => 'alpha',
 318         '>=1.16-no-wc' => 'epsilon',
 319         '>=1.16-wc' => 'beta', # acts like --wildcards
 320     },
 321 );
 322
 323 test_gnutar_inclusion(
 324     extra_args => [ '--no-wildcards' ],
 325     expectations => {
 326         '<1.16' => 'alpha',
 327         '>=1.16' => 'epsilon',
 328     },
 329 );
 330
 331 test_gnutar_inclusion(
 332     extra_args => [ '--no-unquote' ],
 333     expectations => {
 334         '<1.16' => undef,
 335         '>=1.16-no-wc' => 'empty',
 336         '>=1.16-wc' => 'gamma', # acts like --wildcards --no-unquote
 337     },
 338 );
 339
 340 test_gnutar_inclusion(
 341     extra_args => [ '--no-wildcards', '--no-unquote' ],
 342     expectations => {
 343         '<1.16' => undef,
 344         '>=1.16' => 'empty',
 345     },
 346 );
 347
 348 test_gnutar_inclusion(
 349     extra_args => [ '--wildcards' ],
 350     expectations => {
 351         '<1.16' => 'alpha',
 352         '1.16..<1.25' => 'beta',
 353         '>=1.25' => 'zeta',
 354     },
 355 );
 356
 357 test_gnutar_inclusion(
 358     extra_args => [ '--wildcards', '--no-unquote' ],
 359     expectations => {
 360         '<1.16' => undef,
 361         '1.16..<1.25' => 'gamma',
 362         '>=1.25' => 'eta',
 363     },
 364 );
 365
 366 ## exclusion tests (using -t and filenames on the command line)
 367
 368 sub test_gnutar_exclusion {
 369     my %params = @_;
 370
 371     my $matching_type = get_matching_type($params{'expectations'});
 372
 373     # skip these tests if there's no matching version
 374     if (!defined $matching_type) {
 375         SKIP: {
 376             my $msg = (join " ", @{$params{'extra_args'}}) .
 377                         " not supported in version $v";
 378             my $count = @$patterns; # two elements per test, but we run each one twice
 379             skip $msg, $count;
 380         }
 381         return;
 382     }
 383
 384     make_tarfile();
 385     my @patterns = @$patterns;
 386     my @expectations = get_expectation($matching_type);
 387     while (@patterns) {
 388         my $pat = shift @patterns;
 389         my $file = shift @patterns;
 390         my $exp = shift @expectations;
 391
 392         my $eargs = '';
 393         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 394         my $match = $exp? "matches" : "does not match";
 395         my $msg = "exclusion$eargs, extract, pattern $pat $match $file";
 396
 397         rmtree($datadir) if -e $datadir;
 398         mkpath($datadir);
 399
 400         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile, @{$params{'extra_args'}}, "--exclude=$pat" ]);
 401
 402         # fail if the excluded file was extracted anyway..
 403         if ($ok) {
 404             my $excluded_ok = ! -f "$datadir/$file";
 405             if ($excluded_ok and !$exp) {
 406                 fail($msg);
 407                 diag("  exclusion unexpectedly worked with version $v");
 408             } elsif (!$excluded_ok and $exp) {
 409                 fail($msg);
 410                 diag("  exclusion unexpectedly failed with version $v");
 411             } else {
 412                 pass($msg);
 413             }
 414         } else {
 415             fail($msg);
 416             diag("  unexpected error exit with version $v:\n$stderr");
 417         }
 418     }
 419
 420     # test again, but this time during a 'c'reate operation
 421     @patterns = @$patterns;
 422     @expectations = get_expectation($matching_type);
 423     while (@patterns) {
 424         my $pat = shift @patterns;
 425         my $file = shift @patterns;
 426         my $exp = shift @expectations;
 427
 428         my $eargs = '';
 429         $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 430         my $match = $exp? "matches" : "does not match";
 431         my $msg = "exclusion$eargs, create, pattern $pat $match $file";
 432
 433         # this time around, we create the tarball with the exclude, then extract the whole
 434         # thing.  We extract rather than using 't' because 't' has a funny habit of backslashing
 435         # its output that we don't want to deal with here.
 436         make_tarfile(@{$params{'extra_args'}}, "--exclude=$pat");
 437
 438         rmtree($datadir) if -e $datadir;
 439         mkpath($datadir);
 440         my $ok = run_gnutar(args => [ '-C', $datadir, '-x', '-f', $tarfile]);
 441
 442         # fail if the excluded file was extracted anyway..
 443         if ($ok) {
 444             my $excluded_ok = ! -f "$datadir/$file";
 445             if ($excluded_ok and !$exp) {
 446                 fail($msg);
 447                 diag("  exclusion unexpectedly worked with version $v");
 448             } elsif (!$excluded_ok and $exp) {
 449                 fail($msg);
 450                 diag("  exclusion unexpectedly failed with version $v");
 451             } else {
 452                 pass($msg);
 453             }
 454         } else {
 455             fail($msg);
 456             diag("  unexpected error exit with version $v:\n$stderr");
 457         }
 458     }
 459
 460     rmtree($datadir) if -e $datadir;
 461 }
 462
 463 # We'll trust that the following logic is implemented correctly in GNU Tar
 464 # --wildcards is the default (same as no args)
 465 # --no-unquote / --unquote has no effect
 466
 467 # --wildcards
 468 test_gnutar_exclusion(
 469     extra_args => [],
 470     expectations => {
 471         '!1.23' => 'gamma',
 472         '1.23' => 'delta',
 473         '>=1.25' => 'eta',
 474     },
 475 );
 476
 477 # --no-wildcards
 478 test_gnutar_exclusion(
 479     extra_args => [ '--no-wildcards' ],
 480     expectations => {
 481         '*' => 'empty',
 482     },
 483 );
 484
 485 ## list (-t)
 486
 487 sub test_gnutar_toc {
 488     my %params = @_;
 489
 490     my $vi = get_version_index($params{'versions'});
 491
 492     my @patterns = @{ $params{'patterns'} };
 493     my @filenames;
 494     my @expectations;
 495     while (@patterns) {
 496         my $file = shift @patterns;
 497         my $exp = shift @patterns;
 498         $exp = $exp->[$vi];
 499
 500         push @filenames, $file;
 501         push @expectations, $exp;
 502     }
 503
 504     my $eargs = '';
 505     $eargs = ', ' . join(' ', @{$params{'extra_args'}}) if @{$params{'extra_args'}};
 506     my $msg = "list$eargs, with lots of funny characters";
 507
 508     # make a tarfile containing the filenames, then run -t over it
 509     rmtree($datadir) if -e $datadir;
 510     mkpath($datadir);
 511
 512     for my $fn (@filenames) {
 513         open(my $fh, ">", "$datadir/$fn")
 514             or die("opening $datadir/$fn: $!");
 515         print $fh "data";
 516         close($fh);
 517     }
 518
 519     system($gnutar, "-C", $datadir, "-cf", $tarfile, '.');
 520     die "could not run gnutar" unless $? == 0;
 521
 522     rmtree($datadir) if -e $datadir;
 523     my %env;
 524     if ($params{'env'}) {
 525         %env = %{$params{'env'}};
 526     }
 527     my $ok = run_gnutar(args => [ '-t', '-f', $tarfile, @{$params{'extra_args'}}],
 528                         env => \%env);
 529     if (!$ok) {
 530         fail($msg);
 531         diag("gnutar exited with nonzero status for version $v");
 532     }
 533
 534     my @toc_members = sort split(/\n/, $stdout);
 535     shift @toc_members; # strip off './'
 536     is_deeply([ @toc_members ], [ @expectations ], $msg);
 537 }
 538
 539 # there are no extra_args that seem to affect this behavior
 540 test_gnutar_toc(
 541     extra_args => [],
 542     env => { LC_CTYPE => 'C' }, # avoid any funniness with ctypes
 543     versions =>  [ '*' ],
 544     patterns => [
 545         "A\007", [ './A\a' ],
 546         "B\010", [ './B\b' ],
 547         "C\011", [ './C\t' ],
 548         "D\012", [ './D\n' ],
 549         "E\013", [ './E\v' ],
 550         "F\014", [ './F\f' ],
 551         "G\015", [ './G\r' ],
 552         "H\\",   [ './H\\\\' ], # H\ -> H\\
 553         "I\177", [ './I\\177' ],
 554         "J\317\264", [ './J\\317\\264' ], # use legitimate utf-8, for mac os fs
 555         "K\\x",  [ './K\\\\x' ],
 556         "L\\\\", [ './L\\\\\\\\' ],
 557     ],
 558 );
 559
 560 unlink($tarfile);