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 use strict;
  12 use lib qw[../lib];
  13
  14 use constant IS_WIN32   => $^O eq 'MSWin32' ? 1 : 0;
  15 use constant IS_CYGWIN  => $^O eq 'cygwin'  ? 1 : 0;
  16 use constant IS_VMS     => $^O eq 'VMS'     ? 1 : 0;
  17
  18 use Cwd                         qw[cwd];
  19 use Test::More                  qw[no_plan];
  20 use File::Spec;
  21 use File::Spec::Unix;
  22 use File::Path;
  23 use Data::Dumper;
  24 use File::Basename              qw[basename];
  25 use Module::Load::Conditional   qw[check_install];
  26
  27 ### uninitialized value in File::Spec warnings come from A::Zip:
  28 # 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.
  29 #         File::Spec::Unix::catpath('File::Spec','','','undef') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 473
  30 #         Archive::Zip::_asLocalName('') called at /opt/lib/perl5/site_perl/5.8.3/Archive/Zip.pm line 652
  31 #         Archive::Zip::Archive::extractMember('Archive::Zip::Archive=HASH(0x9679c8)','Archive::Zip::ZipFileMember=HASH(0x9678fc)') called at ../lib/Archive/Extract.pm line 753
  32 #         Archive::Extract::_unzip_az('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 674
  33 #         Archive::Extract::_unzip('Archive::Extract=HASH(0x966eac)') called at ../lib/Archive/Extract.pm line 275
  34 #         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
  35 #BEGIN { $SIG{__WARN__} = sub { require Carp; Carp::cluck(@_) } };
  36
  37 if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
  38     diag( "Older versions of Archive::Zip may cause File::Spec warnings" );
  39     diag( "See bug #19713 in rt.cpan.org. It is safe to ignore them" );
  40 }
  41
  42 my $Debug   = $ARGV[0] ? 1 : 0;
  43 my $Me      = basename( $0 );
  44 my $Class   = 'Archive::Extract';
  45 my $Self    = File::Spec->rel2abs(
  46                     IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd()
  47                 );
  48 my $SrcDir  = File::Spec->catdir( $Self,'src' );
  49 my $OutDir  = File::Spec->catdir( $Self,'out' );
  50
  51 use_ok($Class);
  52
  53 ### set verbose if debug is on ###
  54 ### stupid stupid silly stupid warnings silly! ###
  55 $Archive::Extract::VERBOSE  = $Archive::Extract::VERBOSE = $Debug;
  56 $Archive::Extract::WARN     = $Archive::Extract::WARN    = $Debug ? 1 : 0;
  57
  58 my $tmpl = {
  59     ### plain files
  60     'x.bz2' => {    programs    => [qw[bunzip2]],
  61                     modules     => [qw[IO::Uncompress::Bunzip2]],
  62                     method      => 'is_bz2',
  63                     outfile     => 'a',
  64                 },
  65     'x.tgz' => {    programs    => [qw[gzip tar]],
  66                     modules     => [qw[Archive::Tar IO::Zlib]],
  67                     method      => 'is_tgz',
  68                     outfile     => 'a',
  69                 },
  70     'x.tar.gz' => { programs    => [qw[gzip tar]],
  71                     modules     => [qw[Archive::Tar IO::Zlib]],
  72                     method      => 'is_tgz',
  73                     outfile     => 'a',
  74                 },
  75     'x.tar' => {    programs    => [qw[tar]],
  76                     modules     => [qw[Archive::Tar]],
  77                     method      => 'is_tar',
  78                     outfile     => 'a',
  79                 },
  80     'x.gz'  => {    programs    => [qw[gzip]],
  81                     modules     => [qw[Compress::Zlib]],
  82                     method      => 'is_gz',
  83                     outfile     => 'a',
  84                 },
  85     'x.Z'   => {    programs    => [qw[uncompress]],
  86                     modules     => [qw[Compress::Zlib]],
  87                     method      => 'is_Z',
  88                     outfile     => 'a',
  89                 },
  90     'x.zip' => {    programs    => [qw[unzip]],
  91                     modules     => [qw[Archive::Zip]],
  92                     method      => 'is_zip',
  93                     outfile     => 'a',
  94                 },
  95     'x.jar' => {    programs    => [qw[unzip]],
  96                     modules     => [qw[Archive::Zip]],
  97                     method      => 'is_zip',
  98                     outfile     => 'a',
  99                 },
 100     'x.par' => {    programs    => [qw[unzip]],
 101                     modules     => [qw[Archive::Zip]],
 102                     method      => 'is_zip',
 103                     outfile     => 'a',
 104                 },
 105     ### with a directory
 106     'y.tbz'     => {    programs    => [qw[bunzip2 tar]],
 107                         modules     => [qw[Archive::Tar
 108                                            IO::Uncompress::Bunzip2]],
 109                         method      => 'is_tbz',
 110                         outfile     => 'z',
 111                         outdir      => 'y',
 112                     },
 113     'y.tar.bz2' => {    programs    => [qw[bunzip2 tar]],
 114                         modules     => [qw[Archive::Tar
 115                                            IO::Uncompress::Bunzip2]],
 116                         method      => 'is_tbz',
 117                         outfile     => 'z',
 118                         outdir      => 'y'
 119                     },
 120     'y.tgz'     => {    programs    => [qw[gzip tar]],
 121                         modules     => [qw[Archive::Tar IO::Zlib]],
 122                         method      => 'is_tgz',
 123                         outfile     => 'z',
 124                         outdir      => 'y'
 125                     },
 126     'y.tar.gz' => {     programs    => [qw[gzip tar]],
 127                         modules     => [qw[Archive::Tar IO::Zlib]],
 128                         method      => 'is_tgz',
 129                         outfile     => 'z',
 130                         outdir      => 'y'
 131                     },
 132     'y.tar' => {    programs    => [qw[tar]],
 133                     modules     => [qw[Archive::Tar]],
 134                     method      => 'is_tar',
 135                     outfile     => 'z',
 136                     outdir      => 'y'
 137                 },
 138     'y.zip' => {    programs    => [qw[unzip]],
 139                     modules     => [qw[Archive::Zip]],
 140                     method      => 'is_zip',
 141                     outfile     => 'z',
 142                     outdir      => 'y'
 143                 },
 144     'y.par' => {    programs    => [qw[unzip]],
 145                     modules     => [qw[Archive::Zip]],
 146                     method      => 'is_zip',
 147                     outfile     => 'z',
 148                     outdir      => 'y'
 149                 },
 150     'y.jar' => {    programs    => [qw[unzip]],
 151                     modules     => [qw[Archive::Zip]],
 152                     method      => 'is_zip',
 153                     outfile     => 'z',
 154                     outdir      => 'y'
 155                 },
 156     ### with non-same top dir
 157     'double_dir.zip' => {
 158                     programs    => [qw[unzip]],
 159                     modules     => [qw[Archive::Zip]],
 160                     method      => 'is_zip',
 161                     outfile     => 'w',
 162                     outdir      => 'x'
 163                 },
 164 };
 165
 166 ### show us the tools IPC::Cmd will use to run binary programs
 167 if( $Debug ) {
 168     diag( "IPC::Run enabled: $IPC::Cmd::USE_IPC_RUN " );
 169     diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run );
 170     diag( "IPC::Run vesion: $IPC::Run::VERSION" );
 171     diag( "IPC::Open3 enabled: $IPC::Cmd::USE_IPC_OPEN3 " );
 172     diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 );
 173     diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" );
 174 }
 175
 176 ### test all type specifications to new()
 177 ### this tests bug #24578: Wrong check for `type' argument
 178 {   my $meth = 'types';
 179
 180     can_ok( $Class, $meth );
 181
 182     my @types = $Class->$meth;
 183     ok( scalar(@types),         "   Got a list of types" );
 184
 185     for my $type ( @types ) {
 186         my $obj = $Class->new( archive => $Me, type => $type );
 187         ok( $obj,               "   Object created based on '$type'" );
 188         ok( !$obj->error,       "       No error logged" );
 189     }
 190 }
 191
 192 ### XXX whitebox test
 193 ### test __get_extract_dir
 194 SKIP: {   my $meth = '__get_extract_dir';
 195
 196     ### get the right separator -- File::Spec does clean ups for
 197     ### paths, so we need to join ourselves.
 198     my $sep  = [ split '', File::Spec->catfile( 'a', 'b' ) ]->[1];
 199
 200     ### bug #23999: Attempt to generate Makefile.PL gone awry
 201     ### showed that dirs in the style of './dir/' were reported
 202     ### to be unpacked in '.' rather than in 'dir'. here we test
 203     ### for this.
 204     for my $prefix ( '', '.' ) {
 205         skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2
 206             if IS_VMS && length($prefix);
 207
 208         my $dir = basename( $SrcDir );
 209
 210         ### build a list like [dir, dir/file] and [./dir ./dir/file]
 211         ### where the dir and file actually exist, which is important
 212         ### for the method call
 213         my @files = map { length $prefix
 214                                 ? join $sep, $prefix, $_
 215                                 : $_
 216                       } $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
 217
 218         my $res = $Class->$meth( \@files );
 219         $res = &Win32::GetShortPathName( $res ) if IS_WIN32;
 220
 221         ok( $res,               "Found extraction dir '$res'" );
 222         is( $res, $SrcDir,      "   Is expected dir '$SrcDir'" );
 223     }
 224 }
 225
 226 for my $switch (0,1) {
 227
 228     local $Archive::Extract::PREFER_BIN = $switch;
 229     diag("Running extract with PREFER_BIN = $Archive::Extract::PREFER_BIN")
 230         if $Debug;
 231
 232     for my $archive (keys %$tmpl) {
 233
 234         diag("Extracting $archive") if $Debug;
 235
 236         ### check first if we can do the proper
 237
 238         my $ae = Archive::Extract->new(
 239                         archive => File::Spec->catfile($SrcDir,$archive) );
 240
 241         isa_ok( $ae, $Class );
 242
 243         my $method = $tmpl->{$archive}->{method};
 244         ok( $ae->$method(),         "Archive type recognized properly" );
 245
 246     ### 10 tests from here on down ###
 247     SKIP: {
 248         my $file        = $tmpl->{$archive}->{outfile};
 249         my $dir         = $tmpl->{$archive}->{outdir};  # can be undef
 250         my $rel_path    = File::Spec->catfile( grep { defined } $dir, $file );
 251         my $abs_path    = File::Spec->catfile( $OutDir, $rel_path );
 252         my $abs_dir     = File::Spec->catdir(
 253                             grep { defined } $OutDir, $dir );
 254         my $nix_path    = File::Spec::Unix->catfile(
 255                             grep { defined } $dir, $file );
 256
 257         ### check if we can run this test ###
 258         my $pgm_fail; my $mod_fail;
 259         for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
 260             ### no binary extract method
 261             $pgm_fail++, next unless $pgm;
 262
 263             ### we dont have the program
 264             $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
 265                                $Archive::Extract::PROGRAMS->{$pgm};
 266
 267         }
 268
 269         for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
 270             ### no module extract method
 271             $mod_fail++, next unless $mod;
 272
 273             ### we dont have the module
 274             $mod_fail++ unless check_install( module => $mod );
 275         }
 276
 277         ### where to extract to -- try both dir and file for gz files
 278         ### XXX test me!
 279         #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
 280         my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z
 281                         ? ($abs_path)
 282                         : ($OutDir);
 283
 284         skip "No binaries or modules to extract ".$archive,
 285             (10 * scalar @outs) if $mod_fail && $pgm_fail;
 286
 287
 288         ### we dont warnings spewed about missing modules, that might
 289         ### be a problem...
 290         local $IPC::Cmd::WARN = 0;
 291         local $IPC::Cmd::WARN = 0;
 292
 293         for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
 294
 295             ### test buffers ###
 296             my $turn_off = !$use_buffer && !$pgm_fail &&
 297                             $Archive::Extract::PREFER_BIN;
 298
 299             ### whitebox test ###
 300             ### stupid warnings ###
 301             local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
 302             local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
 303             local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
 304             local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
 305
 306
 307             ### try extracting ###
 308             for my $to ( @outs ) {
 309
 310                 diag("Extracting to: $to")                  if $Debug;
 311                 diag("Buffers enabled: ".!$turn_off)        if $Debug;
 312
 313                 my $rv = $ae->extract( to => $to );
 314
 315                 ok( $rv, "extract() for '$archive' reports success");
 316
 317                 diag("Extractor was: " . $ae->_extractor)   if $Debug;
 318
 319                 SKIP: {
 320                     my $re  = qr/^No buffer captured/;
 321                     my $err = $ae->error || '';
 322
 323                     ### skip buffer tests if we dont have buffers or
 324                     ### explicitly turned them off
 325                     skip "No buffers available", 7,
 326                         if ( $turn_off || !IPC::Cmd->can_capture_buffer)
 327                             && $err =~ $re;
 328
 329                     ### if we /should/ have buffers, there should be
 330                     ### no errors complaining we dont have them...
 331                     unlike( $err, $re,
 332                                     "No errors capturing buffers" );
 333
 334                     ### might be 1 or 2, depending wether we extracted
 335                     ### a dir too
 336                     my $file_cnt = grep { defined } $file, $dir;
 337                     is( scalar @{ $ae->files || []}, $file_cnt,
 338                                     "Found correct number of output files" );
 339                     is( $ae->files->[-1], $nix_path,
 340                                     "Found correct output file '$nix_path'" );
 341
 342                     ok( -e $abs_path,
 343                                     "Output file '$abs_path' exists" );
 344                     ok( $ae->extract_path,
 345                                     "Extract dir found" );
 346                     ok( -d $ae->extract_path,
 347                                     "Extract dir exists" );
 348                     is( $ae->extract_path, $abs_dir,
 349                                     "Extract dir is expected '$abs_dir'" );
 350                 }
 351
 352                 SKIP: {
 353                     skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
 354
 355                     1 while unlink $abs_path;
 356                     ok( !(-e $abs_path), "Output file successfully removed" );
 357
 358                     SKIP: {
 359                         skip "No extract path captured, can't remove paths", 2
 360                             unless $ae->extract_path;
 361
 362                         ### if something went wrong with determining the out
 363                         ### path, don't go deleting stuff.. might be Really Bad
 364                         my $out_re = quotemeta( $OutDir );
 365                         if( $ae->extract_path !~ /^$out_re/ ) {
 366                             ok( 0, "Extractpath WRONG (".$ae->extract_path.")");
 367                             skip(  "Unsafe operation -- skip cleanup!!!" ), 1;
 368                         }
 369
 370                         eval { rmtree( $ae->extract_path ) };
 371                         ok( !$@,        "   rmtree gave no error" );
 372                         ok( !(-d $ae->extract_path ),
 373                                         "   Extract dir succesfully removed" );
 374                     }
 375                 }
 376             }
 377         }
 378     } }
 379 }