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