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' }; |
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; |
e87b63e2 |
16 | use constant IS_VMS => $^O eq 'VMS' ? 1 : 0; |
520c99e2 |
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 | |
03998fa0 |
37 | if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) { |
520c99e2 |
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 | }, |
1dae2fb5 |
80 | 'x.gz' => { programs => [qw[gzip]], |
520c99e2 |
81 | modules => [qw[Compress::Zlib]], |
82 | method => 'is_gz', |
83 | outfile => 'a', |
84 | }, |
1dae2fb5 |
85 | 'x.Z' => { programs => [qw[uncompress]], |
86 | modules => [qw[Compress::Zlib]], |
87 | method => 'is_Z', |
88 | outfile => 'a', |
89 | }, |
520c99e2 |
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 |
e87b63e2 |
194 | SKIP: { my $meth = '__get_extract_dir'; |
520c99e2 |
195 | |
e87b63e2 |
196 | ### get the right separator -- File::Spec does clean ups for |
520c99e2 |
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 ( '', '.' ) { |
e87b63e2 |
205 | skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2 |
206 | if IS_VMS && length($prefix); |
207 | |
520c99e2 |
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); |
1dae2fb5 |
280 | my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z |
281 | ? ($abs_path) |
282 | : ($OutDir); |
520c99e2 |
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; |
1dae2fb5 |
312 | |
520c99e2 |
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 | |
1dae2fb5 |
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 | |
520c99e2 |
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 | } |