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
CommitLineData
520c99e2
JB
1BEGIN {
2 if( $ENV{PERL_CORE} ) {
3 chdir '../lib/Archive/Extract' if -d '../lib/Archive/Extract';
4 unshift @INC, '../../..', '../../../..';
5 }
6}
7
8BEGIN { chdir 't' if -d 't' };
9BEGIN { mkdir 'out' unless -d 'out' };
10
11use strict;
12use lib qw[../lib];
13
14use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
15use constant IS_CYGWIN => $^O eq 'cygwin' ? 1 : 0;
16
17use Cwd qw[cwd];
18use Test::More qw[no_plan];
19use File::Spec;
20use File::Spec::Unix;
21use File::Path;
22use Data::Dumper;
23use File::Basename qw[basename];
24use 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
03998fa0 36if ((IS_WIN32 or IS_CYGWIN) && ! $ENV{PERL_CORE}) {
520c99e2
JB
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
41my $Debug = $ARGV[0] ? 1 : 0;
42my $Me = basename( $0 );
43my $Class = 'Archive::Extract';
44my $Self = File::Spec->rel2abs(
45 IS_WIN32 ? &Win32::GetShortPathName( cwd() ) : cwd()
46 );
47my $SrcDir = File::Spec->catdir( $Self,'src' );
48my $OutDir = File::Spec->catdir( $Self,'out' );
49
50use_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
57my $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
161if( $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
217for 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}