Commit | Line | Data |
---|---|---|
520c99e2 | 1 | package Archive::Extract; |
1e6a1397 | 2 | use if $] > 5.017, 'deprecate'; |
520c99e2 JB |
3 | |
4 | use strict; | |
5 | ||
f62b3c7e | 6 | use Cwd qw[cwd chdir]; |
520c99e2 JB |
7 | use Carp qw[carp]; |
8 | use IPC::Cmd qw[run can_run]; | |
9 | use FileHandle; | |
10 | use File::Path qw[mkpath]; | |
11 | use File::Spec; | |
12 | use File::Basename qw[dirname basename]; | |
13 | use Params::Check qw[check]; | |
14 | use Module::Load::Conditional qw[can_load check_install]; | |
15 | use Locale::Maketext::Simple Style => 'gettext'; | |
16 | ||
17 | ### solaris has silly /bin/tar output ### | |
18 | use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0; | |
9f1eb87f | 19 | use constant ON_NETBSD => $^O eq 'netbsd' ? 1 : 0; |
8134d388 | 20 | use constant ON_OPENBSD => $^O eq 'openbsd' ? 1 : 0; |
f37a9f48 | 21 | use constant ON_FREEBSD => $^O eq 'freebsd' ? 1 : 0; |
4bce464d | 22 | use constant ON_LINUX => $^O eq 'linux' ? 1 : 0; |
520c99e2 JB |
23 | use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; |
24 | ||
4f3b9739 JM |
25 | ### VMS may require quoting upper case command options |
26 | use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; | |
27 | ||
e74f3fd4 JB |
28 | ### Windows needs special treatment of Tar options |
29 | use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0; | |
30 | ||
83285295 JB |
31 | ### we can't use this extraction method, because of missing |
32 | ### modules/binaries: | |
f37a9f48 | 33 | use constant METHOD_NA => []; |
83285295 | 34 | |
520c99e2 JB |
35 | ### If these are changed, update @TYPES and the new() POD |
36 | use constant TGZ => 'tgz'; | |
37 | use constant TAR => 'tar'; | |
38 | use constant GZ => 'gz'; | |
39 | use constant ZIP => 'zip'; | |
40 | use constant BZ2 => 'bz2'; | |
41 | use constant TBZ => 'tbz'; | |
1dae2fb5 | 42 | use constant Z => 'Z'; |
8d2ac73b | 43 | use constant LZMA => 'lzma'; |
d7f87992 CBW |
44 | use constant XZ => 'xz'; |
45 | use constant TXZ => 'txz'; | |
520c99e2 | 46 | |
f37a9f48 | 47 | use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG |
198e857c | 48 | $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER |
83285295 JB |
49 | ]; |
50 | ||
1e6a1397 | 51 | $VERSION = '0.64'; |
83285295 JB |
52 | $PREFER_BIN = 0; |
53 | $WARN = 1; | |
54 | $DEBUG = 0; | |
55 | $_ALLOW_PURE_PERL = 1; # allow pure perl extractors | |
56 | $_ALLOW_BIN = 1; # allow binary extractors | |
198e857c | 57 | $_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available |
520c99e2 | 58 | |
83285295 | 59 | # same as all constants |
f37a9f48 | 60 | my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ ); |
520c99e2 JB |
61 | |
62 | local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; | |
63 | ||
64 | =pod | |
65 | ||
66 | =head1 NAME | |
67 | ||
68 | Archive::Extract - A generic archive extracting mechanism | |
69 | ||
70 | =head1 SYNOPSIS | |
71 | ||
72 | use Archive::Extract; | |
73 | ||
74 | ### build an Archive::Extract object ### | |
75 | my $ae = Archive::Extract->new( archive => 'foo.tgz' ); | |
76 | ||
77 | ### extract to cwd() ### | |
78 | my $ok = $ae->extract; | |
79 | ||
80 | ### extract to /tmp ### | |
81 | my $ok = $ae->extract( to => '/tmp' ); | |
82 | ||
83 | ### what if something went wrong? | |
84 | my $ok = $ae->extract or die $ae->error; | |
85 | ||
86 | ### files from the archive ### | |
87 | my $files = $ae->files; | |
88 | ||
89 | ### dir that was extracted to ### | |
90 | my $outdir = $ae->extract_path; | |
91 | ||
92 | ||
93 | ### quick check methods ### | |
94 | $ae->is_tar # is it a .tar file? | |
95 | $ae->is_tgz # is it a .tar.gz or .tgz file? | |
96 | $ae->is_gz; # is it a .gz file? | |
97 | $ae->is_zip; # is it a .zip file? | |
98 | $ae->is_bz2; # is it a .bz2 file? | |
99 | $ae->is_tbz; # is it a .tar.bz2 or .tbz file? | |
8d2ac73b | 100 | $ae->is_lzma; # is it a .lzma file? |
d7f87992 CBW |
101 | $ae->is_xz; # is it a .xz file? |
102 | $ae->is_txz; # is it a .tar.xz or .txz file? | |
520c99e2 JB |
103 | |
104 | ### absolute path to the archive you provided ### | |
105 | $ae->archive; | |
106 | ||
107 | ### commandline tools, if found ### | |
108 | $ae->bin_tar # path to /bin/tar, if found | |
109 | $ae->bin_gzip # path to /bin/gzip, if found | |
110 | $ae->bin_unzip # path to /bin/unzip, if found | |
111 | $ae->bin_bunzip2 # path to /bin/bunzip2 if found | |
8d2ac73b | 112 | $ae->bin_unlzma # path to /bin/unlzma if found |
d7f87992 | 113 | $ae->bin_unxz # path to /bin/unxz if found |
520c99e2 JB |
114 | |
115 | =head1 DESCRIPTION | |
116 | ||
117 | Archive::Extract is a generic archive extraction mechanism. | |
118 | ||
119 | It allows you to extract any archive file of the type .tar, .tar.gz, | |
f37a9f48 CBW |
120 | .gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma |
121 | without having to worry how it | |
122 | does so, or use different interfaces for each type by using either | |
1dae2fb5 | 123 | perl modules, or commandline tools on your system. |
520c99e2 JB |
124 | |
125 | See the C<HOW IT WORKS> section further down for details. | |
126 | ||
127 | =cut | |
128 | ||
129 | ||
130 | ### see what /bin/programs are available ### | |
131 | $PROGRAMS = {}; | |
4bce464d | 132 | CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) { |
f37a9f48 | 133 | if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) { |
9f1eb87f | 134 | local $IPC::Cmd::INSTANCES = 1; |
f37a9f48 | 135 | ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm); |
4bce464d CBW |
136 | next CMD; |
137 | } | |
138 | if ( $pgm eq 'unzip' and ON_LINUX ) { | |
139 | # Check if 'unzip' is busybox masquerading | |
140 | local $IPC::Cmd::INSTANCES = 1; | |
141 | my $opt = ON_VMS ? '"-Z"' : '-Z'; | |
142 | ($PROGRAMS->{$pgm}) = grep { scalar run(command=> [ $_, $opt, '-1' ]) } can_run($pgm); | |
143 | next CMD; | |
9f1eb87f | 144 | } |
8134d388 CBW |
145 | if ( $pgm eq 'tar' and ON_OPENBSD ) { |
146 | # try gtar first | |
147 | next CMD if $PROGRAMS->{$pgm} = can_run('gtar'); | |
148 | } | |
520c99e2 JB |
149 | $PROGRAMS->{$pgm} = can_run($pgm); |
150 | } | |
151 | ||
152 | ### mapping from types to extractor methods ### | |
83285295 JB |
153 | my $Mapping = { # binary program # pure perl module |
154 | is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, | |
155 | is_tar => { bin => '_untar_bin', pp => '_untar_at' }, | |
156 | is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, | |
157 | is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, | |
158 | is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, | |
159 | is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, | |
160 | is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, | |
161 | is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, | |
d7f87992 CBW |
162 | is_xz => { bin => '_unxz_bin', pp => '_unxz_cz' }, |
163 | is_txz => { bin => '_untar_bin', pp => '_untar_at' }, | |
520c99e2 JB |
164 | }; |
165 | ||
eadbb00b | 166 | { ### use subs so we re-generate array refs etc for the no-override flags |
83285295 JB |
167 | ### if we don't, then we reuse the same arrayref, meaning objects store |
168 | ### previous errors | |
520c99e2 | 169 | my $tmpl = { |
83285295 JB |
170 | archive => sub { { required => 1, allow => FILE_EXISTS } }, |
171 | type => sub { { default => '', allow => [ @Types ] } }, | |
172 | _error_msg => sub { { no_override => 1, default => [] } }, | |
173 | _error_msg_long => sub { { no_override => 1, default => [] } }, | |
520c99e2 JB |
174 | }; |
175 | ||
eadbb00b | 176 | ### build accessors ### |
f37a9f48 | 177 | for my $method( keys %$tmpl, |
520c99e2 | 178 | qw[_extractor _gunzip_to files extract_path], |
520c99e2 JB |
179 | ) { |
180 | no strict 'refs'; | |
181 | *$method = sub { | |
182 | my $self = shift; | |
183 | $self->{$method} = $_[0] if @_; | |
184 | return $self->{$method}; | |
185 | } | |
186 | } | |
187 | ||
188 | =head1 METHODS | |
189 | ||
190 | =head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) | |
191 | ||
192 | Creates a new C<Archive::Extract> object based on the archive file you | |
193 | passed it. Automatically determines the type of archive based on the | |
194 | extension, but you can override that by explicitly providing the | |
195 | C<type> argument. | |
196 | ||
197 | Valid values for C<type> are: | |
198 | ||
199 | =over 4 | |
200 | ||
201 | =item tar | |
202 | ||
203 | Standard tar files, as produced by, for example, C</bin/tar>. | |
204 | Corresponds to a C<.tar> suffix. | |
205 | ||
206 | =item tgz | |
207 | ||
208 | Gzip compressed tar files, as produced by, for example C</bin/tar -z>. | |
209 | Corresponds to a C<.tgz> or C<.tar.gz> suffix. | |
210 | ||
211 | =item gz | |
212 | ||
213 | Gzip compressed file, as produced by, for example C</bin/gzip>. | |
214 | Corresponds to a C<.gz> suffix. | |
215 | ||
1dae2fb5 RGS |
216 | =item Z |
217 | ||
218 | Lempel-Ziv compressed file, as produced by, for example C</bin/compress>. | |
219 | Corresponds to a C<.Z> suffix. | |
220 | ||
520c99e2 JB |
221 | =item zip |
222 | ||
223 | Zip compressed file, as produced by, for example C</bin/zip>. | |
224 | Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. | |
225 | ||
226 | =item bz2 | |
227 | ||
228 | Bzip2 compressed file, as produced by, for example, C</bin/bzip2>. | |
229 | Corresponds to a C<.bz2> suffix. | |
230 | ||
231 | =item tbz | |
232 | ||
9f1eb87f | 233 | Bzip2 compressed tar file, as produced by, for example C</bin/tar -j>. |
520c99e2 JB |
234 | Corresponds to a C<.tbz> or C<.tar.bz2> suffix. |
235 | ||
8d2ac73b SP |
236 | =item lzma |
237 | ||
238 | Lzma compressed file, as produced by C</bin/lzma>. | |
239 | Corresponds to a C<.lzma> suffix. | |
240 | ||
d7f87992 CBW |
241 | =item xz |
242 | ||
243 | Xz compressed file, as produced by C</bin/xz>. | |
244 | Corresponds to a C<.xz> suffix. | |
245 | ||
246 | =item txz | |
247 | ||
9f1eb87f | 248 | Xz compressed tar file, as produced by, for example C</bin/tar -J>. |
d7f87992 CBW |
249 | Corresponds to a C<.txz> or C<.tar.xz> suffix. |
250 | ||
520c99e2 JB |
251 | =back |
252 | ||
253 | Returns a C<Archive::Extract> object on success, or false on failure. | |
254 | ||
255 | =cut | |
256 | ||
257 | ### constructor ### | |
258 | sub new { | |
259 | my $class = shift; | |
260 | my %hash = @_; | |
f37a9f48 | 261 | |
83285295 JB |
262 | ### see above why we use subs here and generate the template; |
263 | ### it's basically to not re-use arrayrefs | |
264 | my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; | |
520c99e2 | 265 | |
83285295 | 266 | my $parsed = check( \%utmpl, \%hash ) or return; |
520c99e2 JB |
267 | |
268 | ### make sure we have an absolute path ### | |
269 | my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); | |
270 | ||
271 | ### figure out the type, if it wasn't already specified ### | |
272 | unless ( $parsed->{type} ) { | |
273 | $parsed->{type} = | |
aefcd4a2 CBW |
274 | $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ : |
275 | $ar =~ /.+?\.gz$/i ? GZ : | |
276 | $ar =~ /.+?\.tar$/i ? TAR : | |
277 | $ar =~ /.+?\.(zip|jar|ear|war|par)$/i ? ZIP : | |
278 | $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ : | |
279 | $ar =~ /.+?\.bz2$/i ? BZ2 : | |
280 | $ar =~ /.+?\.Z$/ ? Z : | |
281 | $ar =~ /.+?\.lzma$/ ? LZMA : | |
282 | $ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ : | |
283 | $ar =~ /.+?\.xz$/ ? XZ : | |
520c99e2 JB |
284 | ''; |
285 | ||
286 | } | |
287 | ||
83285295 | 288 | bless $parsed, $class; |
520c99e2 | 289 | |
f37a9f48 | 290 | ### don't know what type of file it is |
83285295 JB |
291 | ### XXX this *has* to be an object call, not a package call |
292 | return $parsed->_error(loc("Cannot determine file type for '%1'", | |
293 | $parsed->{archive} )) unless $parsed->{type}; | |
294 | return $parsed; | |
520c99e2 JB |
295 | } |
296 | } | |
297 | ||
298 | =head2 $ae->extract( [to => '/output/path'] ) | |
299 | ||
300 | Extracts the archive represented by the C<Archive::Extract> object to | |
301 | the path of your choice as specified by the C<to> argument. Defaults to | |
302 | C<cwd()>. | |
303 | ||
f37a9f48 CBW |
304 | Since C<.gz> files never hold a directory, but only a single file; if |
305 | the C<to> argument is an existing directory, the file is extracted | |
306 | there, with its C<.gz> suffix stripped. | |
307 | If the C<to> argument is not an existing directory, the C<to> argument | |
308 | is understood to be a filename, if the archive type is C<gz>. | |
520c99e2 | 309 | In the case that you did not specify a C<to> argument, the output |
83285295 | 310 | file will be the name of the archive file, stripped from its C<.gz> |
520c99e2 JB |
311 | suffix, in the current working directory. |
312 | ||
313 | C<extract> will try a pure perl solution first, and then fall back to | |
314 | commandline tools if they are available. See the C<GLOBAL VARIABLES> | |
315 | section below on how to alter this behaviour. | |
316 | ||
317 | It will return true on success, and false on failure. | |
318 | ||
319 | On success, it will also set the follow attributes in the object: | |
320 | ||
321 | =over 4 | |
322 | ||
323 | =item $ae->extract_path | |
324 | ||
325 | This is the directory that the files where extracted to. | |
326 | ||
327 | =item $ae->files | |
328 | ||
329 | This is an array ref with the paths of all the files in the archive, | |
330 | relative to the C<to> argument you specified. | |
331 | To get the full path to an extracted file, you would use: | |
332 | ||
333 | File::Spec->catfile( $to, $ae->files->[0] ); | |
334 | ||
335 | Note that all files from a tar archive will be in unix format, as per | |
336 | the tar specification. | |
337 | ||
338 | =back | |
339 | ||
340 | =cut | |
341 | ||
342 | sub extract { | |
343 | my $self = shift; | |
344 | my %hash = @_; | |
345 | ||
83285295 JB |
346 | ### reset error messages |
347 | $self->_error_msg( [] ); | |
348 | $self->_error_msg_long( [] ); | |
349 | ||
520c99e2 JB |
350 | my $to; |
351 | my $tmpl = { | |
352 | to => { default => '.', store => \$to } | |
353 | }; | |
354 | ||
355 | check( $tmpl, \%hash ) or return; | |
356 | ||
f37a9f48 | 357 | ### so 'to' could be a file or a dir, depending on whether it's a .gz |
520c99e2 JB |
358 | ### file, or basically anything else. |
359 | ### so, check that, then act accordingly. | |
360 | ### set an accessor specifically so _gunzip can know what file to extract | |
361 | ### to. | |
362 | my $dir; | |
363 | { ### a foo.gz file | |
d7f87992 | 364 | if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) { |
f37a9f48 | 365 | |
d7f87992 | 366 | my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i; |
f37a9f48 | 367 | |
520c99e2 JB |
368 | ### to is a dir? |
369 | if ( -d $to ) { | |
f37a9f48 | 370 | $dir = $to; |
520c99e2 JB |
371 | $self->_gunzip_to( basename($cp) ); |
372 | ||
373 | ### then it's a filename | |
374 | } else { | |
375 | $dir = dirname($to); | |
376 | $self->_gunzip_to( basename($to) ); | |
377 | } | |
378 | ||
379 | ### not a foo.gz file | |
380 | } else { | |
381 | $dir = $to; | |
382 | } | |
383 | } | |
384 | ||
385 | ### make the dir if it doesn't exist ### | |
386 | unless( -d $dir ) { | |
387 | eval { mkpath( $dir ) }; | |
388 | ||
389 | return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) | |
390 | if $@; | |
391 | } | |
392 | ||
393 | ### get the current dir, to restore later ### | |
394 | my $cwd = cwd(); | |
395 | ||
396 | my $ok = 1; | |
397 | EXTRACT: { | |
398 | ||
399 | ### chdir to the target dir ### | |
400 | unless( chdir $dir ) { | |
401 | $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); | |
402 | $ok = 0; last EXTRACT; | |
403 | } | |
404 | ||
405 | ### set files to an empty array ref, so there's always an array | |
406 | ### ref IN the accessor, to avoid errors like: | |
407 | ### Can't use an undefined value as an ARRAY reference at | |
408 | ### ../lib/Archive/Extract.pm line 742. (rt #19815) | |
409 | $self->files( [] ); | |
410 | ||
f37a9f48 | 411 | ### find out the dispatch methods needed for this type of |
83285295 JB |
412 | ### archive. Do a $self->is_XXX to figure out the type, then |
413 | ### get the hashref with bin + pure perl dispatchers. | |
414 | my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; | |
520c99e2 | 415 | |
83285295 JB |
416 | ### add pure perl extractor if allowed & add bin extractor if allowed |
417 | my @methods; | |
418 | push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; | |
419 | push @methods, $map->{'bin'} if $_ALLOW_BIN; | |
f37a9f48 | 420 | |
83285295 JB |
421 | ### reverse it if we prefer bin extractors |
422 | @methods = reverse @methods if $PREFER_BIN; | |
520c99e2 | 423 | |
83285295 JB |
424 | my($na, $fail); |
425 | for my $method (@methods) { | |
a6696b92 | 426 | $self->debug( "# Extracting with ->$method\n" ); |
f37a9f48 | 427 | |
83285295 | 428 | my $rv = $self->$method; |
f37a9f48 | 429 | |
83285295 JB |
430 | ### a positive extraction |
431 | if( $rv and $rv ne METHOD_NA ) { | |
a6696b92 | 432 | $self->debug( "# Extraction succeeded\n" ); |
83285295 JB |
433 | $self->_extractor($method); |
434 | last; | |
f37a9f48 | 435 | |
83285295 | 436 | ### method is not available |
f37a9f48 | 437 | } elsif ( $rv and $rv eq METHOD_NA ) { |
a6696b92 | 438 | $self->debug( "# Extraction method not available\n" ); |
f37a9f48 | 439 | $na++; |
83285295 | 440 | } else { |
a6696b92 | 441 | $self->debug( "# Extraction method failed\n" ); |
83285295 | 442 | $fail++; |
f37a9f48 | 443 | } |
83285295 | 444 | } |
520c99e2 | 445 | |
83285295 JB |
446 | ### warn something went wrong if we didn't get an extractor |
447 | unless( $self->_extractor ) { | |
448 | my $diag = $fail ? loc("Extract failed due to errors") : | |
449 | $na ? loc("Extract failed; no extractors available") : | |
450 | ''; | |
f37a9f48 | 451 | |
83285295 JB |
452 | $self->_error($diag); |
453 | $ok = 0; | |
f37a9f48 | 454 | } |
520c99e2 JB |
455 | } |
456 | ||
457 | ### and chdir back ### | |
458 | unless( chdir $cwd ) { | |
459 | $self->_error(loc("Could not chdir back to start dir '%1': %2'", | |
460 | $cwd, $!)); | |
461 | } | |
462 | ||
463 | return $ok; | |
464 | } | |
465 | ||
466 | =pod | |
467 | ||
468 | =head1 ACCESSORS | |
469 | ||
470 | =head2 $ae->error([BOOL]) | |
471 | ||
472 | Returns the last encountered error as string. | |
473 | Pass it a true value to get the C<Carp::longmess()> output instead. | |
474 | ||
475 | =head2 $ae->extract_path | |
476 | ||
477 | This is the directory the archive got extracted to. | |
478 | See C<extract()> for details. | |
479 | ||
480 | =head2 $ae->files | |
481 | ||
482 | This is an array ref holding all the paths from the archive. | |
483 | See C<extract()> for details. | |
484 | ||
485 | =head2 $ae->archive | |
486 | ||
487 | This is the full path to the archive file represented by this | |
488 | C<Archive::Extract> object. | |
489 | ||
490 | =head2 $ae->type | |
491 | ||
492 | This is the type of archive represented by this C<Archive::Extract> | |
493 | object. See accessors below for an easier way to use this. | |
494 | See the C<new()> method for details. | |
495 | ||
496 | =head2 $ae->types | |
497 | ||
498 | Returns a list of all known C<types> for C<Archive::Extract>'s | |
499 | C<new> method. | |
500 | ||
501 | =cut | |
502 | ||
503 | sub types { return @Types } | |
504 | ||
505 | =head2 $ae->is_tgz | |
506 | ||
507 | Returns true if the file is of type C<.tar.gz>. | |
508 | See the C<new()> method for details. | |
509 | ||
510 | =head2 $ae->is_tar | |
511 | ||
512 | Returns true if the file is of type C<.tar>. | |
513 | See the C<new()> method for details. | |
514 | ||
515 | =head2 $ae->is_gz | |
516 | ||
517 | Returns true if the file is of type C<.gz>. | |
518 | See the C<new()> method for details. | |
519 | ||
1dae2fb5 RGS |
520 | =head2 $ae->is_Z |
521 | ||
522 | Returns true if the file is of type C<.Z>. | |
523 | See the C<new()> method for details. | |
524 | ||
520c99e2 JB |
525 | =head2 $ae->is_zip |
526 | ||
527 | Returns true if the file is of type C<.zip>. | |
528 | See the C<new()> method for details. | |
529 | ||
8d2ac73b SP |
530 | =head2 $ae->is_lzma |
531 | ||
532 | Returns true if the file is of type C<.lzma>. | |
533 | See the C<new()> method for details. | |
534 | ||
d7f87992 CBW |
535 | =head2 $ae->is_xz |
536 | ||
537 | Returns true if the file is of type C<.xz>. | |
538 | See the C<new()> method for details. | |
539 | ||
520c99e2 JB |
540 | =cut |
541 | ||
542 | ### quick check methods ### | |
543 | sub is_tgz { return $_[0]->type eq TGZ } | |
544 | sub is_tar { return $_[0]->type eq TAR } | |
545 | sub is_gz { return $_[0]->type eq GZ } | |
546 | sub is_zip { return $_[0]->type eq ZIP } | |
547 | sub is_tbz { return $_[0]->type eq TBZ } | |
548 | sub is_bz2 { return $_[0]->type eq BZ2 } | |
1dae2fb5 | 549 | sub is_Z { return $_[0]->type eq Z } |
8d2ac73b | 550 | sub is_lzma { return $_[0]->type eq LZMA } |
d7f87992 CBW |
551 | sub is_xz { return $_[0]->type eq XZ } |
552 | sub is_txz { return $_[0]->type eq TXZ } | |
520c99e2 JB |
553 | |
554 | =pod | |
555 | ||
556 | =head2 $ae->bin_tar | |
557 | ||
558 | Returns the full path to your tar binary, if found. | |
559 | ||
560 | =head2 $ae->bin_gzip | |
561 | ||
562 | Returns the full path to your gzip binary, if found | |
563 | ||
564 | =head2 $ae->bin_unzip | |
565 | ||
566 | Returns the full path to your unzip binary, if found | |
567 | ||
8d2ac73b SP |
568 | =head2 $ae->bin_unlzma |
569 | ||
570 | Returns the full path to your unlzma binary, if found | |
571 | ||
d7f87992 CBW |
572 | =head2 $ae->bin_unxz |
573 | ||
574 | Returns the full path to your unxz binary, if found | |
575 | ||
520c99e2 JB |
576 | =cut |
577 | ||
578 | ### paths to commandline tools ### | |
1dae2fb5 RGS |
579 | sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} } |
580 | sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} } | |
581 | sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} } | |
582 | sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} } | |
f37a9f48 | 583 | sub bin_uncompress { return $PROGRAMS->{'uncompress'} |
1dae2fb5 | 584 | if $PROGRAMS->{'uncompress'} } |
8d2ac73b | 585 | sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} } |
d7f87992 | 586 | sub bin_unxz { return $PROGRAMS->{'unxz'} if $PROGRAMS->{'unxz'} } |
8d2ac73b | 587 | |
9e5a0ef9 JB |
588 | =head2 $bool = $ae->have_old_bunzip2 |
589 | ||
590 | Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release, | |
591 | require all archive names to end in C<.bz2> or it will not extract | |
592 | them. This method checks if you have a recent version of C<bunzip2> | |
593 | that allows any extension, or an older one that doesn't. | |
594 | ||
595 | =cut | |
596 | ||
597 | sub have_old_bunzip2 { | |
598 | my $self = shift; | |
599 | ||
600 | ### no bunzip2? no old bunzip2 either :) | |
601 | return unless $self->bin_bunzip2; | |
602 | ||
f37a9f48 | 603 | ### if we can't run this, we can't be sure if it's too old or not |
9e5a0ef9 JB |
604 | ### XXX stupid stupid stupid bunzip2 doesn't understand --version |
605 | ### is not a request to extract data: | |
606 | ### $ bunzip2 --version | |
607 | ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001. | |
608 | ### [...] | |
609 | ### bunzip2: I won't read compressed data from a terminal. | |
610 | ### bunzip2: For help, type: `bunzip2 --help'. | |
611 | ### $ echo $? | |
612 | ### 1 | |
613 | ### HATEFUL! | |
f37a9f48 | 614 | |
8d2ac73b SP |
615 | ### double hateful: bunzip2 --version also hangs if input is a pipe |
616 | ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] | |
617 | ### So, we have to provide *another* argument which is a fake filename, | |
83285295 | 618 | ### just so it wont try to read from stdin to print its version.. |
8d2ac73b SP |
619 | ### *sigh* |
620 | ### Even if the file exists, it won't clobber or change it. | |
9e5a0ef9 | 621 | my $buffer; |
f37a9f48 | 622 | scalar run( |
8d2ac73b | 623 | command => [$self->bin_bunzip2, '--version', 'NoSuchFile'], |
9e5a0ef9 JB |
624 | verbose => 0, |
625 | buffer => \$buffer | |
626 | ); | |
627 | ||
628 | ### no output | |
629 | return unless $buffer; | |
f37a9f48 | 630 | |
9e5a0ef9 JB |
631 | my ($version) = $buffer =~ /version \s+ (\d+)/ix; |
632 | ||
633 | return 1 if $version < 1; | |
634 | return; | |
635 | } | |
520c99e2 JB |
636 | |
637 | ################################# | |
638 | # | |
639 | # Untar code | |
640 | # | |
641 | ################################# | |
642 | ||
e74f3fd4 JB |
643 | ### annoying issue with (gnu) tar on win32, as illustrated by this |
644 | ### bug: https://rt.cpan.org/Ticket/Display.html?id=40138 | |
645 | ### which shows that (gnu) tar will interpret a file name with a : | |
646 | ### in it as a remote file name, so C:\tmp\foo.txt is interpreted | |
647 | ### as a remote shell, and the extract fails. | |
648 | { my @ExtraTarFlags; | |
649 | if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) { | |
520c99e2 | 650 | |
e74f3fd4 JB |
651 | ### if this is gnu tar we are running, we need to use --force-local |
652 | push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i; | |
f37a9f48 | 653 | } |
520c99e2 | 654 | |
520c99e2 | 655 | |
e74f3fd4 JB |
656 | ### use /bin/tar to extract ### |
657 | sub _untar_bin { | |
658 | my $self = shift; | |
f37a9f48 | 659 | |
e74f3fd4 JB |
660 | ### check for /bin/tar ### |
661 | ### check for /bin/gzip if we need it ### | |
662 | ### if any of the binaries are not available, return NA | |
8134d388 | 663 | { my $diag = !$self->bin_tar ? |
e74f3fd4 | 664 | loc("No '%1' program found", '/bin/tar') : |
f37a9f48 | 665 | $self->is_tgz && !$self->bin_gzip ? |
e74f3fd4 JB |
666 | loc("No '%1' program found", '/bin/gzip') : |
667 | $self->is_tbz && !$self->bin_bunzip2 ? | |
668 | loc("No '%1' program found", '/bin/bunzip2') : | |
d7f87992 CBW |
669 | $self->is_txz && !$self->bin_unxz ? |
670 | loc("No '%1' program found", '/bin/unxz') : | |
e74f3fd4 | 671 | ''; |
f37a9f48 | 672 | |
e74f3fd4 JB |
673 | if( $diag ) { |
674 | $self->_error( $diag ); | |
675 | return METHOD_NA; | |
676 | } | |
f37a9f48 CBW |
677 | } |
678 | ||
e74f3fd4 JB |
679 | ### XXX figure out how to make IPC::Run do this in one call -- |
680 | ### currently i don't know how to get output of a command after a pipe | |
681 | ### trapped in a scalar. Mailed barries about this 5th of june 2004. | |
f37a9f48 | 682 | |
e74f3fd4 JB |
683 | ### see what command we should run, based on whether |
684 | ### it's a .tgz or .tar | |
f37a9f48 | 685 | |
ac73ea1e CBW |
686 | ### GNU tar can't handled VMS filespecs, but VMSTAR can handle Unix filespecs. |
687 | my $archive = $self->archive; | |
688 | $archive = VMS::Filespec::unixify($archive) if ON_VMS; | |
689 | ||
e74f3fd4 JB |
690 | ### XXX solaris tar and bsdtar are having different outputs |
691 | ### depending whether you run with -x or -t | |
692 | ### compensate for this insanity by running -t first, then -x | |
f37a9f48 | 693 | { my $cmd = |
ac73ea1e | 694 | $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|', |
e74f3fd4 | 695 | $self->bin_tar, '-tf', '-'] : |
ac73ea1e | 696 | $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', |
e74f3fd4 | 697 | $self->bin_tar, '-tf', '-'] : |
ac73ea1e | 698 | $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', |
d7f87992 | 699 | $self->bin_tar, '-tf', '-'] : |
ac73ea1e | 700 | [$self->bin_tar, @ExtraTarFlags, '-tf', $archive]; |
f37a9f48 CBW |
701 | |
702 | ### run the command | |
7bb74d35 | 703 | ### newer versions of 'tar' (1.21 and up) now print record size |
f37a9f48 | 704 | ### to STDERR as well if v OR t is given (used to be both). This |
7bb74d35 JB |
705 | ### is a 'feature' according to the changelog, so we must now only |
706 | ### inspect STDOUT, otherwise, failures like these occur: | |
f37a9f48 | 707 | ### http://www.cpantesters.org/cpan/report/3230366 |
7bb74d35 JB |
708 | my $buffer = ''; |
709 | my @out = run( command => $cmd, | |
e74f3fd4 | 710 | buffer => \$buffer, |
7bb74d35 JB |
711 | verbose => $DEBUG ); |
712 | ||
f37a9f48 CBW |
713 | ### command was unsuccessful |
714 | unless( $out[0] ) { | |
e74f3fd4 JB |
715 | return $self->_error(loc( |
716 | "Error listing contents of archive '%1': %2", | |
ac73ea1e | 717 | $archive, $buffer )); |
e74f3fd4 | 718 | } |
f37a9f48 | 719 | |
e74f3fd4 JB |
720 | ### no buffers available? |
721 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
ac73ea1e | 722 | $self->_error( $self->_no_buffer_files( $archive ) ); |
f37a9f48 | 723 | |
e74f3fd4 JB |
724 | } else { |
725 | ### if we're on solaris we /might/ be using /bin/tar, which has | |
726 | ### a weird output format... we might also be using | |
727 | ### /usr/local/bin/tar, which is gnu tar, which is perfectly | |
728 | ### fine... so we have to do some guessing here =/ | |
729 | my @files = map { chomp; | |
730 | !ON_SOLARIS ? $_ | |
731 | : (m|^ x \s+ # 'xtract' -- sigh | |
732 | (.+?), # the actual file name | |
733 | \s+ [\d,.]+ \s bytes, | |
734 | \s+ [\d,.]+ \s tape \s blocks | |
735 | |x ? $1 : $_); | |
f37a9f48 | 736 | |
eadbb00b | 737 | ### only STDOUT, see above. Sometimes, extra whitespace |
0228b1bb JB |
738 | ### is present, so make sure we only pick lines with |
739 | ### a length | |
f37a9f48 CBW |
740 | } grep { length } map { split $/, $_ } join '', @{$out[3]}; |
741 | ||
e74f3fd4 JB |
742 | ### store the files that are in the archive ### |
743 | $self->files(\@files); | |
744 | } | |
520c99e2 | 745 | } |
f37a9f48 | 746 | |
e74f3fd4 | 747 | ### now actually extract it ### |
f37a9f48 | 748 | { my $cmd = |
ac73ea1e | 749 | $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|', |
e74f3fd4 | 750 | $self->bin_tar, '-xf', '-'] : |
ac73ea1e | 751 | $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', |
e74f3fd4 | 752 | $self->bin_tar, '-xf', '-'] : |
ac73ea1e | 753 | $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', |
d7f87992 | 754 | $self->bin_tar, '-xf', '-'] : |
ac73ea1e | 755 | [$self->bin_tar, @ExtraTarFlags, '-xf', $archive]; |
f37a9f48 | 756 | |
e74f3fd4 JB |
757 | my $buffer = ''; |
758 | unless( scalar run( command => $cmd, | |
759 | buffer => \$buffer, | |
760 | verbose => $DEBUG ) | |
761 | ) { | |
762 | return $self->_error(loc("Error extracting archive '%1': %2", | |
ac73ea1e | 763 | $archive, $buffer )); |
e74f3fd4 | 764 | } |
f37a9f48 | 765 | |
e74f3fd4 JB |
766 | ### we might not have them, due to lack of buffers |
767 | if( $self->files ) { | |
768 | ### now that we've extracted, figure out where we extracted to | |
769 | my $dir = $self->__get_extract_dir( $self->files ); | |
f37a9f48 | 770 | |
e74f3fd4 JB |
771 | ### store the extraction dir ### |
772 | $self->extract_path( $dir ); | |
773 | } | |
520c99e2 | 774 | } |
f37a9f48 | 775 | |
e74f3fd4 JB |
776 | ### we got here, no error happened |
777 | return 1; | |
520c99e2 | 778 | } |
520c99e2 JB |
779 | } |
780 | ||
e74f3fd4 | 781 | |
520c99e2 JB |
782 | ### use archive::tar to extract ### |
783 | sub _untar_at { | |
784 | my $self = shift; | |
785 | ||
83285295 JB |
786 | ### Loading Archive::Tar is going to set it to 1, so make it local |
787 | ### within this block, starting with its initial value. Whatever | |
788 | ### Achive::Tar does will be undone when we return. | |
789 | ### | |
790 | ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN | |
791 | ### so users don't have to even think about this variable. If they | |
792 | ### do, they still get their set value outside of this call. | |
793 | local $Archive::Tar::WARN = $Archive::Tar::WARN; | |
f37a9f48 | 794 | |
83285295 | 795 | ### we definitely need Archive::Tar, so load that first |
520c99e2 JB |
796 | { my $use_list = { 'Archive::Tar' => '0.0' }; |
797 | ||
798 | unless( can_load( modules => $use_list ) ) { | |
799 | ||
83285295 JB |
800 | $self->_error(loc("You do not have '%1' installed - " . |
801 | "Please install it as soon as possible.", | |
802 | 'Archive::Tar')); | |
f37a9f48 | 803 | |
83285295 | 804 | return METHOD_NA; |
520c99e2 JB |
805 | } |
806 | } | |
807 | ||
808 | ### we might pass it a filehandle if it's a .tbz file.. | |
809 | my $fh_to_read = $self->archive; | |
810 | ||
811 | ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib | |
812 | ### if A::T's version is 0.99 or higher | |
813 | if( $self->is_tgz ) { | |
814 | my $use_list = { 'Compress::Zlib' => '0.0' }; | |
815 | $use_list->{ 'IO::Zlib' } = '0.0' | |
816 | if $Archive::Tar::VERSION >= '0.99'; | |
817 | ||
818 | unless( can_load( modules => $use_list ) ) { | |
819 | my $which = join '/', sort keys %$use_list; | |
820 | ||
83285295 JB |
821 | $self->_error(loc( |
822 | "You do not have '%1' installed - Please ". | |
823 | "install it as soon as possible.", $which) | |
824 | ); | |
f37a9f48 | 825 | |
83285295 | 826 | return METHOD_NA; |
520c99e2 | 827 | } |
83285295 | 828 | |
520c99e2 JB |
829 | } elsif ( $self->is_tbz ) { |
830 | my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; | |
831 | unless( can_load( modules => $use_list ) ) { | |
83285295 JB |
832 | $self->_error(loc( |
833 | "You do not have '%1' installed - Please " . | |
f37a9f48 | 834 | "install it as soon as possible.", |
83285295 JB |
835 | 'IO::Uncompress::Bunzip2') |
836 | ); | |
f37a9f48 | 837 | |
83285295 | 838 | return METHOD_NA; |
520c99e2 JB |
839 | } |
840 | ||
841 | my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or | |
842 | return $self->_error(loc("Unable to open '%1': %2", | |
843 | $self->archive, | |
844 | $IO::Uncompress::Bunzip2::Bunzip2Error)); | |
845 | ||
846 | $fh_to_read = $bz; | |
d7f87992 CBW |
847 | } elsif ( $self->is_txz ) { |
848 | my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; | |
849 | unless( can_load( modules => $use_list ) ) { | |
850 | $self->_error(loc( | |
851 | "You do not have '%1' installed - Please " . | |
f37a9f48 | 852 | "install it as soon as possible.", |
d7f87992 CBW |
853 | 'IO::Uncompress::UnXz') |
854 | ); | |
f37a9f48 | 855 | |
d7f87992 CBW |
856 | return METHOD_NA; |
857 | } | |
858 | ||
859 | my $xz = IO::Uncompress::UnXz->new( $self->archive ) or | |
860 | return $self->_error(loc("Unable to open '%1': %2", | |
861 | $self->archive, | |
862 | $IO::Uncompress::UnXz::UnXzError)); | |
863 | ||
864 | $fh_to_read = $xz; | |
520c99e2 JB |
865 | } |
866 | ||
198e857c JB |
867 | my @files; |
868 | { | |
869 | ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've | |
870 | ### localized $Archive::Tar::WARN already. | |
871 | $Archive::Tar::WARN = $Archive::Extract::WARN; | |
83285295 | 872 | |
198e857c JB |
873 | ### only tell it it's compressed if it's a .tgz, as we give it a file |
874 | ### handle if it's a .tbz | |
875 | my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ); | |
520c99e2 | 876 | |
198e857c JB |
877 | ### for version of Archive::Tar > 1.04 |
878 | local $Archive::Tar::CHOWN = 0; | |
520c99e2 | 879 | |
198e857c JB |
880 | ### use the iterator if we can. it's a feature of A::T 1.40 and up |
881 | if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) { | |
520c99e2 | 882 | |
198e857c JB |
883 | my $next; |
884 | unless ( $next = Archive::Tar->iter( @read ) ) { | |
885 | return $self->_error(loc( | |
f37a9f48 | 886 | "Unable to read '%1': %2", $self->archive, |
198e857c JB |
887 | $Archive::Tar::error)); |
888 | } | |
520c99e2 | 889 | |
198e857c JB |
890 | while ( my $file = $next->() ) { |
891 | push @files, $file->full_path; | |
f37a9f48 | 892 | |
198e857c | 893 | $file->extract or return $self->_error(loc( |
f37a9f48 | 894 | "Unable to read '%1': %2", |
198e857c JB |
895 | $self->archive, |
896 | $Archive::Tar::error)); | |
897 | } | |
f37a9f48 CBW |
898 | |
899 | ### older version, read the archive into memory | |
198e857c JB |
900 | } else { |
901 | ||
902 | my $tar = Archive::Tar->new(); | |
903 | ||
904 | unless( $tar->read( @read ) ) { | |
f37a9f48 | 905 | return $self->_error(loc("Unable to read '%1': %2", |
198e857c JB |
906 | $self->archive, $Archive::Tar::error)); |
907 | } | |
908 | ||
909 | ### workaround to prevent Archive::Tar from setting uid, which | |
910 | ### is a potential security hole. -autrijus | |
911 | ### have to do it here, since A::T needs to be /loaded/ first ### | |
912 | { no strict 'refs'; local $^W; | |
913 | ||
914 | ### older versions of archive::tar <= 0.23 | |
915 | *Archive::Tar::chown = sub {}; | |
916 | } | |
917 | ||
918 | { local $^W; # quell 'splice() offset past end of array' warnings | |
919 | # on older versions of A::T | |
920 | ||
f37a9f48 | 921 | ### older archive::tar always returns $self, return value |
198e857c JB |
922 | ### slightly fux0r3d because of it. |
923 | $tar->extract or return $self->_error(loc( | |
924 | "Unable to extract '%1': %2", | |
925 | $self->archive, $Archive::Tar::error )); | |
926 | } | |
927 | ||
928 | @files = $tar->list_files; | |
929 | } | |
520c99e2 JB |
930 | } |
931 | ||
198e857c | 932 | my $dir = $self->__get_extract_dir( \@files ); |
520c99e2 JB |
933 | |
934 | ### store the files that are in the archive ### | |
935 | $self->files(\@files); | |
936 | ||
937 | ### store the extraction dir ### | |
938 | $self->extract_path( $dir ); | |
939 | ||
940 | ### check if the dir actually appeared ### | |
941 | return 1 if -d $self->extract_path; | |
942 | ||
943 | ### no dir, we failed ### | |
944 | return $self->_error(loc("Unable to extract '%1': %2", | |
945 | $self->archive, $Archive::Tar::error )); | |
946 | } | |
947 | ||
948 | ################################# | |
949 | # | |
950 | # Gunzip code | |
951 | # | |
952 | ################################# | |
953 | ||
520c99e2 JB |
954 | sub _gunzip_bin { |
955 | my $self = shift; | |
956 | ||
957 | ### check for /bin/gzip -- we need it ### | |
83285295 JB |
958 | unless( $self->bin_gzip ) { |
959 | $self->_error(loc("No '%1' program found", '/bin/gzip')); | |
960 | return METHOD_NA; | |
961 | } | |
520c99e2 JB |
962 | |
963 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
964 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
965 | $self->_gunzip_to, $! )); | |
966 | ||
967 | my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ]; | |
968 | ||
969 | my $buffer; | |
970 | unless( scalar run( command => $cmd, | |
971 | verbose => $DEBUG, | |
972 | buffer => \$buffer ) | |
973 | ) { | |
974 | return $self->_error(loc("Unable to gunzip '%1': %2", | |
975 | $self->archive, $buffer)); | |
976 | } | |
977 | ||
978 | ### no buffers available? | |
979 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
980 | $self->_error( $self->_no_buffer_content( $self->archive ) ); | |
981 | } | |
982 | ||
35fe4187 | 983 | $self->_print($fh, $buffer) if defined $buffer; |
520c99e2 JB |
984 | |
985 | close $fh; | |
986 | ||
987 | ### set what files where extract, and where they went ### | |
988 | $self->files( [$self->_gunzip_to] ); | |
989 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
990 | ||
991 | return 1; | |
992 | } | |
993 | ||
994 | sub _gunzip_cz { | |
995 | my $self = shift; | |
996 | ||
997 | my $use_list = { 'Compress::Zlib' => '0.0' }; | |
998 | unless( can_load( modules => $use_list ) ) { | |
83285295 JB |
999 | $self->_error(loc("You do not have '%1' installed - Please " . |
1000 | "install it as soon as possible.", 'Compress::Zlib')); | |
1001 | return METHOD_NA; | |
520c99e2 JB |
1002 | } |
1003 | ||
1004 | my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or | |
1005 | return $self->_error(loc("Unable to open '%1': %2", | |
1006 | $self->archive, $Compress::Zlib::gzerrno)); | |
1007 | ||
1008 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
1009 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1010 | $self->_gunzip_to, $! )); | |
1011 | ||
1012 | my $buffer; | |
35fe4187 | 1013 | $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0; |
520c99e2 JB |
1014 | $fh->close; |
1015 | ||
1016 | ### set what files where extract, and where they went ### | |
1017 | $self->files( [$self->_gunzip_to] ); | |
1018 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1019 | ||
1020 | return 1; | |
1021 | } | |
1022 | ||
1023 | ################################# | |
1024 | # | |
1dae2fb5 RGS |
1025 | # Uncompress code |
1026 | # | |
1027 | ################################# | |
1028 | ||
1dae2fb5 RGS |
1029 | sub _uncompress_bin { |
1030 | my $self = shift; | |
1031 | ||
1032 | ### check for /bin/gzip -- we need it ### | |
83285295 JB |
1033 | unless( $self->bin_uncompress ) { |
1034 | $self->_error(loc("No '%1' program found", '/bin/uncompress')); | |
1035 | return METHOD_NA; | |
1036 | } | |
1dae2fb5 RGS |
1037 | |
1038 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
1039 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1040 | $self->_gunzip_to, $! )); | |
1041 | ||
1042 | my $cmd = [ $self->bin_uncompress, '-c', $self->archive ]; | |
1043 | ||
1044 | my $buffer; | |
1045 | unless( scalar run( command => $cmd, | |
1046 | verbose => $DEBUG, | |
1047 | buffer => \$buffer ) | |
1048 | ) { | |
1049 | return $self->_error(loc("Unable to uncompress '%1': %2", | |
1050 | $self->archive, $buffer)); | |
1051 | } | |
1052 | ||
1053 | ### no buffers available? | |
1054 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
1055 | $self->_error( $self->_no_buffer_content( $self->archive ) ); | |
1056 | } | |
1057 | ||
35fe4187 | 1058 | $self->_print($fh, $buffer) if defined $buffer; |
1dae2fb5 RGS |
1059 | |
1060 | close $fh; | |
1061 | ||
1062 | ### set what files where extract, and where they went ### | |
1063 | $self->files( [$self->_gunzip_to] ); | |
1064 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1065 | ||
1066 | return 1; | |
1067 | } | |
1068 | ||
1069 | ||
1070 | ################################# | |
1071 | # | |
520c99e2 JB |
1072 | # Unzip code |
1073 | # | |
1074 | ################################# | |
1075 | ||
520c99e2 JB |
1076 | |
1077 | sub _unzip_bin { | |
1078 | my $self = shift; | |
1079 | ||
1080 | ### check for /bin/gzip if we need it ### | |
83285295 JB |
1081 | unless( $self->bin_unzip ) { |
1082 | $self->_error(loc("No '%1' program found", '/bin/unzip')); | |
1083 | return METHOD_NA; | |
f37a9f48 | 1084 | } |
520c99e2 JB |
1085 | |
1086 | ### first, get the files.. it must be 2 different commands with 'unzip' :( | |
9e5a0ef9 | 1087 | { ### on VMS, capital letter options have to be quoted. This is |
6447e912 | 1088 | ### reported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11 |
9e5a0ef9 JB |
1089 | ### Subject: [patch@31735]Archive Extract fix on VMS. |
1090 | my $opt = ON_VMS ? '"-Z"' : '-Z'; | |
1091 | my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ]; | |
f37a9f48 | 1092 | |
520c99e2 JB |
1093 | my $buffer = ''; |
1094 | unless( scalar run( command => $cmd, | |
1095 | verbose => $DEBUG, | |
1096 | buffer => \$buffer ) | |
1097 | ) { | |
1098 | return $self->_error(loc("Unable to unzip '%1': %2", | |
1099 | $self->archive, $buffer)); | |
1100 | } | |
1101 | ||
1102 | ### no buffers available? | |
1103 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
1104 | $self->_error( $self->_no_buffer_files( $self->archive ) ); | |
1105 | ||
1106 | } else { | |
aefcd4a2 CBW |
1107 | ### Annoyingly, pesky MSWin32 can either have 'native' tools |
1108 | ### which have \r\n line endings or Cygwin-based tools which | |
1109 | ### have \n line endings. Jan Dubois suggested using this fix | |
1110 | local $/ = ON_WIN32 ? qr/\r?\n/ : "\n"; | |
520c99e2 JB |
1111 | $self->files( [split $/, $buffer] ); |
1112 | } | |
1113 | } | |
1114 | ||
1115 | ### now, extract the archive ### | |
1116 | { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ]; | |
1117 | ||
1118 | my $buffer; | |
1119 | unless( scalar run( command => $cmd, | |
1120 | verbose => $DEBUG, | |
1121 | buffer => \$buffer ) | |
1122 | ) { | |
1123 | return $self->_error(loc("Unable to unzip '%1': %2", | |
1124 | $self->archive, $buffer)); | |
1125 | } | |
1126 | ||
1127 | if( scalar @{$self->files} ) { | |
1128 | my $files = $self->files; | |
1129 | my $dir = $self->__get_extract_dir( $files ); | |
1130 | ||
1131 | $self->extract_path( $dir ); | |
1132 | } | |
1133 | } | |
1134 | ||
1135 | return 1; | |
1136 | } | |
1137 | ||
1138 | sub _unzip_az { | |
1139 | my $self = shift; | |
1140 | ||
1141 | my $use_list = { 'Archive::Zip' => '0.0' }; | |
1142 | unless( can_load( modules => $use_list ) ) { | |
83285295 JB |
1143 | $self->_error(loc("You do not have '%1' installed - Please " . |
1144 | "install it as soon as possible.", 'Archive::Zip')); | |
f37a9f48 | 1145 | return METHOD_NA; |
520c99e2 JB |
1146 | } |
1147 | ||
1148 | my $zip = Archive::Zip->new(); | |
1149 | ||
1150 | unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { | |
1151 | return $self->_error(loc("Unable to read '%1'", $self->archive)); | |
1152 | } | |
1153 | ||
1154 | my @files; | |
f37a9f48 CBW |
1155 | |
1156 | ||
e74f3fd4 JB |
1157 | ### Address: #43278: Explicitly tell Archive::Zip where to put the files: |
1158 | ### "In my BackPAN indexing, Archive::Zip was extracting things | |
1159 | ### in my script's directory instead of the current working directory. | |
1160 | ### I traced this back through Archive::Zip::_asLocalName which | |
1161 | ### eventually calls File::Spec::Win32::rel2abs which on Windows might | |
1162 | ### call Cwd::getdcwd. getdcwd returns the wrong directory in my | |
1163 | ### case, even though I think I'm on the same drive. | |
f37a9f48 | 1164 | ### |
e74f3fd4 JB |
1165 | ### To fix this, I pass the optional second argument to |
1166 | ### extractMember using the cwd from Archive::Extract." --bdfoy | |
1167 | ||
1168 | ## store cwd() before looping; calls to cwd() can be expensive, and | |
1169 | ### it won't change during the loop | |
1170 | my $extract_dir = cwd(); | |
f37a9f48 | 1171 | |
e74f3fd4 | 1172 | ### have to extract every member individually ### |
520c99e2 JB |
1173 | for my $member ($zip->members) { |
1174 | push @files, $member->{fileName}; | |
1175 | ||
eadbb00b | 1176 | ### file to extract to, to avoid the above problem |
e74f3fd4 | 1177 | my $to = File::Spec->catfile( $extract_dir, $member->{fileName} ); |
f37a9f48 | 1178 | |
e74f3fd4 | 1179 | unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) { |
520c99e2 JB |
1180 | return $self->_error(loc("Extraction of '%1' from '%2' failed", |
1181 | $member->{fileName}, $self->archive )); | |
1182 | } | |
1183 | } | |
1184 | ||
1185 | my $dir = $self->__get_extract_dir( \@files ); | |
1186 | ||
1187 | ### set what files where extract, and where they went ### | |
1188 | $self->files( \@files ); | |
1189 | $self->extract_path( File::Spec->rel2abs($dir) ); | |
1190 | ||
1191 | return 1; | |
1192 | } | |
1193 | ||
1194 | sub __get_extract_dir { | |
1195 | my $self = shift; | |
1196 | my $files = shift || []; | |
1197 | ||
1198 | return unless scalar @$files; | |
1199 | ||
1200 | my($dir1, $dir2); | |
1201 | for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { | |
1202 | my($dir,$pos) = @$aref; | |
1203 | ||
1204 | ### add a catdir(), so that any trailing slashes get | |
1205 | ### take care of (removed) | |
1206 | ### also, a catdir() normalises './dir/foo' to 'dir/foo'; | |
1207 | ### which was the problem in bug #23999 | |
1208 | my $res = -d $files->[$pos] | |
1209 | ? File::Spec->catdir( $files->[$pos], '' ) | |
f37a9f48 | 1210 | : File::Spec->catdir( dirname( $files->[$pos] ) ); |
520c99e2 JB |
1211 | |
1212 | $$dir = $res; | |
1213 | } | |
1214 | ||
f37a9f48 | 1215 | ### if the first and last dir don't match, make sure the |
520c99e2 JB |
1216 | ### dirname is not set wrongly |
1217 | my $dir; | |
f37a9f48 | 1218 | |
520c99e2 JB |
1219 | ### dirs are the same, so we know for sure what the extract dir is |
1220 | if( $dir1 eq $dir2 ) { | |
1221 | $dir = $dir1; | |
f37a9f48 | 1222 | |
520c99e2 JB |
1223 | ### dirs are different.. do they share the base dir? |
1224 | ### if so, use that, if not, fall back to '.' | |
1225 | } else { | |
1226 | my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0]; | |
1227 | my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0]; | |
f37a9f48 CBW |
1228 | |
1229 | $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' ); | |
1230 | } | |
520c99e2 JB |
1231 | |
1232 | return File::Spec->rel2abs( $dir ); | |
1233 | } | |
1234 | ||
1235 | ################################# | |
1236 | # | |
1237 | # Bunzip2 code | |
1238 | # | |
1239 | ################################# | |
1240 | ||
520c99e2 JB |
1241 | sub _bunzip2_bin { |
1242 | my $self = shift; | |
1243 | ||
1244 | ### check for /bin/gzip -- we need it ### | |
83285295 JB |
1245 | unless( $self->bin_bunzip2 ) { |
1246 | $self->_error(loc("No '%1' program found", '/bin/bunzip2')); | |
1247 | return METHOD_NA; | |
f37a9f48 | 1248 | } |
520c99e2 JB |
1249 | |
1250 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
1251 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1252 | $self->_gunzip_to, $! )); | |
f37a9f48 | 1253 | |
9e5a0ef9 JB |
1254 | ### guard against broken bunzip2. See ->have_old_bunzip2() |
1255 | ### for details | |
1256 | if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) { | |
1257 | return $self->_error(loc("Your bunzip2 version is too old and ". | |
1258 | "can only extract files ending in '%1'", | |
1259 | '.bz2')); | |
1260 | } | |
520c99e2 | 1261 | |
9e5a0ef9 | 1262 | my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ]; |
520c99e2 JB |
1263 | |
1264 | my $buffer; | |
1265 | unless( scalar run( command => $cmd, | |
1266 | verbose => $DEBUG, | |
1267 | buffer => \$buffer ) | |
1268 | ) { | |
1269 | return $self->_error(loc("Unable to bunzip2 '%1': %2", | |
1270 | $self->archive, $buffer)); | |
1271 | } | |
1272 | ||
1273 | ### no buffers available? | |
1274 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
1275 | $self->_error( $self->_no_buffer_content( $self->archive ) ); | |
1276 | } | |
f37a9f48 | 1277 | |
35fe4187 | 1278 | $self->_print($fh, $buffer) if defined $buffer; |
520c99e2 JB |
1279 | |
1280 | close $fh; | |
1281 | ||
1282 | ### set what files where extract, and where they went ### | |
1283 | $self->files( [$self->_gunzip_to] ); | |
1284 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1285 | ||
1286 | return 1; | |
1287 | } | |
1288 | ||
1289 | ### using cz2, the compact versions... this we use mainly in archive::tar | |
1290 | ### extractor.. | |
1291 | # sub _bunzip2_cz1 { | |
1292 | # my $self = shift; | |
f37a9f48 | 1293 | # |
520c99e2 JB |
1294 | # my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; |
1295 | # unless( can_load( modules => $use_list ) ) { | |
1296 | # return $self->_error(loc("You do not have '%1' installed - Please " . | |
1297 | # "install it as soon as possible.", | |
1298 | # 'IO::Uncompress::Bunzip2')); | |
1299 | # } | |
f37a9f48 | 1300 | # |
520c99e2 JB |
1301 | # my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or |
1302 | # return $self->_error(loc("Unable to open '%1': %2", | |
1303 | # $self->archive, | |
1304 | # $IO::Uncompress::Bunzip2::Bunzip2Error)); | |
f37a9f48 | 1305 | # |
520c99e2 JB |
1306 | # my $fh = FileHandle->new('>'. $self->_gunzip_to) or |
1307 | # return $self->_error(loc("Could not open '%1' for writing: %2", | |
1308 | # $self->_gunzip_to, $! )); | |
f37a9f48 | 1309 | # |
520c99e2 JB |
1310 | # my $buffer; |
1311 | # $fh->print($buffer) while $bz->read($buffer) > 0; | |
1312 | # $fh->close; | |
f37a9f48 | 1313 | # |
520c99e2 JB |
1314 | # ### set what files where extract, and where they went ### |
1315 | # $self->files( [$self->_gunzip_to] ); | |
1316 | # $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
f37a9f48 | 1317 | # |
520c99e2 JB |
1318 | # return 1; |
1319 | # } | |
1320 | ||
83285295 | 1321 | sub _bunzip2_bz2 { |
520c99e2 JB |
1322 | my $self = shift; |
1323 | ||
1324 | my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; | |
1325 | unless( can_load( modules => $use_list ) ) { | |
83285295 JB |
1326 | $self->_error(loc("You do not have '%1' installed - Please " . |
1327 | "install it as soon as possible.", | |
1328 | 'IO::Uncompress::Bunzip2')); | |
f37a9f48 | 1329 | return METHOD_NA; |
520c99e2 JB |
1330 | } |
1331 | ||
1332 | IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) | |
1333 | or return $self->_error(loc("Unable to uncompress '%1': %2", | |
1334 | $self->archive, | |
1335 | $IO::Uncompress::Bunzip2::Bunzip2Error)); | |
1336 | ||
1337 | ### set what files where extract, and where they went ### | |
1338 | $self->files( [$self->_gunzip_to] ); | |
1339 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1340 | ||
1341 | return 1; | |
1342 | } | |
1343 | ||
d7f87992 CBW |
1344 | ################################# |
1345 | # | |
1346 | # UnXz code | |
1347 | # | |
1348 | ################################# | |
1349 | ||
1350 | sub _unxz_bin { | |
1351 | my $self = shift; | |
1352 | ||
1353 | ### check for /bin/unxz -- we need it ### | |
1354 | unless( $self->bin_unxz ) { | |
1355 | $self->_error(loc("No '%1' program found", '/bin/unxz')); | |
1356 | return METHOD_NA; | |
1357 | } | |
1358 | ||
1359 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
1360 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1361 | $self->_gunzip_to, $! )); | |
1362 | ||
1363 | my $cmd = [ $self->bin_unxz, '-cdf', $self->archive ]; | |
1364 | ||
1365 | my $buffer; | |
1366 | unless( scalar run( command => $cmd, | |
1367 | verbose => $DEBUG, | |
1368 | buffer => \$buffer ) | |
1369 | ) { | |
1370 | return $self->_error(loc("Unable to unxz '%1': %2", | |
1371 | $self->archive, $buffer)); | |
1372 | } | |
1373 | ||
1374 | ### no buffers available? | |
1375 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
1376 | $self->_error( $self->_no_buffer_content( $self->archive ) ); | |
1377 | } | |
1378 | ||
1379 | $self->_print($fh, $buffer) if defined $buffer; | |
1380 | ||
1381 | close $fh; | |
1382 | ||
1383 | ### set what files where extract, and where they went ### | |
1384 | $self->files( [$self->_gunzip_to] ); | |
1385 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1386 | ||
1387 | return 1; | |
1388 | } | |
1389 | ||
1390 | sub _unxz_cz { | |
1391 | my $self = shift; | |
1392 | ||
1393 | my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; | |
1394 | unless( can_load( modules => $use_list ) ) { | |
1395 | $self->_error(loc("You do not have '%1' installed - Please " . | |
1396 | "install it as soon as possible.", | |
1397 | 'IO::Uncompress::UnXz')); | |
f37a9f48 | 1398 | return METHOD_NA; |
d7f87992 CBW |
1399 | } |
1400 | ||
1401 | IO::Uncompress::UnXz::unxz($self->archive => $self->_gunzip_to) | |
1402 | or return $self->_error(loc("Unable to uncompress '%1': %2", | |
1403 | $self->archive, | |
1404 | $IO::Uncompress::UnXz::UnXzError)); | |
1405 | ||
1406 | ### set what files where extract, and where they went ### | |
1407 | $self->files( [$self->_gunzip_to] ); | |
1408 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1409 | ||
1410 | return 1; | |
1411 | } | |
1412 | ||
520c99e2 JB |
1413 | |
1414 | ################################# | |
1415 | # | |
8d2ac73b SP |
1416 | # unlzma code |
1417 | # | |
1418 | ################################# | |
1419 | ||
8d2ac73b SP |
1420 | sub _unlzma_bin { |
1421 | my $self = shift; | |
1422 | ||
1423 | ### check for /bin/unlzma -- we need it ### | |
83285295 JB |
1424 | unless( $self->bin_unlzma ) { |
1425 | $self->_error(loc("No '%1' program found", '/bin/unlzma')); | |
1426 | return METHOD_NA; | |
f37a9f48 | 1427 | } |
8d2ac73b SP |
1428 | |
1429 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or | |
1430 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1431 | $self->_gunzip_to, $! )); | |
1432 | ||
1433 | my $cmd = [ $self->bin_unlzma, '-c', $self->archive ]; | |
1434 | ||
1435 | my $buffer; | |
1436 | unless( scalar run( command => $cmd, | |
1437 | verbose => $DEBUG, | |
1438 | buffer => \$buffer ) | |
1439 | ) { | |
1440 | return $self->_error(loc("Unable to unlzma '%1': %2", | |
1441 | $self->archive, $buffer)); | |
1442 | } | |
1443 | ||
1444 | ### no buffers available? | |
1445 | if( !IPC::Cmd->can_capture_buffer and !$buffer ) { | |
1446 | $self->_error( $self->_no_buffer_content( $self->archive ) ); | |
1447 | } | |
1448 | ||
35fe4187 | 1449 | $self->_print($fh, $buffer) if defined $buffer; |
8d2ac73b SP |
1450 | |
1451 | close $fh; | |
1452 | ||
1453 | ### set what files where extract, and where they went ### | |
1454 | $self->files( [$self->_gunzip_to] ); | |
1455 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1456 | ||
1457 | return 1; | |
1458 | } | |
1459 | ||
1460 | sub _unlzma_cz { | |
1461 | my $self = shift; | |
1462 | ||
d7f87992 CBW |
1463 | my $use_list1 = { 'IO::Uncompress::UnLzma' => '0.0' }; |
1464 | my $use_list2 = { 'Compress::unLZMA' => '0.0' }; | |
1465 | ||
1466 | if (can_load( modules => $use_list1 ) ) { | |
1467 | IO::Uncompress::UnLzma::unlzma($self->archive => $self->_gunzip_to) | |
1468 | or return $self->_error(loc("Unable to uncompress '%1': %2", | |
1469 | $self->archive, | |
1470 | $IO::Uncompress::UnLzma::UnLzmaError)); | |
8d2ac73b | 1471 | } |
d7f87992 | 1472 | elsif (can_load( modules => $use_list2 ) ) { |
8d2ac73b | 1473 | |
d7f87992 CBW |
1474 | my $fh = FileHandle->new('>'. $self->_gunzip_to) or |
1475 | return $self->_error(loc("Could not open '%1' for writing: %2", | |
1476 | $self->_gunzip_to, $! )); | |
8d2ac73b | 1477 | |
d7f87992 CBW |
1478 | my $buffer; |
1479 | $buffer = Compress::unLZMA::uncompressfile( $self->archive ); | |
1480 | unless ( defined $buffer ) { | |
1481 | return $self->_error(loc("Could not unlzma '%1': %2", | |
1482 | $self->archive, $@)); | |
1483 | } | |
8d2ac73b | 1484 | |
d7f87992 | 1485 | $self->_print($fh, $buffer) if defined $buffer; |
8d2ac73b | 1486 | |
d7f87992 CBW |
1487 | close $fh; |
1488 | } | |
1489 | else { | |
1490 | $self->_error(loc("You do not have '%1' or '%2' installed - Please " . | |
1491 | "install it as soon as possible.", 'Compress::unLZMA', 'IO::Uncompress::UnLzma')); | |
f37a9f48 | 1492 | return METHOD_NA; |
d7f87992 | 1493 | } |
8d2ac73b SP |
1494 | |
1495 | ### set what files where extract, and where they went ### | |
1496 | $self->files( [$self->_gunzip_to] ); | |
1497 | $self->extract_path( File::Spec->rel2abs(cwd()) ); | |
1498 | ||
1499 | return 1; | |
1500 | } | |
1501 | ||
1502 | ################################# | |
1503 | # | |
520c99e2 JB |
1504 | # Error code |
1505 | # | |
1506 | ################################# | |
1507 | ||
35fe4187 CBW |
1508 | # For printing binaries that avoids interfering globals |
1509 | sub _print { | |
1510 | my $self = shift; | |
1511 | my $fh = shift; | |
1512 | ||
1513 | local( $\, $", $, ) = ( undef, ' ', '' ); | |
1514 | return print $fh @_; | |
1515 | } | |
1516 | ||
520c99e2 JB |
1517 | sub _error { |
1518 | my $self = shift; | |
1519 | my $error = shift; | |
83285295 JB |
1520 | my $lerror = Carp::longmess($error); |
1521 | ||
1522 | push @{$self->_error_msg}, $error; | |
1523 | push @{$self->_error_msg_long}, $lerror; | |
f37a9f48 | 1524 | |
520c99e2 JB |
1525 | ### set $Archive::Extract::WARN to 0 to disable printing |
1526 | ### of errors | |
1527 | if( $WARN ) { | |
83285295 | 1528 | carp $DEBUG ? $lerror : $error; |
520c99e2 JB |
1529 | } |
1530 | ||
1531 | return; | |
1532 | } | |
1533 | ||
1534 | sub error { | |
1535 | my $self = shift; | |
83285295 JB |
1536 | |
1537 | ### make sure we have a fallback aref | |
f37a9f48 CBW |
1538 | my $aref = do { |
1539 | shift() | |
1540 | ? $self->_error_msg_long | |
1541 | : $self->_error_msg | |
83285295 | 1542 | } || []; |
f37a9f48 | 1543 | |
83285295 | 1544 | return join $/, @$aref; |
520c99e2 JB |
1545 | } |
1546 | ||
a6696b92 CBW |
1547 | =head2 debug( MESSAGE ) |
1548 | ||
1549 | This method outputs MESSAGE to the default filehandle if C<$DEBUG> is | |
1550 | true. It's a small method, but it's here if you'd like to subclass it | |
1551 | so you can so something else with any debugging output. | |
1552 | ||
1553 | =cut | |
1554 | ||
1555 | ### this is really a stub for subclassing | |
1556 | sub debug { | |
1557 | return unless $DEBUG; | |
1558 | ||
1559 | print $_[1]; | |
1560 | } | |
1561 | ||
520c99e2 JB |
1562 | sub _no_buffer_files { |
1563 | my $self = shift; | |
1564 | my $file = shift or return; | |
1565 | return loc("No buffer captured, unable to tell ". | |
1566 | "extracted files or extraction dir for '%1'", $file); | |
1567 | } | |
1568 | ||
1569 | sub _no_buffer_content { | |
1570 | my $self = shift; | |
1571 | my $file = shift or return; | |
1572 | return loc("No buffer captured, unable to get content for '%1'", $file); | |
1573 | } | |
1574 | 1; | |
1575 | ||
1576 | =pod | |
1577 | ||
1578 | =head1 HOW IT WORKS | |
1579 | ||
1580 | C<Archive::Extract> tries first to determine what type of archive you | |
1581 | are passing it, by inspecting its suffix. It does not do this by using | |
1582 | Mime magic, or something related. See C<CAVEATS> below. | |
1583 | ||
1584 | Once it has determined the file type, it knows which extraction methods | |
1585 | it can use on the archive. It will try a perl solution first, then fall | |
1586 | back to a commandline tool if that fails. If that also fails, it will | |
1587 | return false, indicating it was unable to extract the archive. | |
1588 | See the section on C<GLOBAL VARIABLES> to see how to alter this order. | |
1589 | ||
1590 | =head1 CAVEATS | |
1591 | ||
1592 | =head2 File Extensions | |
1593 | ||
1594 | C<Archive::Extract> trusts on the extension of the archive to determine | |
1595 | what type it is, and what extractor methods therefore can be used. If | |
1596 | your archives do not have any of the extensions as described in the | |
1597 | C<new()> method, you will have to specify the type explicitly, or | |
1598 | C<Archive::Extract> will not be able to extract the archive for you. | |
1599 | ||
9e5a0ef9 JB |
1600 | =head2 Supporting Very Large Files |
1601 | ||
1602 | C<Archive::Extract> can use either pure perl modules or command line | |
f37a9f48 | 1603 | programs under the hood. Some of the pure perl modules (like |
8d2ac73b | 1604 | C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory, |
9e5a0ef9 JB |
1605 | which may not be feasible on your system. Consider setting the global |
1606 | variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer | |
1607 | the use of command line programs and won't consume so much memory. | |
1608 | ||
1609 | See the C<GLOBAL VARIABLES> section below for details. | |
1610 | ||
1611 | =head2 Bunzip2 support of arbitrary extensions. | |
1612 | ||
f37a9f48 | 1613 | Older versions of C</bin/bunzip2> do not support arbitrary file |
9e5a0ef9 JB |
1614 | extensions and insist on a C<.bz2> suffix. Although we do our best |
1615 | to guard against this, if you experience a bunzip2 error, it may | |
1616 | be related to this. For details, please see the C<have_old_bunzip2> | |
1617 | method. | |
1618 | ||
520c99e2 JB |
1619 | =head1 GLOBAL VARIABLES |
1620 | ||
1621 | =head2 $Archive::Extract::DEBUG | |
1622 | ||
1623 | Set this variable to C<true> to have all calls to command line tools | |
1624 | be printed out, including all their output. | |
1625 | This also enables C<Carp::longmess> errors, instead of the regular | |
1626 | C<carp> errors. | |
1627 | ||
1628 | Good for tracking down why things don't work with your particular | |
1629 | setup. | |
1630 | ||
1631 | Defaults to C<false>. | |
1632 | ||
1633 | =head2 $Archive::Extract::WARN | |
1634 | ||
1635 | This variable controls whether errors encountered internally by | |
1636 | C<Archive::Extract> should be C<carp>'d or not. | |
1637 | ||
1638 | Set to false to silence warnings. Inspect the output of the C<error()> | |
1639 | method manually to see what went wrong. | |
1640 | ||
1641 | Defaults to C<true>. | |
1642 | ||
1643 | =head2 $Archive::Extract::PREFER_BIN | |
1644 | ||
1645 | This variables controls whether C<Archive::Extract> should prefer the | |
1646 | use of perl modules, or commandline tools to extract archives. | |
1647 | ||
1648 | Set to C<true> to have C<Archive::Extract> prefer commandline tools. | |
1649 | ||
1650 | Defaults to C<false>. | |
1651 | ||
0228b1bb | 1652 | =head1 TODO / CAVEATS |
520c99e2 JB |
1653 | |
1654 | =over 4 | |
1655 | ||
1656 | =item Mime magic support | |
1657 | ||
1658 | Maybe this module should use something like C<File::Type> to determine | |
1659 | the type, rather than blindly trust the suffix. | |
1660 | ||
0228b1bb JB |
1661 | =item Thread safety |
1662 | ||
1663 | Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before | |
f37a9f48 | 1664 | extraction, and a C<chdir> back again after. This is not necessarily |
0228b1bb JB |
1665 | thread safe. See C<rt.cpan.org> bug C<#45671> for details. |
1666 | ||
1dae2fb5 RGS |
1667 | =back |
1668 | ||
574b415d | 1669 | =head1 BUG REPORTS |
520c99e2 | 1670 | |
8134d388 | 1671 | Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.orgE<gt>. |
520c99e2 | 1672 | |
574b415d RGS |
1673 | =head1 AUTHOR |
1674 | ||
1675 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. | |
520c99e2 | 1676 | |
574b415d | 1677 | =head1 COPYRIGHT |
520c99e2 | 1678 | |
f37a9f48 | 1679 | This library is free software; you may redistribute and/or modify it |
574b415d | 1680 | under the same terms as Perl itself. |
520c99e2 JB |
1681 | |
1682 | =cut | |
1683 | ||
1684 | # Local variables: | |
1685 | # c-indentation-style: bsd | |
1686 | # c-basic-offset: 4 | |
1687 | # indent-tabs-mode: nil | |
1688 | # End: | |
1689 | # vim: expandtab shiftwidth=4: | |
1690 |