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