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
1 package Archive::Extract;
2
3 use strict;
4
5 use Cwd                         qw[cwd chdir];
6 use Carp                        qw[carp];
7 use IPC::Cmd                    qw[run can_run];
8 use FileHandle;
9 use File::Path                  qw[mkpath];
10 use File::Spec;
11 use File::Basename              qw[dirname basename];
12 use Params::Check               qw[check];
13 use Module::Load::Conditional   qw[can_load check_install];
14 use Locale::Maketext::Simple    Style => 'gettext';
15
16 ### solaris has silly /bin/tar output ###
17 use constant ON_SOLARIS     => $^O eq 'solaris' ? 1 : 0;
18 use constant ON_NETBSD      => $^O eq 'netbsd' ? 1 : 0;
19 use constant ON_FREEBSD     => $^O eq 'freebsd' ? 1 : 0;
20 use constant ON_LINUX       => $^O eq 'linux' ? 1 : 0;
21 use constant FILE_EXISTS    => sub { -e $_[0] ? 1 : 0 };
22
23 ### VMS may require quoting upper case command options
24 use constant ON_VMS         => $^O eq 'VMS' ? 1 : 0;
25
26 ### Windows needs special treatment of Tar options
27 use constant ON_WIN32       => $^O eq 'MSWin32' ? 1 : 0;
28
29 ### we can't use this extraction method, because of missing
30 ### modules/binaries:
31 use constant METHOD_NA      => [];
32
33 ### If these are changed, update @TYPES and the new() POD
34 use constant TGZ            => 'tgz';
35 use constant TAR            => 'tar';
36 use constant GZ             => 'gz';
37 use constant ZIP            => 'zip';
38 use constant BZ2            => 'bz2';
39 use constant TBZ            => 'tbz';
40 use constant Z              => 'Z';
41 use constant LZMA           => 'lzma';
42 use constant XZ             => 'xz';
43 use constant TXZ            => 'txz';
44
45 use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
46             $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
47          ];
48
49 $VERSION            = '0.60';
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
55 $_ALLOW_TAR_ITER        = 1;    # try to use Archive::Tar->iter if available
56
57 # same as all constants
58 my @Types           = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ );
59
60 local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
61
62 =pod
63
64 =head1 NAME
65
66 Archive::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?
98     $ae->is_lzma;   # is it a .lzma file?
99     $ae->is_xz;     # is it a .xz file?
100     $ae->is_txz;    # is it a .tar.xz or .txz file?
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
110     $ae->bin_unlzma  # path to /bin/unlzma if found
111     $ae->bin_unxz    # path to /bin/unxz if found
112
113 =head1 DESCRIPTION
114
115 Archive::Extract is a generic archive extraction mechanism.
116
117 It allows you to extract any archive file of the type .tar, .tar.gz,
118 .gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma
119 without having to worry how it
120 does so, or use different interfaces for each type by using either
121 perl modules, or commandline tools on your system.
122
123 See the C<HOW IT WORKS> section further down for details.
124
125 =cut
126
127
128 ### see what /bin/programs are available ###
129 $PROGRAMS = {};
130 CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) {
131     if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) {
132       local $IPC::Cmd::INSTANCES = 1;
133       ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm);
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;
142     }
143     $PROGRAMS->{$pgm} = can_run($pgm);
144 }
145
146 ### mapping from types to extractor methods ###
147 my $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'  },
156     is_xz   => { bin => '_unxz_bin',        pp => '_unxz_cz'    },
157     is_txz  => { bin => '_untar_bin',       pp => '_untar_at'   },
158 };
159
160 {   ### use subs so we re-generate array refs etc for the no-override flags
161     ### if we don't, then we reuse the same arrayref, meaning objects store
162     ### previous errors
163     my $tmpl = {
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 => [] }        },
168     };
169
170     ### build accessors ###
171     for my $method( keys %$tmpl,
172                     qw[_extractor _gunzip_to files extract_path],
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
186 Creates a new C<Archive::Extract> object based on the archive file you
187 passed it. Automatically determines the type of archive based on the
188 extension, but you can override that by explicitly providing the
189 C<type> argument.
190
191 Valid values for C<type> are:
192
193 =over 4
194
195 =item tar
196
197 Standard tar files, as produced by, for example, C</bin/tar>.
198 Corresponds to a C<.tar> suffix.
199
200 =item tgz
201
202 Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
203 Corresponds to a C<.tgz> or C<.tar.gz> suffix.
204
205 =item gz
206
207 Gzip compressed file, as produced by, for example C</bin/gzip>.
208 Corresponds to a C<.gz> suffix.
209
210 =item Z
211
212 Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
213 Corresponds to a C<.Z> suffix.
214
215 =item zip
216
217 Zip compressed file, as produced by, for example C</bin/zip>.
218 Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
219
220 =item bz2
221
222 Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
223 Corresponds to a C<.bz2> suffix.
224
225 =item tbz
226
227 Bzip2 compressed tar file, as produced by, for example C</bin/tar -j>.
228 Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
229
230 =item lzma
231
232 Lzma compressed file, as produced by C</bin/lzma>.
233 Corresponds to a C<.lzma> suffix.
234
235 =item xz
236
237 Xz compressed file, as produced by C</bin/xz>.
238 Corresponds to a C<.xz> suffix.
239
240 =item txz
241
242 Xz compressed tar file, as produced by, for example C</bin/tar -J>.
243 Corresponds to a C<.txz> or C<.tar.xz> suffix.
244
245 =back
246
247 Returns 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    = @_;
255
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;
259
260         my $parsed = check( \%utmpl, \%hash ) or return;
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} =
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    :
278                 '';
279
280         }
281
282         bless $parsed, $class;
283
284         ### don't know what type of file it is
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;
289     }
290 }
291
292 =head2 $ae->extract( [to => '/output/path'] )
293
294 Extracts the archive represented by the C<Archive::Extract> object to
295 the path of your choice as specified by the C<to> argument. Defaults to
296 C<cwd()>.
297
298 Since C<.gz> files never hold a directory, but only a single file; if
299 the C<to> argument is an existing directory, the file is extracted
300 there, with its C<.gz> suffix stripped.
301 If the C<to> argument is not an existing directory, the C<to> argument
302 is understood to be a filename, if the archive type is C<gz>.
303 In the case that you did not specify a C<to> argument, the output
304 file will be the name of the archive file, stripped from its C<.gz>
305 suffix, in the current working directory.
306
307 C<extract> will try a pure perl solution first, and then fall back to
308 commandline tools if they are available. See the C<GLOBAL VARIABLES>
309 section below on how to alter this behaviour.
310
311 It will return true on success, and false on failure.
312
313 On success, it will also set the follow attributes in the object:
314
315 =over 4
316
317 =item $ae->extract_path
318
319 This is the directory that the files where extracted to.
320
321 =item $ae->files
322
323 This is an array ref with the paths of all the files in the archive,
324 relative to the C<to> argument you specified.
325 To get the full path to an extracted file, you would use:
326
327     File::Spec->catfile( $to, $ae->files->[0] );
328
329 Note that all files from a tar archive will be in unix format, as per
330 the tar specification.
331
332 =back
333
334 =cut
335
336 sub extract {
337     my $self = shift;
338     my %hash = @_;
339
340     ### reset error messages
341     $self->_error_msg( [] );
342     $self->_error_msg_long( [] );
343
344     my $to;
345     my $tmpl = {
346         to  => { default => '.', store => \$to }
347     };
348
349     check( $tmpl, \%hash ) or return;
350
351     ### so 'to' could be a file or a dir, depending on whether it's a .gz
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
358         if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) {
359
360             my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i;
361
362             ### to is a dir?
363             if ( -d $to ) {
364                 $dir = $to;
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
405         ### find out the dispatch methods needed for this type of
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;
409
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;
414
415         ### reverse it if we prefer bin extractors
416         @methods = reverse @methods if $PREFER_BIN;
417
418         my($na, $fail);
419         for my $method (@methods) {
420             $self->debug( "# Extracting with ->$method\n" );
421
422             my $rv = $self->$method;
423
424             ### a positive extraction
425             if( $rv and $rv ne METHOD_NA ) {
426                 $self->debug( "# Extraction succeeded\n" );
427                 $self->_extractor($method);
428                 last;
429
430             ### method is not available
431             } elsif ( $rv and $rv eq METHOD_NA ) {
432                 $self->debug( "# Extraction method not available\n" );
433                 $na++;
434             } else {
435                 $self->debug( "# Extraction method failed\n" );
436                 $fail++;
437             }
438         }
439
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                        '';
445
446             $self->_error($diag);
447             $ok = 0;
448         }
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
466 Returns the last encountered error as string.
467 Pass it a true value to get the C<Carp::longmess()> output instead.
468
469 =head2 $ae->extract_path
470
471 This is the directory the archive got extracted to.
472 See C<extract()> for details.
473
474 =head2 $ae->files
475
476 This is an array ref holding all the paths from the archive.
477 See C<extract()> for details.
478
479 =head2 $ae->archive
480
481 This is the full path to the archive file represented by this
482 C<Archive::Extract> object.
483
484 =head2 $ae->type
485
486 This is the type of archive represented by this C<Archive::Extract>
487 object. See accessors below for an easier way to use this.
488 See the C<new()> method for details.
489
490 =head2 $ae->types
491
492 Returns a list of all known C<types> for C<Archive::Extract>'s
493 C<new> method.
494
495 =cut
496
497 sub types { return @Types }
498
499 =head2 $ae->is_tgz
500
501 Returns true if the file is of type C<.tar.gz>.
502 See the C<new()> method for details.
503
504 =head2 $ae->is_tar
505
506 Returns true if the file is of type C<.tar>.
507 See the C<new()> method for details.
508
509 =head2 $ae->is_gz
510
511 Returns true if the file is of type C<.gz>.
512 See the C<new()> method for details.
513
514 =head2 $ae->is_Z
515
516 Returns true if the file is of type C<.Z>.
517 See the C<new()> method for details.
518
519 =head2 $ae->is_zip
520
521 Returns true if the file is of type C<.zip>.
522 See the C<new()> method for details.
523
524 =head2 $ae->is_lzma
525
526 Returns true if the file is of type C<.lzma>.
527 See the C<new()> method for details.
528
529 =head2 $ae->is_xz
530
531 Returns true if the file is of type C<.xz>.
532 See the C<new()> method for details.
533
534 =cut
535
536 ### quick check methods ###
537 sub is_tgz  { return $_[0]->type eq TGZ }
538 sub is_tar  { return $_[0]->type eq TAR }
539 sub is_gz   { return $_[0]->type eq GZ  }
540 sub is_zip  { return $_[0]->type eq ZIP }
541 sub is_tbz  { return $_[0]->type eq TBZ }
542 sub is_bz2  { return $_[0]->type eq BZ2 }
543 sub is_Z    { return $_[0]->type eq Z   }
544 sub is_lzma { return $_[0]->type eq LZMA }
545 sub is_xz   { return $_[0]->type eq XZ   }
546 sub is_txz  { return $_[0]->type eq TXZ }
547
548 =pod
549
550 =head2 $ae->bin_tar
551
552 Returns the full path to your tar binary, if found.
553
554 =head2 $ae->bin_gzip
555
556 Returns the full path to your gzip binary, if found
557
558 =head2 $ae->bin_unzip
559
560 Returns the full path to your unzip binary, if found
561
562 =head2 $ae->bin_unlzma
563
564 Returns the full path to your unlzma binary, if found
565
566 =head2 $ae->bin_unxz
567
568 Returns the full path to your unxz binary, if found
569
570 =cut
571
572 ### paths to commandline tools ###
573 sub bin_gzip        { return $PROGRAMS->{'gzip'}    if $PROGRAMS->{'gzip'}  }
574 sub bin_unzip       { return $PROGRAMS->{'unzip'}   if $PROGRAMS->{'unzip'} }
575 sub bin_tar         { return $PROGRAMS->{'tar'}     if $PROGRAMS->{'tar'}   }
576 sub bin_bunzip2     { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
577 sub bin_uncompress  { return $PROGRAMS->{'uncompress'}
578                                                  if $PROGRAMS->{'uncompress'} }
579 sub bin_unlzma      { return $PROGRAMS->{'unlzma'}  if $PROGRAMS->{'unlzma'} }
580 sub bin_unxz        { return $PROGRAMS->{'unxz'}    if $PROGRAMS->{'unxz'} }
581
582 =head2 $bool = $ae->have_old_bunzip2
583
584 Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
585 require all archive names to end in C<.bz2> or it will not extract
586 them. This method checks if you have a recent version of C<bunzip2>
587 that allows any extension, or an older one that doesn't.
588
589 =cut
590
591 sub have_old_bunzip2 {
592     my $self = shift;
593
594     ### no bunzip2? no old bunzip2 either :)
595     return unless $self->bin_bunzip2;
596
597     ### if we can't run this, we can't be sure if it's too old or not
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!
608
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,
612     ### just so it wont try to read from stdin to print its version..
613     ### *sigh*
614     ### Even if the file exists, it won't clobber or change it.
615     my $buffer;
616     scalar run(
617          command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
618          verbose => 0,
619          buffer  => \$buffer
620     );
621
622     ### no output
623     return unless $buffer;
624
625     my ($version) = $buffer =~ /version \s+ (\d+)/ix;
626
627     return 1 if $version < 1;
628     return;
629 }
630
631 #################################
632 #
633 # Untar code
634 #
635 #################################
636
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 ) {
644
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;
647     }
648
649
650     ### use /bin/tar to extract ###
651     sub _untar_bin {
652         my $self = shift;
653
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
657         {   my $diag =  not $self->bin_tar ?
658                             loc("No '%1' program found", '/bin/tar') :
659                         $self->is_tgz && !$self->bin_gzip ?
660                             loc("No '%1' program found", '/bin/gzip') :
661                         $self->is_tbz && !$self->bin_bunzip2 ?
662                             loc("No '%1' program found", '/bin/bunzip2') :
663                         $self->is_txz && !$self->bin_unxz ?
664                             loc("No '%1' program found", '/bin/unxz') :
665                         '';
666
667             if( $diag ) {
668                 $self->_error( $diag );
669                 return METHOD_NA;
670             }
671         }
672
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.
676
677         ### see what command we should run, based on whether
678         ### it's a .tgz or .tar
679
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
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
687         {    my $cmd =
688                 $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
689                                  $self->bin_tar, '-tf', '-'] :
690                 $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
691                                  $self->bin_tar, '-tf', '-'] :
692                 $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
693                                  $self->bin_tar, '-tf', '-'] :
694                 [$self->bin_tar, @ExtraTarFlags, '-tf', $archive];
695
696             ### run the command
697             ### newer versions of 'tar' (1.21 and up) now print record size
698             ### to STDERR as well if v OR t is given (used to be both). This
699             ### is a 'feature' according to the changelog, so we must now only
700             ### inspect STDOUT, otherwise, failures like these occur:
701             ### http://www.cpantesters.org/cpan/report/3230366
702             my $buffer  = '';
703             my @out     = run(  command => $cmd,
704                                 buffer  => \$buffer,
705                                 verbose => $DEBUG );
706
707             ### command was unsuccessful
708             unless( $out[0] ) {
709                 return $self->_error(loc(
710                                 "Error listing contents of archive '%1': %2",
711                                 $archive, $buffer ));
712             }
713
714             ### no buffers available?
715             if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
716                 $self->_error( $self->_no_buffer_files( $archive ) );
717
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 : $_);
730
731                         ### only STDOUT, see above. Sometimes, extra whitespace
732                         ### is present, so make sure we only pick lines with
733                         ### a length
734                         } grep { length } map { split $/, $_ } join '', @{$out[3]};
735
736                 ### store the files that are in the archive ###
737                 $self->files(\@files);
738             }
739         }
740
741         ### now actually extract it ###
742         {   my $cmd =
743                 $self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
744                                  $self->bin_tar, '-xf', '-'] :
745                 $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|',
746                                  $self->bin_tar, '-xf', '-'] :
747                 $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|',
748                                  $self->bin_tar, '-xf', '-'] :
749                 [$self->bin_tar, @ExtraTarFlags, '-xf', $archive];
750
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",
757                                 $archive, $buffer ));
758             }
759
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 );
764
765                 ### store the extraction dir ###
766                 $self->extract_path( $dir );
767             }
768         }
769
770         ### we got here, no error happened
771         return 1;
772     }
773 }
774
775
776 ### use archive::tar to extract ###
777 sub _untar_at {
778     my $self = shift;
779
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;
788
789     ### we definitely need Archive::Tar, so load that first
790     {   my $use_list = { 'Archive::Tar' => '0.0' };
791
792         unless( can_load( modules => $use_list ) ) {
793
794             $self->_error(loc("You do not have '%1' installed - " .
795                               "Please install it as soon as possible.",
796                               'Archive::Tar'));
797
798             return METHOD_NA;
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
815             $self->_error(loc(
816                 "You do not have '%1' installed - Please ".
817                 "install it as soon as possible.", $which)
818             );
819
820             return METHOD_NA;
821         }
822
823     } elsif ( $self->is_tbz ) {
824         my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
825         unless( can_load( modules => $use_list ) ) {
826             $self->_error(loc(
827                 "You do not have '%1' installed - Please " .
828                 "install it as soon as possible.",
829                 'IO::Uncompress::Bunzip2')
830             );
831
832             return METHOD_NA;
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;
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 " .
846                 "install it as soon as possible.",
847                 'IO::Uncompress::UnXz')
848             );
849
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;
859     }
860
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;
866
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 ) );
870
871         ### for version of Archive::Tar > 1.04
872         local $Archive::Tar::CHOWN = 0;
873
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' ) ) {
876
877             my $next;
878             unless ( $next = Archive::Tar->iter( @read ) ) {
879                 return $self->_error(loc(
880                             "Unable to read '%1': %2", $self->archive,
881                             $Archive::Tar::error));
882             }
883
884             while ( my $file = $next->() ) {
885                 push @files, $file->full_path;
886
887                 $file->extract or return $self->_error(loc(
888                         "Unable to read '%1': %2",
889                         $self->archive,
890                         $Archive::Tar::error));
891             }
892
893         ### older version, read the archive into memory
894         } else {
895
896             my $tar = Archive::Tar->new();
897
898             unless( $tar->read( @read ) ) {
899                 return $self->_error(loc("Unable to read '%1': %2",
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
915                 ### older archive::tar always returns $self, return value
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         }
924     }
925
926     my $dir = $self->__get_extract_dir( \@files );
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
948 sub _gunzip_bin {
949     my $self = shift;
950
951     ### check for /bin/gzip -- we need it ###
952     unless( $self->bin_gzip ) {
953         $self->_error(loc("No '%1' program found", '/bin/gzip'));
954         return METHOD_NA;
955     }
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
977     $self->_print($fh, $buffer) if defined $buffer;
978
979     close $fh;
980
981     ### set what files where extract, and where they went ###
982     $self->files( [$self->_gunzip_to] );
983     $self->extract_path( File::Spec->rel2abs(cwd()) );
984
985     return 1;
986 }
987
988 sub _gunzip_cz {
989     my $self = shift;
990
991     my $use_list = { 'Compress::Zlib' => '0.0' };
992     unless( can_load( modules => $use_list ) ) {
993         $self->_error(loc("You do not have '%1' installed - Please " .
994                     "install it as soon as possible.", 'Compress::Zlib'));
995         return METHOD_NA;
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;
1007     $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0;
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 #
1019 # Uncompress code
1020 #
1021 #################################
1022
1023 sub _uncompress_bin {
1024     my $self = shift;
1025
1026     ### check for /bin/gzip -- we need it ###
1027     unless( $self->bin_uncompress ) {
1028         $self->_error(loc("No '%1' program found", '/bin/uncompress'));
1029         return METHOD_NA;
1030     }
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
1052     $self->_print($fh, $buffer) if defined $buffer;
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 #
1066 # Unzip code
1067 #
1068 #################################
1069
1070
1071 sub _unzip_bin {
1072     my $self = shift;
1073
1074     ### check for /bin/gzip if we need it ###
1075     unless( $self->bin_unzip ) {
1076         $self->_error(loc("No '%1' program found", '/bin/unzip'));
1077         return METHOD_NA;
1078     }
1079
1080     ### first, get the files.. it must be 2 different commands with 'unzip' :(
1081     {   ### on VMS, capital letter options have to be quoted. This is
1082         ### reported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
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 ];
1086
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 {
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";
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
1132 sub _unzip_az {
1133     my $self = shift;
1134
1135     my $use_list = { 'Archive::Zip' => '0.0' };
1136     unless( can_load( modules => $use_list ) ) {
1137         $self->_error(loc("You do not have '%1' installed - Please " .
1138                       "install it as soon as possible.", 'Archive::Zip'));
1139         return METHOD_NA;
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;
1149
1150
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.
1158     ###
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();
1165
1166     ### have to extract every member individually ###
1167     for my $member ($zip->members) {
1168         push @files, $member->{fileName};
1169
1170         ### file to extract to, to avoid the above problem
1171         my $to = File::Spec->catfile( $extract_dir, $member->{fileName} );
1172
1173         unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) {
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
1188 sub __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], '' )
1204                     : File::Spec->catdir( dirname( $files->[$pos] ) );
1205
1206         $$dir = $res;
1207     }
1208
1209     ### if the first and last dir don't match, make sure the
1210     ### dirname is not set wrongly
1211     my $dir;
1212
1213     ### dirs are the same, so we know for sure what the extract dir is
1214     if( $dir1 eq $dir2 ) {
1215         $dir = $dir1;
1216
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];
1222
1223         $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
1224     }
1225
1226     return File::Spec->rel2abs( $dir );
1227 }
1228
1229 #################################
1230 #
1231 # Bunzip2 code
1232 #
1233 #################################
1234
1235 sub _bunzip2_bin {
1236     my $self = shift;
1237
1238     ### check for /bin/gzip -- we need it ###
1239     unless( $self->bin_bunzip2 ) {
1240         $self->_error(loc("No '%1' program found", '/bin/bunzip2'));
1241         return METHOD_NA;
1242     }
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, $! ));
1247
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     }
1255
1256     my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ];
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     }
1271
1272     $self->_print($fh, $buffer) if defined $buffer;
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;
1287 #
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 #     }
1294 #
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));
1299 #
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, $! ));
1303 #
1304 #     my $buffer;
1305 #     $fh->print($buffer) while $bz->read($buffer) > 0;
1306 #     $fh->close;
1307 #
1308 #     ### set what files where extract, and where they went ###
1309 #     $self->files( [$self->_gunzip_to] );
1310 #     $self->extract_path( File::Spec->rel2abs(cwd()) );
1311 #
1312 #     return 1;
1313 # }
1314
1315 sub _bunzip2_bz2 {
1316     my $self = shift;
1317
1318     my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
1319     unless( can_load( modules => $use_list ) ) {
1320         $self->_error(loc("You do not have '%1' installed - Please " .
1321                           "install it as soon as possible.",
1322                           'IO::Uncompress::Bunzip2'));
1323         return METHOD_NA;
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
1338 #################################
1339 #
1340 # UnXz code
1341 #
1342 #################################
1343
1344 sub _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
1384 sub _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'));
1392         return METHOD_NA;
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
1407
1408 #################################
1409 #
1410 # unlzma code
1411 #
1412 #################################
1413
1414 sub _unlzma_bin {
1415     my $self = shift;
1416
1417     ### check for /bin/unlzma -- we need it ###
1418     unless( $self->bin_unlzma ) {
1419         $self->_error(loc("No '%1' program found", '/bin/unlzma'));
1420         return METHOD_NA;
1421     }
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
1443     $self->_print($fh, $buffer) if defined $buffer;
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
1454 sub _unlzma_cz {
1455     my $self = shift;
1456
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));
1465     }
1466     elsif (can_load( modules => $use_list2 ) ) {
1467
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, $! ));
1471
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         }
1478
1479         $self->_print($fh, $buffer) if defined $buffer;
1480
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'));
1486         return METHOD_NA;
1487     }
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 #
1498 # Error code
1499 #
1500 #################################
1501
1502 # For printing binaries that avoids interfering globals
1503 sub _print {
1504     my $self = shift;
1505     my $fh = shift;
1506
1507     local( $\, $", $, ) = ( undef, ' ', '' );
1508     return print $fh @_;
1509 }
1510
1511 sub _error {
1512     my $self    = shift;
1513     my $error   = shift;
1514     my $lerror  = Carp::longmess($error);
1515
1516     push @{$self->_error_msg},      $error;
1517     push @{$self->_error_msg_long}, $lerror;
1518
1519     ### set $Archive::Extract::WARN to 0 to disable printing
1520     ### of errors
1521     if( $WARN ) {
1522         carp $DEBUG ? $lerror : $error;
1523     }
1524
1525     return;
1526 }
1527
1528 sub error {
1529     my $self = shift;
1530
1531     ### make sure we have a fallback aref
1532     my $aref = do {
1533         shift()
1534             ? $self->_error_msg_long
1535             : $self->_error_msg
1536     } || [];
1537
1538     return join $/, @$aref;
1539 }
1540
1541 =head2 debug( MESSAGE )
1542
1543 This method outputs MESSAGE to the default filehandle if C<$DEBUG> is
1544 true. It's a small method, but it's here if you'd like to subclass it
1545 so you can so something else with any debugging output.
1546
1547 =cut
1548
1549 ### this is really a stub for subclassing
1550 sub debug {
1551     return unless $DEBUG;
1552
1553     print $_[1];
1554 }
1555
1556 sub _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
1563 sub _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 }
1568 1;
1569
1570 =pod
1571
1572 =head1 HOW IT WORKS
1573
1574 C<Archive::Extract> tries first to determine what type of archive you
1575 are passing it, by inspecting its suffix. It does not do this by using
1576 Mime magic, or something related. See C<CAVEATS> below.
1577
1578 Once it has determined the file type, it knows which extraction methods
1579 it can use on the archive. It will try a perl solution first, then fall
1580 back to a commandline tool if that fails. If that also fails, it will
1581 return false, indicating it was unable to extract the archive.
1582 See the section on C<GLOBAL VARIABLES> to see how to alter this order.
1583
1584 =head1 CAVEATS
1585
1586 =head2 File Extensions
1587
1588 C<Archive::Extract> trusts on the extension of the archive to determine
1589 what type it is, and what extractor methods therefore can be used. If
1590 your archives do not have any of the extensions as described in the
1591 C<new()> method, you will have to specify the type explicitly, or
1592 C<Archive::Extract> will not be able to extract the archive for you.
1593
1594 =head2 Supporting Very Large Files
1595
1596 C<Archive::Extract> can use either pure perl modules or command line
1597 programs under the hood. Some of the pure perl modules (like
1598 C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
1599 which may not be feasible on your system. Consider setting the global
1600 variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
1601 the use of command line programs and won't consume so much memory.
1602
1603 See the C<GLOBAL VARIABLES> section below for details.
1604
1605 =head2 Bunzip2 support of arbitrary extensions.
1606
1607 Older versions of C</bin/bunzip2> do not support arbitrary file
1608 extensions and insist on a C<.bz2> suffix. Although we do our best
1609 to guard against this, if you experience a bunzip2 error, it may
1610 be related to this. For details, please see the C<have_old_bunzip2>
1611 method.
1612
1613 =head1 GLOBAL VARIABLES
1614
1615 =head2 $Archive::Extract::DEBUG
1616
1617 Set this variable to C<true> to have all calls to command line tools
1618 be printed out, including all their output.
1619 This also enables C<Carp::longmess> errors, instead of the regular
1620 C<carp> errors.
1621
1622 Good for tracking down why things don't work with your particular
1623 setup.
1624
1625 Defaults to C<false>.
1626
1627 =head2 $Archive::Extract::WARN
1628
1629 This variable controls whether errors encountered internally by
1630 C<Archive::Extract> should be C<carp>'d or not.
1631
1632 Set to false to silence warnings. Inspect the output of the C<error()>
1633 method manually to see what went wrong.
1634
1635 Defaults to C<true>.
1636
1637 =head2 $Archive::Extract::PREFER_BIN
1638
1639 This variables controls whether C<Archive::Extract> should prefer the
1640 use of perl modules, or commandline tools to extract archives.
1641
1642 Set to C<true> to have C<Archive::Extract> prefer commandline tools.
1643
1644 Defaults to C<false>.
1645
1646 =head1 TODO / CAVEATS
1647
1648 =over 4
1649
1650 =item Mime magic support
1651
1652 Maybe this module should use something like C<File::Type> to determine
1653 the type, rather than blindly trust the suffix.
1654
1655 =item Thread safety
1656
1657 Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before
1658 extraction, and a C<chdir> back again after. This is not necessarily
1659 thread safe. See C<rt.cpan.org> bug C<#45671> for details.
1660
1661 =back
1662
1663 =head1 BUG REPORTS
1664
1665 Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>.
1666
1667 =head1 AUTHOR
1668
1669 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1670
1671 =head1 COPYRIGHT
1672
1673 This library is free software; you may redistribute and/or modify it
1674 under the same terms as Perl itself.
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