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