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