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