2 if( $ENV{PERL_CORE} ) {
3 chdir '../lib/Archive/Extract' if -d '../lib/Archive/Extract';
4 unshift @INC, '../../..', '../../../..';
8 BEGIN { chdir 't' if -d 't' };
9 BEGIN { mkdir 'out' unless -d 'out' };
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;
19 use Test::More qw[no_plan];
24 use File::Basename qw[basename];
25 use Module::Load::Conditional qw[check_install];
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(@_) } };
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" );
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()
48 my $SrcDir = File::Spec->catdir( $Self,'src' );
49 my $OutDir = File::Spec->catdir( $Self,'out' );
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;
60 'x.bz2' => { programs => [qw[bunzip2]],
61 modules => [qw[IO::Uncompress::Bunzip2]],
65 'x.tgz' => { programs => [qw[gzip tar]],
66 modules => [qw[Archive::Tar IO::Zlib]],
70 'x.tar.gz' => { programs => [qw[gzip tar]],
71 modules => [qw[Archive::Tar IO::Zlib]],
75 'x.tar' => { programs => [qw[tar]],
76 modules => [qw[Archive::Tar]],
80 'x.gz' => { programs => [qw[gzip]],
81 modules => [qw[Compress::Zlib]],
85 'x.Z' => { programs => [qw[uncompress]],
86 modules => [qw[Compress::Zlib]],
90 'x.zip' => { programs => [qw[unzip]],
91 modules => [qw[Archive::Zip]],
95 'x.jar' => { programs => [qw[unzip]],
96 modules => [qw[Archive::Zip]],
100 'x.par' => { programs => [qw[unzip]],
101 modules => [qw[Archive::Zip]],
106 'y.tbz' => { programs => [qw[bunzip2 tar]],
107 modules => [qw[Archive::Tar
108 IO::Uncompress::Bunzip2]],
113 'y.tar.bz2' => { programs => [qw[bunzip2 tar]],
114 modules => [qw[Archive::Tar
115 IO::Uncompress::Bunzip2]],
120 'y.tgz' => { programs => [qw[gzip tar]],
121 modules => [qw[Archive::Tar IO::Zlib]],
126 'y.tar.gz' => { programs => [qw[gzip tar]],
127 modules => [qw[Archive::Tar IO::Zlib]],
132 'y.tar' => { programs => [qw[tar]],
133 modules => [qw[Archive::Tar]],
138 'y.zip' => { programs => [qw[unzip]],
139 modules => [qw[Archive::Zip]],
144 'y.par' => { programs => [qw[unzip]],
145 modules => [qw[Archive::Zip]],
150 'y.jar' => { programs => [qw[unzip]],
151 modules => [qw[Archive::Zip]],
156 ### with non-same top dir
157 'double_dir.zip' => {
158 programs => [qw[unzip]],
159 modules => [qw[Archive::Zip]],
166 ### show us the tools IPC::Cmd will use to run binary programs
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" );
176 ### test all type specifications to new()
177 ### this tests bug #24578: Wrong check for `type' argument
178 { my $meth = 'types';
180 can_ok( $Class, $meth );
182 my @types = $Class->$meth;
183 ok( scalar(@types), " Got a list of types" );
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" );
192 ### XXX whitebox test
193 ### test __get_extract_dir
194 SKIP: { my $meth = '__get_extract_dir';
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];
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
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);
208 my $dir = basename( $SrcDir );
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, $_
216 } $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
218 my $res = $Class->$meth( \@files );
219 $res = &Win32::GetShortPathName( $res ) if IS_WIN32;
221 ok( $res, "Found extraction dir '$res'" );
222 is( $res, $SrcDir, " Is expected dir '$SrcDir'" );
226 for my $switch (0,1) {
228 local $Archive::Extract::PREFER_BIN = $switch;
229 diag("Running extract with PREFER_BIN = $Archive::Extract::PREFER_BIN")
232 for my $archive (keys %$tmpl) {
234 diag("Extracting $archive") if $Debug;
236 ### check first if we can do the proper
238 my $ae = Archive::Extract->new(
239 archive => File::Spec->catfile($SrcDir,$archive) );
241 isa_ok( $ae, $Class );
243 my $method = $tmpl->{$archive}->{method};
244 ok( $ae->$method(), "Archive type recognized properly" );
246 ### 10 tests from here on down ###
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 );
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;
263 ### we dont have the program
264 $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
265 $Archive::Extract::PROGRAMS->{$pgm};
269 for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
270 ### no module extract method
271 $mod_fail++, next unless $mod;
273 ### we dont have the module
274 $mod_fail++ unless check_install( module => $mod );
277 ### where to extract to -- try both dir and file for gz files
279 #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
280 my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z
284 skip "No binaries or modules to extract ".$archive,
285 (10 * scalar @outs) if $mod_fail && $pgm_fail;
288 ### we dont warnings spewed about missing modules, that might
290 local $IPC::Cmd::WARN = 0;
291 local $IPC::Cmd::WARN = 0;
293 for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
296 my $turn_off = !$use_buffer && !$pgm_fail &&
297 $Archive::Extract::PREFER_BIN;
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;
307 ### try extracting ###
308 for my $to ( @outs ) {
310 diag("Extracting to: $to") if $Debug;
311 diag("Buffers enabled: ".!$turn_off) if $Debug;
313 my $rv = $ae->extract( to => $to );
315 ok( $rv, "extract() for '$archive' reports success");
317 diag("Extractor was: " . $ae->_extractor) if $Debug;
320 my $re = qr/^No buffer captured/;
321 my $err = $ae->error || '';
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)
329 ### if we /should/ have buffers, there should be
330 ### no errors complaining we dont have them...
332 "No errors capturing buffers" );
334 ### might be 1 or 2, depending wether we extracted
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'" );
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'" );
353 skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
355 1 while unlink $abs_path;
356 ok( !(-e $abs_path), "Output file successfully removed" );
359 skip "No extract path captured, can't remove paths", 2
360 unless $ae->extract_path;
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;
370 eval { rmtree( $ae->extract_path ) };
371 ok( !$@, " rmtree gave no error" );
372 ok( !(-d $ae->extract_path ),
373 " Extract dir succesfully removed" );