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