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