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