lib/Archive/Extract/t/01_Archive-Extract.t

   1 BEGIN {
   2     if( $ENV{PERL_CORE} ) {
   3         chdir '../lib/Archive/Extract' if -d '../lib/Archive/Extract';
   4         unshift @INC, '../../..', '../../../..';
   5     }
   6 }
   7
   8 BEGIN { chdir 't' if -d 't' };
   9 BEGIN { mkdir 'out' unless -d 'out' };
  10
  11 ### left behind, at least on Win32. See core patch #31904
  12 END   { rmtree('out') };
  13
  14 use strict;
  15 use lib qw[../lib];
  16
  17 use constant IS_WIN32   => $^O eq 'MSWin32' ? 1 : 0;
  18 use constant IS_CYGWIN  => $^O eq 'cygwin'  ? 1 : 0;
  19 use constant IS_VMS     => $^O eq 'VMS'     ? 1 : 0;
  20
  21 use Cwd                         qw[cwd];
  22 use Test::More                  qw[no_plan];
  23 use File::Spec;
  24 use File::Spec::Unix;
  25 use File::Path;
  26 use Data::Dumper;
  27 use File::Basename              qw[basename];
  28 use Module::Load::Conditional   qw[check_install];
  29
  30 ### uninitialized value in File::Spec warnings come from A::Zip:
  31 # t/01_Archive-Extract....ok 135/0Use of uninitialized value in concatenation (.) or string at /opt/lib/perl5/5.8.3/File/Spec/Unix.pm line 313.
  32 #         File::Spec::Unix::catpath('File::Spec','','','undef') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 473
  33 #         Archive::Zip::_asLocalName('') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 652
  34 #         Archive::Zip::Archive::extractMember('Archive::Zip::Archive=HASH(0x9679c8)','Archive::Zip::ZipFileMember=HASH(0x9678fc)') called at ../lib/Archive/Extract.pm line 753
  35 #         Archive::Extract::_unzip_az('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 674
  36 #         Archive::Extract::_unzip('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 275
  37 #         Archive::Extract::extract('Archive::Extract=HASH(0x966eac)','to','/Users/kane/sources/p4/other/archive-extract/t/out') called at t/01_Archive-Extract.t line 180
  38 #BEGIN { $SIG{__WARN__} = sub { require Carp; Carp::cluck(@_) } };
  39
  40 if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
  41     diag( "Older versions of Archive::Zip may cause File::Spec warnings" );
  42     diag( "See bug #19713 in rt.cpan.org. It is safe to ignore them" );
  43 }
  44
  45 my $Debug   = $ARGV[0] ? 1 : 0;
  46 my $Me      = basename( $0 );
  47 my $Class   = 'Archive::Extract';
  48 my $Self    = File::Spec->rel2abs(
  49                     IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd()
  50                 );
  51 my $SrcDir  = File::Spec->catdir( $Self,'src' );
  52 my $OutDir  = File::Spec->catdir( $Self,'out' );
  53
  54 use_ok($Class);
  55
  56 ### set verbose if debug is on ###
  57 ### stupid stupid silly stupid warnings silly! ###
  58 $Archive::Extract::VERBOSE  = $Archive::Extract::VERBOSE = $Debug;
  59 $Archive::Extract::WARN     = $Archive::Extract::WARN    = $Debug ? 1 : 0;
  60
  61
  62 my $tmpl = {
  63     ### plain files
  64     'x.bz2' => {    programs    => [qw[bunzip2]],
  65                     modules     => [qw[IO::Uncompress::Bunzip2]],
  66                     method      => 'is_bz2',
  67                     outfile     => 'a',
  68                 },
  69     'x.tgz' => {    programs    => [qw[gzip tar]],
  70                     modules     => [qw[Archive::Tar IO::Zlib]],
  71                     method      => 'is_tgz',
  72                     outfile     => 'a',
  73                 },
  74     'x.tar.gz' => { programs    => [qw[gzip tar]],
  75                     modules     => [qw[Archive::Tar IO::Zlib]],
  76                     method      => 'is_tgz',
  77                     outfile     => 'a',
  78                 },
  79     'x.tar' => {    programs    => [qw[tar]],
  80                     modules     => [qw[Archive::Tar]],
  81                     method      => 'is_tar',
  82                     outfile     => 'a',
  83                 },
  84     'x.gz'  => {    programs    => [qw[gzip]],
  85                     modules     => [qw[Compress::Zlib]],
  86                     method      => 'is_gz',
  87                     outfile     => 'a',
  88                 },
  89     'x.Z'   => {    programs    => [qw[uncompress]],
  90                     modules     => [qw[Compress::Zlib]],
  91                     method      => 'is_Z',
  92                     outfile     => 'a',
  93                 },
  94     'x.zip' => {    programs    => [qw[unzip]],
  95                     modules     => [qw[Archive::Zip]],
  96                     method      => 'is_zip',
  97                     outfile     => 'a',
  98                 },
  99     'x.jar' => {    programs    => [qw[unzip]],
 100                     modules     => [qw[Archive::Zip]],
 101                     method      => 'is_zip',
 102                     outfile     => 'a',
 103                 },
 104     'x.par' => {    programs    => [qw[unzip]],
 105                     modules     => [qw[Archive::Zip]],
 106                     method      => 'is_zip',
 107                     outfile     => 'a',
 108                 },
 109     'x.lzma' => {   programs    => [qw[unlzma]],
 110                     modules     => [qw[Compress::unLZMA]],
 111                     method      => 'is_lzma',
 112                     outfile     => 'a',
 113                 },
 114     ### with a directory
 115     'y.tbz'     => {    programs    => [qw[bunzip2 tar]],
 116                         modules     => [qw[Archive::Tar
 117                                            IO::Uncompress::Bunzip2]],
 118                         method      => 'is_tbz',
 119                         outfile     => 'z',
 120                         outdir      => 'y',
 121                     },
 122     'y.tar.bz2' => {    programs    => [qw[bunzip2 tar]],
 123                         modules     => [qw[Archive::Tar
 124                                            IO::Uncompress::Bunzip2]],
 125                         method      => 'is_tbz',
 126                         outfile     => 'z',
 127                         outdir      => 'y'
 128                     },
 129     'y.tgz'     => {    programs    => [qw[gzip tar]],
 130                         modules     => [qw[Archive::Tar IO::Zlib]],
 131                         method      => 'is_tgz',
 132                         outfile     => 'z',
 133                         outdir      => 'y'
 134                     },
 135     'y.tar.gz' => {     programs    => [qw[gzip tar]],
 136                         modules     => [qw[Archive::Tar IO::Zlib]],
 137                         method      => 'is_tgz',
 138                         outfile     => 'z',
 139                         outdir      => 'y'
 140                     },
 141     'y.tar' => {    programs    => [qw[tar]],
 142                     modules     => [qw[Archive::Tar]],
 143                     method      => 'is_tar',
 144                     outfile     => 'z',
 145                     outdir      => 'y'
 146                 },
 147     'y.zip' => {    programs    => [qw[unzip]],
 148                     modules     => [qw[Archive::Zip]],
 149                     method      => 'is_zip',
 150                     outfile     => 'z',
 151                     outdir      => 'y'
 152                 },
 153     'y.par' => {    programs    => [qw[unzip]],
 154                     modules     => [qw[Archive::Zip]],
 155                     method      => 'is_zip',
 156                     outfile     => 'z',
 157                     outdir      => 'y'
 158                 },
 159     'y.jar' => {    programs    => [qw[unzip]],
 160                     modules     => [qw[Archive::Zip]],
 161                     method      => 'is_zip',
 162                     outfile     => 'z',
 163                     outdir      => 'y'
 164                 },
 165     ### with non-same top dir
 166     'double_dir.zip' => {
 167                     programs    => [qw[unzip]],
 168                     modules     => [qw[Archive::Zip]],
 169                     method      => 'is_zip',
 170                     outfile     => 'w',
 171                     outdir      => 'x'
 172                 },
 173 };
 174
 175 ### XXX special case: on older solaris boxes (8),
 176 ### bunzip2 is version 0.9.x. Older versions (pre 1),
 177 ### only extract files that end in .bz2, and nothing
 178 ### else. So remove that test case if we have an older
 179 ### bunzip2 :(
 180 {   if( $Class->have_old_bunzip2 ) {
 181         delete $tmpl->{'y.tbz'};
 182         diag "Old bunzip2 detected, skipping .tbz test";
 183     }
 184 }
 185
 186 ### show us the tools IPC::Cmd will use to run binary programs
 187 if( $Debug ) {
 188     diag( "IPC::Run enabled: $IPC::Cmd::USE_IPC_RUN " );
 189     diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run );
 190     diag( "IPC::Run vesion: $IPC::Run::VERSION" );
 191     diag( "IPC::Open3 enabled: $IPC::Cmd::USE_IPC_OPEN3 " );
 192     diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 );
 193     diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" );
 194 }
 195
 196 ### test all type specifications to new()
 197 ### this tests bug #24578: Wrong check for `type' argument
 198 {   my $meth = 'types';
 199
 200     can_ok( $Class, $meth );
 201
 202     my @types = $Class->$meth;
 203     ok( scalar(@types),         "   Got a list of types" );
 204
 205     for my $type ( @types ) {
 206         my $obj = $Class->new( archive => $Me, type => $type );
 207         ok( $obj,               "   Object created based on '$type'" );
 208         ok( !$obj->error,       "       No error logged" );
 209     }
 210
 211     ### test unknown type
 212     {   ### must turn on warnings to catch error here
 213         local $Archive::Extract::WARN = 1;
 214
 215         my $warnings;
 216         local $SIG{__WARN__} = sub { $warnings .= "@_" };
 217
 218         my $ae = $Class->new( archive => $Me );
 219         ok( !$ae,               "   No archive created based on '$Me'" );
 220         ok( !$Class->error,     "       Error not captured in class method" );
 221         ok( $warnings,          "       Error captured as warning" );
 222         like( $warnings, qr/Cannot determine file type for/,
 223                                 "           Error is: unknown file type" );
 224     }
 225 }
 226
 227 ### test multiple errors
 228 ### XXX whitebox test
 229 {   ### grab a random file from the template, so we can make an object
 230     my $ae = Archive::Extract->new(
 231                 archive =>  File::Spec->catfile($SrcDir,[keys %$tmpl]->[0])
 232              );
 233     ok( $ae,                    "Archive created" );
 234     ok( not($ae->error),        "   No errors yet" );
 235
 236     ### log a few errors
 237     {   local $Archive::Extract::WARN = 0;
 238         $ae->_error( $_ ) for 1..5;
 239     }
 240
 241     my $err = $ae->error;
 242     ok( $err,                   "   Errors retrieved" );
 243
 244     my $expect = join $/, 1..5;
 245     is( $err, $expect,          "       As expected" );
 246
 247     ### this resets the errors
 248     ### override the 'check' routine to return false, so we bail out of
 249     ### extract() early and just run the error reset code;
 250     {   no warnings qw[once redefine];
 251         local *Archive::Extract::check = sub { return };
 252         $ae->extract;
 253     }
 254     ok( not($ae->error),        "   Errors erased after ->extract() call" );
 255 }
 256
 257 ### XXX whitebox test
 258 ### test __get_extract_dir
 259 SKIP: {   my $meth = '__get_extract_dir';
 260
 261     ### get the right separator -- File::Spec does clean ups for
 262     ### paths, so we need to join ourselves.
 263     my $sep  = [ split '', File::Spec->catfile( 'a', 'b' ) ]->[1];
 264
 265     ### bug #23999: Attempt to generate Makefile.PL gone awry
 266     ### showed that dirs in the style of './dir/' were reported
 267     ### to be unpacked in '.' rather than in 'dir'. here we test
 268     ### for this.
 269     for my $prefix ( '', '.' ) {
 270         skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2
 271             if IS_VMS && length($prefix);
 272
 273         my $dir = basename( $SrcDir );
 274
 275         ### build a list like [dir, dir/file] and [./dir ./dir/file]
 276         ### where the dir and file actually exist, which is important
 277         ### for the method call
 278         my @files = map { length $prefix
 279                                 ? join $sep, $prefix, $_
 280                                 : $_
 281                       } $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
 282
 283         my $res = $Class->$meth( \@files );
 284         $res = &Win32::GetShortPathName( $res ) if IS_WIN32;
 285
 286         ok( $res,               "Found extraction dir '$res'" );
 287         is( $res, $SrcDir,      "   Is expected dir '$SrcDir'" );
 288     }
 289 }
 290
 291 ### configuration to run in: allow perl or allow binaries
 292 for my $switch ( [0,1], [1,0] ) {
 293     my $cfg = "PP: $switch->[0] Bin: $switch->[1]";
 294
 295     local $Archive::Extract::_ALLOW_PURE_PERL   = $switch->[0];
 296     local $Archive::Extract::_ALLOW_BIN         = $switch->[1];
 297
 298     diag("Running extract with configuration: $cfg") if $Debug;
 299
 300     for my $archive (keys %$tmpl) {
 301
 302         diag("Extracting $archive in config $cfg") if $Debug;
 303
 304         ### check first if we can do the proper
 305
 306         my $ae = Archive::Extract->new(
 307                         archive => File::Spec->catfile($SrcDir,$archive) );
 308
 309         isa_ok( $ae, $Class );
 310
 311         my $method = $tmpl->{$archive}->{method};
 312         ok( $ae->$method(),         "Archive type recognized properly" );
 313
 314     ### 10 tests from here on down ###
 315     SKIP: {
 316         my $file        = $tmpl->{$archive}->{outfile};
 317         my $dir         = $tmpl->{$archive}->{outdir};  # can be undef
 318         my $rel_path    = File::Spec->catfile( grep { defined } $dir, $file );
 319         my $abs_path    = File::Spec->catfile( $OutDir, $rel_path );
 320         my $abs_dir     = File::Spec->catdir(
 321                             grep { defined } $OutDir, $dir );
 322         my $nix_path    = File::Spec::Unix->catfile(
 323                             grep { defined } $dir, $file );
 324
 325         ### check if we can run this test ###
 326         my $pgm_fail; my $mod_fail;
 327         for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
 328             ### no binary extract method
 329             $pgm_fail++, next unless $pgm;
 330
 331             ### we dont have the program
 332             $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
 333                                $Archive::Extract::PROGRAMS->{$pgm};
 334
 335         }
 336
 337         for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
 338             ### no module extract method
 339             $mod_fail++, next unless $mod;
 340
 341             ### we dont have the module
 342             $mod_fail++ unless check_install( module => $mod );
 343         }
 344
 345         ### where to extract to -- try both dir and file for gz files
 346         ### XXX test me!
 347         #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
 348         my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma
 349                         ? ($abs_path)
 350                         : ($OutDir);
 351
 352         skip "No binaries or modules to extract ".$archive,
 353             (10 * scalar @outs) if $mod_fail && $pgm_fail;
 354
 355         ### we dont warnings spewed about missing modules, that might
 356         ### be a problem...
 357         local $IPC::Cmd::WARN = 0;
 358         local $IPC::Cmd::WARN = 0;
 359
 360         for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
 361
 362             ### test buffers ###
 363             my $turn_off = !$use_buffer && !$pgm_fail &&
 364                             $Archive::Extract::_ALLOW_BIN;
 365
 366             ### whitebox test ###
 367             ### stupid warnings ###
 368             local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
 369             local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
 370             local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
 371             local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
 372
 373
 374             ### try extracting ###
 375             for my $to ( @outs ) {
 376
 377                 diag("Extracting to: $to")                  if $Debug;
 378                 diag("Buffers enabled: ".!$turn_off)        if $Debug;
 379
 380                 my $rv = $ae->extract( to => $to );
 381
 382                 SKIP: {
 383                     my $re  = qr/^No buffer captured/;
 384                     my $err = $ae->error || '';
 385
 386                     ### skip buffer tests if we dont have buffers or
 387                     ### explicitly turned them off
 388                     skip "No buffers available", 8
 389                         if ( $turn_off || !IPC::Cmd->can_capture_buffer)
 390                             && $err =~ $re;
 391
 392                     ### skip tests if we dont have an extractor
 393                     skip "No extractor available", 8
 394                         if $err =~ /Extract failed; no extractors available/;
 395
 396                     ok( $rv, "extract() for '$archive' reports success ($cfg)");
 397
 398                     diag("Extractor was: " . $ae->_extractor)   if $Debug;
 399
 400                     ### if we /should/ have buffers, there should be
 401                     ### no errors complaining we dont have them...
 402                     unlike( $err, $re,
 403                                     "No errors capturing buffers" );
 404
 405                     ### might be 1 or 2, depending wether we extracted
 406                     ### a dir too
 407                     my $files    = $ae->files || [];
 408                     my $file_cnt = grep { defined } $file, $dir;
 409                     is( scalar @$files, $file_cnt,
 410                                     "Found correct number of output files" );
 411
 412                     ### due to prototypes on is(), if there's no -1 index on
 413                     ### the array ref, it'll give a fatal exception:
 414                     ### "Modification of non-creatable array value attempted,
 415                     ### subscript -1 at -e line 1." So wrap it in do { }
 416                     is( do { $files->[-1] }, $nix_path,
 417                                     "Found correct output file '$nix_path'" );
 418
 419                     ok( -e $abs_path,
 420                                     "Output file '$abs_path' exists" );
 421                     ok( $ae->extract_path,
 422                                     "Extract dir found" );
 423                     ok( -d $ae->extract_path,
 424                                     "Extract dir exists" );
 425                     is( $ae->extract_path, $abs_dir,
 426                                     "Extract dir is expected '$abs_dir'" );
 427                 }
 428
 429                 SKIP: {
 430                     skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
 431
 432                     1 while unlink $abs_path;
 433                     ok( !(-e $abs_path), "Output file successfully removed" );
 434
 435                     SKIP: {
 436                         skip "No extract path captured, can't remove paths", 2
 437                             unless $ae->extract_path;
 438
 439                         ### if something went wrong with determining the out
 440                         ### path, don't go deleting stuff.. might be Really Bad
 441                         my $out_re = quotemeta( $OutDir );
 442
 443                         ### VMS directory layout is different. Craig Berry
 444                         ### explains:
 445                         ### the test is trying to determine if C</disk1/foo/bar>
 446                         ### is part of C</disk1/foo/bar/baz>.  Except in VMS
 447                         ### syntax, that would mean trying to determine whether
 448                         ### C<disk1:[foo.bar]> is part of C<disk1:[foo.bar.baz]>
 449                         ### Because we have both a directory delimiter
 450                         ### (dot) and a directory spec terminator (right
 451                         ### bracket), we have to trim the right bracket from
 452                         ### the first one to make it successfully match the
 453                         ### second one.  Since we're asserting the same truth --
 454                         ### that one path spec is the leading part of the other
 455                         ### -- it seems to me ok to have this in the test only.
 456                         ###
 457                         ### so we strip the ']' of the back of the regex
 458                         $out_re =~ s/\\\]// if IS_VMS;
 459
 460                         if( $ae->extract_path !~ /^$out_re/ ) {
 461                             ok( 0, "Extractpath WRONG (".$ae->extract_path.")");
 462                             skip(  "Unsafe operation -- skip cleanup!!!" ), 1;
 463                         }
 464
 465                         eval { rmtree( $ae->extract_path ) };
 466                         ok( !$@,        "   rmtree gave no error" );
 467                         ok( !(-d $ae->extract_path ),
 468                                         "   Extract dir succesfully removed" );
 469                     }
 470                 }
 471             }
 472         }
 473     } }
 474 }