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