1 package Archive::Extract;
7 use IPC::Cmd qw[run can_run];
9 use File::Path qw[mkpath];
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';
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 };
20 ### If these are changed, update @TYPES and the new() POD
21 use constant TGZ => 'tgz';
22 use constant TAR => 'tar';
23 use constant GZ => 'gz';
24 use constant ZIP => 'zip';
25 use constant BZ2 => 'bz2';
26 use constant TBZ => 'tbz';
27 use constant Z => 'Z';
29 use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG];
35 my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z ); # same as all constants
37 local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
43 Archive::Extract - A generic archive extracting mechanism
49 ### build an Archive::Extract object ###
50 my $ae = Archive::Extract->new( archive => 'foo.tgz' );
52 ### extract to cwd() ###
53 my $ok = $ae->extract;
55 ### extract to /tmp ###
56 my $ok = $ae->extract( to => '/tmp' );
58 ### what if something went wrong?
59 my $ok = $ae->extract or die $ae->error;
61 ### files from the archive ###
62 my $files = $ae->files;
64 ### dir that was extracted to ###
65 my $outdir = $ae->extract_path;
68 ### quick check methods ###
69 $ae->is_tar # is it a .tar file?
70 $ae->is_tgz # is it a .tar.gz or .tgz file?
71 $ae->is_gz; # is it a .gz file?
72 $ae->is_zip; # is it a .zip file?
73 $ae->is_bz2; # is it a .bz2 file?
74 $ae->is_tbz; # is it a .tar.bz2 or .tbz file?
76 ### absolute path to the archive you provided ###
79 ### commandline tools, if found ###
80 $ae->bin_tar # path to /bin/tar, if found
81 $ae->bin_gzip # path to /bin/gzip, if found
82 $ae->bin_unzip # path to /bin/unzip, if found
83 $ae->bin_bunzip2 # path to /bin/bunzip2 if found
87 Archive::Extract is a generic archive extraction mechanism.
89 It allows you to extract any archive file of the type .tar, .tar.gz,
90 .gz, .Z, tar.bz2, .tbz, .bz2 or .zip without having to worry how it
91 does so, or use different interfaces for each type by using either
92 perl modules, or commandline tools on your system.
94 See the C<HOW IT WORKS> section further down for details.
99 ### see what /bin/programs are available ###
101 for my $pgm (qw[tar unzip gzip bunzip2 uncompress]) {
102 $PROGRAMS->{$pgm} = can_run($pgm);
105 ### mapping from types to extractor methods ###
112 is_bz2 => '_bunzip2',
113 is_Z => '_uncompress',
118 archive => { required => 1, allow => FILE_EXISTS },
119 type => { default => '', allow => [ @Types ] },
122 ### build accesssors ###
123 for my $method( keys %$tmpl,
124 qw[_extractor _gunzip_to files extract_path],
125 qw[_error_msg _error_msg_long]
130 $self->{$method} = $_[0] if @_;
131 return $self->{$method};
137 =head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE])
139 Creates a new C<Archive::Extract> object based on the archive file you
140 passed it. Automatically determines the type of archive based on the
141 extension, but you can override that by explicitly providing the
144 Valid values for C<type> are:
150 Standard tar files, as produced by, for example, C</bin/tar>.
151 Corresponds to a C<.tar> suffix.
155 Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
156 Corresponds to a C<.tgz> or C<.tar.gz> suffix.
160 Gzip compressed file, as produced by, for example C</bin/gzip>.
161 Corresponds to a C<.gz> suffix.
165 Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
166 Corresponds to a C<.Z> suffix.
170 Zip compressed file, as produced by, for example C</bin/zip>.
171 Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
175 Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
176 Corresponds to a C<.bz2> suffix.
180 Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
181 Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
185 Returns a C<Archive::Extract> object on success, or false on failure.
194 my $parsed = check( $tmpl, \%hash ) or return;
196 ### make sure we have an absolute path ###
197 my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
199 ### figure out the type, if it wasn't already specified ###
200 unless ( $parsed->{type} ) {
202 $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
203 $ar =~ /.+?\.gz$/i ? GZ :
204 $ar =~ /.+?\.tar$/i ? TAR :
205 $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
206 $ar =~ /.+?\.(?:tbz|tar\.bz2?)$/i ? TBZ :
207 $ar =~ /.+?\.bz2$/i ? BZ2 :
208 $ar =~ /.+?\.Z$/ ? Z :
213 ### don't know what type of file it is ###
214 return __PACKAGE__->_error(loc("Cannot determine file type for '%1'",
215 $parsed->{archive} )) unless $parsed->{type};
217 return bless $parsed, $class;
221 =head2 $ae->extract( [to => '/output/path'] )
223 Extracts the archive represented by the C<Archive::Extract> object to
224 the path of your choice as specified by the C<to> argument. Defaults to
227 Since C<.gz> files never hold a directory, but only a single file; if
228 the C<to> argument is an existing directory, the file is extracted
229 there, with it's C<.gz> suffix stripped.
230 If the C<to> argument is not an existing directory, the C<to> argument
231 is understood to be a filename, if the archive type is C<gz>.
232 In the case that you did not specify a C<to> argument, the output
233 file will be the name of the archive file, stripped from it's C<.gz>
234 suffix, in the current working directory.
236 C<extract> will try a pure perl solution first, and then fall back to
237 commandline tools if they are available. See the C<GLOBAL VARIABLES>
238 section below on how to alter this behaviour.
240 It will return true on success, and false on failure.
242 On success, it will also set the follow attributes in the object:
246 =item $ae->extract_path
248 This is the directory that the files where extracted to.
252 This is an array ref with the paths of all the files in the archive,
253 relative to the C<to> argument you specified.
254 To get the full path to an extracted file, you would use:
256 File::Spec->catfile( $to, $ae->files->[0] );
258 Note that all files from a tar archive will be in unix format, as per
259 the tar specification.
271 to => { default => '.', store => \$to }
274 check( $tmpl, \%hash ) or return;
276 ### so 'to' could be a file or a dir, depending on whether it's a .gz
277 ### file, or basically anything else.
278 ### so, check that, then act accordingly.
279 ### set an accessor specifically so _gunzip can know what file to extract
283 if( $self->is_gz or $self->is_bz2 or $self->is_Z) {
285 my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2|Z)$//i;
290 $self->_gunzip_to( basename($cp) );
292 ### then it's a filename
295 $self->_gunzip_to( basename($to) );
298 ### not a foo.gz file
304 ### make the dir if it doesn't exist ###
306 eval { mkpath( $dir ) };
308 return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
312 ### get the current dir, to restore later ###
318 ### chdir to the target dir ###
319 unless( chdir $dir ) {
320 $self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
321 $ok = 0; last EXTRACT;
324 ### set files to an empty array ref, so there's always an array
325 ### ref IN the accessor, to avoid errors like:
326 ### Can't use an undefined value as an ARRAY reference at
327 ### ../lib/Archive/Extract.pm line 742. (rt #19815)
330 ### find what extractor method to use ###
331 while( my($type,$method) = each %$Mapping ) {
333 ### call the corresponding method if the type is OK ###
335 $ok = $self->$method();
339 ### warn something went wrong if we didn't get an OK ###
340 $self->_error(loc("Extract failed, no extractor found"))
345 ### and chdir back ###
346 unless( chdir $cwd ) {
347 $self->_error(loc("Could not chdir back to start dir '%1': %2'",
358 =head2 $ae->error([BOOL])
360 Returns the last encountered error as string.
361 Pass it a true value to get the C<Carp::longmess()> output instead.
363 =head2 $ae->extract_path
365 This is the directory the archive got extracted to.
366 See C<extract()> for details.
370 This is an array ref holding all the paths from the archive.
371 See C<extract()> for details.
375 This is the full path to the archive file represented by this
376 C<Archive::Extract> object.
380 This is the type of archive represented by this C<Archive::Extract>
381 object. See accessors below for an easier way to use this.
382 See the C<new()> method for details.
386 Returns a list of all known C<types> for C<Archive::Extract>'s
391 sub types { return @Types }
395 Returns true if the file is of type C<.tar.gz>.
396 See the C<new()> method for details.
400 Returns true if the file is of type C<.tar>.
401 See the C<new()> method for details.
405 Returns true if the file is of type C<.gz>.
406 See the C<new()> method for details.
410 Returns true if the file is of type C<.Z>.
411 See the C<new()> method for details.
415 Returns true if the file is of type C<.zip>.
416 See the C<new()> method for details.
420 ### quick check methods ###
421 sub is_tgz { return $_[0]->type eq TGZ }
422 sub is_tar { return $_[0]->type eq TAR }
423 sub is_gz { return $_[0]->type eq GZ }
424 sub is_zip { return $_[0]->type eq ZIP }
425 sub is_tbz { return $_[0]->type eq TBZ }
426 sub is_bz2 { return $_[0]->type eq BZ2 }
427 sub is_Z { return $_[0]->type eq Z }
433 Returns the full path to your tar binary, if found.
437 Returns the full path to your gzip binary, if found
439 =head2 $ae->bin_unzip
441 Returns the full path to your unzip binary, if found
445 ### paths to commandline tools ###
446 sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} }
447 sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} }
448 sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} }
449 sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
450 sub bin_uncompress { return $PROGRAMS->{'uncompress'}
451 if $PROGRAMS->{'uncompress'} }
453 #################################
457 #################################
460 ### untar wrapper... goes to either Archive::Tar or /bin/tar
461 ### depending on $PREFER_BIN
465 ### bzip2 support in A::T via IO::Uncompress::Bzip2
466 my @methods = qw[_untar_at _untar_bin];
467 @methods = reverse @methods if $PREFER_BIN;
469 for my $method (@methods) {
470 $self->_extractor($method) && return 1 if $self->$method();
473 return $self->_error(loc("Unable to untar file '%1'", $self->archive));
476 ### use /bin/tar to extract ###
480 ### check for /bin/tar ###
481 return $self->_error(loc("No '%1' program found", '/bin/tar'))
482 unless $self->bin_tar;
484 ### check for /bin/gzip if we need it ###
485 return $self->_error(loc("No '%1' program found", '/bin/gzip'))
486 if $self->is_tgz && !$self->bin_gzip;
488 return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
489 if $self->is_tbz && !$self->bin_bunzip2;
491 ### XXX figure out how to make IPC::Run do this in one call --
492 ### currently i don't know how to get output of a command after a pipe
493 ### trapped in a scalar. Mailed barries about this 5th of june 2004.
497 ### see what command we should run, based on whether
498 ### it's a .tgz or .tar
500 ### XXX solaris tar and bsdtar are having different outputs
501 ### depending whether you run with -x or -t
502 ### compensate for this insanity by running -t first, then -x
504 $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
505 $self->bin_tar, '-tf', '-'] :
506 $self->is_tbz ? [$self->bin_bunzip2, '-c', $self->archive, '|',
507 $self->bin_tar, '-tf', '-'] :
508 [$self->bin_tar, '-tf', $self->archive];
510 ### run the command ###
512 unless( scalar run( command => $cmd,
516 return $self->_error(loc(
517 "Error listing contents of archive '%1': %2",
518 $self->archive, $buffer ));
521 ### no buffers available?
522 if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
523 $self->_error( $self->_no_buffer_files( $self->archive ) );
526 ### if we're on solaris we /might/ be using /bin/tar, which has
527 ### a weird output format... we might also be using
528 ### /usr/local/bin/tar, which is gnu tar, which is perfectly
529 ### fine... so we have to do some guessing here =/
530 my @files = map { chomp;
532 : (m|^ x \s+ # 'xtract' -- sigh
533 (.+?), # the actual file name
534 \s+ [\d,.]+ \s bytes,
535 \s+ [\d,.]+ \s tape \s blocks
540 ### store the files that are in the archive ###
541 $self->files(\@files);
545 ### now actually extract it ###
547 $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
548 $self->bin_tar, '-xf', '-'] :
549 $self->is_tbz ? [$self->bin_bunzip2, '-c', $self->archive, '|',
550 $self->bin_tar, '-xf', '-'] :
551 [$self->bin_tar, '-xf', $self->archive];
554 unless( scalar run( command => $cmd,
558 return $self->_error(loc("Error extracting archive '%1': %2",
559 $self->archive, $buffer ));
562 ### we might not have them, due to lack of buffers
564 ### now that we've extracted, figure out where we extracted to
565 my $dir = $self->__get_extract_dir( $self->files );
567 ### store the extraction dir ###
568 $self->extract_path( $dir );
572 ### we got here, no error happened
576 ### use archive::tar to extract ###
580 ### we definitely need A::T, so load that first
581 { my $use_list = { 'Archive::Tar' => '0.0' };
583 unless( can_load( modules => $use_list ) ) {
585 return $self->_error(loc("You do not have '%1' installed - " .
586 "Please install it as soon as possible.",
591 ### we might pass it a filehandle if it's a .tbz file..
592 my $fh_to_read = $self->archive;
594 ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
595 ### if A::T's version is 0.99 or higher
596 if( $self->is_tgz ) {
597 my $use_list = { 'Compress::Zlib' => '0.0' };
598 $use_list->{ 'IO::Zlib' } = '0.0'
599 if $Archive::Tar::VERSION >= '0.99';
601 unless( can_load( modules => $use_list ) ) {
602 my $which = join '/', sort keys %$use_list;
604 return $self->_error(loc(
605 "You do not have '%1' installed - Please ".
606 "install it as soon as possible.", $which));
609 } elsif ( $self->is_tbz ) {
610 my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
611 unless( can_load( modules => $use_list ) ) {
612 return $self->_error(loc(
613 "You do not have '%1' installed - Please " .
614 "install it as soon as possible.",
615 'IO::Uncompress::Bunzip2'));
618 my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
619 return $self->_error(loc("Unable to open '%1': %2",
621 $IO::Uncompress::Bunzip2::Bunzip2Error));
626 my $tar = Archive::Tar->new();
628 ### only tell it it's compressed if it's a .tgz, as we give it a file
629 ### handle if it's a .tbz
630 unless( $tar->read( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ) ) {
631 return $self->_error(loc("Unable to read '%1': %2", $self->archive,
632 $Archive::Tar::error));
635 ### workaround to prevent Archive::Tar from setting uid, which
636 ### is a potential security hole. -autrijus
637 ### have to do it here, since A::T needs to be /loaded/ first ###
638 { no strict 'refs'; local $^W;
640 ### older versions of archive::tar <= 0.23
641 *Archive::Tar::chown = sub {};
644 ### for version of archive::tar > 1.04
645 local $Archive::Tar::Constant::CHOWN = 0;
647 { local $^W; # quell 'splice() offset past end of array' warnings
648 # on older versions of A::T
650 ### older archive::tar always returns $self, return value slightly
651 ### fux0r3d because of it.
653 or return $self->_error(loc("Unable to extract '%1': %2",
654 $self->archive, $Archive::Tar::error ));
657 my @files = $tar->list_files;
658 my $dir = $self->__get_extract_dir( \@files );
660 ### store the files that are in the archive ###
661 $self->files(\@files);
663 ### store the extraction dir ###
664 $self->extract_path( $dir );
666 ### check if the dir actually appeared ###
667 return 1 if -d $self->extract_path;
669 ### no dir, we failed ###
670 return $self->_error(loc("Unable to extract '%1': %2",
671 $self->archive, $Archive::Tar::error ));
674 #################################
678 #################################
680 ### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip
681 ### depending on $PREFER_BIN
685 my @methods = qw[_gunzip_cz _gunzip_bin];
686 @methods = reverse @methods if $PREFER_BIN;
688 for my $method (@methods) {
689 $self->_extractor($method) && return 1 if $self->$method();
692 return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
698 ### check for /bin/gzip -- we need it ###
699 return $self->_error(loc("No '%1' program found", '/bin/gzip'))
700 unless $self->bin_gzip;
703 my $fh = FileHandle->new('>'. $self->_gunzip_to) or
704 return $self->_error(loc("Could not open '%1' for writing: %2",
705 $self->_gunzip_to, $! ));
707 my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];
710 unless( scalar run( command => $cmd,
714 return $self->_error(loc("Unable to gunzip '%1': %2",
715 $self->archive, $buffer));
718 ### no buffers available?
719 if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
720 $self->_error( $self->_no_buffer_content( $self->archive ) );
723 print $fh $buffer if defined $buffer;
727 ### set what files where extract, and where they went ###
728 $self->files( [$self->_gunzip_to] );
729 $self->extract_path( File::Spec->rel2abs(cwd()) );
737 my $use_list = { 'Compress::Zlib' => '0.0' };
738 unless( can_load( modules => $use_list ) ) {
739 return $self->_error(loc("You do not have '%1' installed - Please " .
740 "install it as soon as possible.", 'Compress::Zlib'));
743 my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
744 return $self->_error(loc("Unable to open '%1': %2",
745 $self->archive, $Compress::Zlib::gzerrno));
747 my $fh = FileHandle->new('>'. $self->_gunzip_to) or
748 return $self->_error(loc("Could not open '%1' for writing: %2",
749 $self->_gunzip_to, $! ));
752 $fh->print($buffer) while $gz->gzread($buffer) > 0;
755 ### set what files where extract, and where they went ###
756 $self->files( [$self->_gunzip_to] );
757 $self->extract_path( File::Spec->rel2abs(cwd()) );
762 #################################
766 #################################
769 ### untar wrapper... goes to either Archive::Tar or /bin/tar
770 ### depending on $PREFER_BIN
774 my @methods = qw[_gunzip_cz _uncompress_bin];
775 @methods = reverse @methods if $PREFER_BIN;
777 for my $method (@methods) {
778 $self->_extractor($method) && return 1 if $self->$method();
781 return $self->_error(loc("Unable to untar file '%1'", $self->archive));
784 sub _uncompress_bin {
787 ### check for /bin/gzip -- we need it ###
788 return $self->_error(loc("No '%1' program found", '/bin/uncompress'))
789 unless $self->bin_uncompress;
792 my $fh = FileHandle->new('>'. $self->_gunzip_to) or
793 return $self->_error(loc("Could not open '%1' for writing: %2",
794 $self->_gunzip_to, $! ));
796 my $cmd = [ $self->bin_uncompress, '-c', $self->archive ];
799 unless( scalar run( command => $cmd,
803 return $self->_error(loc("Unable to uncompress '%1': %2",
804 $self->archive, $buffer));
807 ### no buffers available?
808 if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
809 $self->_error( $self->_no_buffer_content( $self->archive ) );
812 print $fh $buffer if defined $buffer;
816 ### set what files where extract, and where they went ###
817 $self->files( [$self->_gunzip_to] );
818 $self->extract_path( File::Spec->rel2abs(cwd()) );
824 #################################
828 #################################
830 ### unzip wrapper... goes to either Archive::Zip or /bin/unzip
831 ### depending on $PREFER_BIN
835 my @methods = qw[_unzip_az _unzip_bin];
836 @methods = reverse @methods if $PREFER_BIN;
838 for my $method (@methods) {
839 $self->_extractor($method) && return 1 if $self->$method();
842 return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
848 ### check for /bin/gzip if we need it ###
849 return $self->_error(loc("No '%1' program found", '/bin/unzip'))
850 unless $self->bin_unzip;
853 ### first, get the files.. it must be 2 different commands with 'unzip' :(
854 { my $cmd = [ $self->bin_unzip, '-Z', '-1', $self->archive ];
857 unless( scalar run( command => $cmd,
861 return $self->_error(loc("Unable to unzip '%1': %2",
862 $self->archive, $buffer));
865 ### no buffers available?
866 if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
867 $self->_error( $self->_no_buffer_files( $self->archive ) );
870 $self->files( [split $/, $buffer] );
874 ### now, extract the archive ###
875 { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ];
878 unless( scalar run( command => $cmd,
882 return $self->_error(loc("Unable to unzip '%1': %2",
883 $self->archive, $buffer));
886 if( scalar @{$self->files} ) {
887 my $files = $self->files;
888 my $dir = $self->__get_extract_dir( $files );
890 $self->extract_path( $dir );
900 my $use_list = { 'Archive::Zip' => '0.0' };
901 unless( can_load( modules => $use_list ) ) {
902 return $self->_error(loc("You do not have '%1' installed - Please " .
903 "install it as soon as possible.", 'Archive::Zip'));
906 my $zip = Archive::Zip->new();
908 unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) {
909 return $self->_error(loc("Unable to read '%1'", $self->archive));
913 ### have to extract every memeber individually ###
914 for my $member ($zip->members) {
915 push @files, $member->{fileName};
917 unless( $zip->extractMember($member) == &Archive::Zip::AZ_OK ) {
918 return $self->_error(loc("Extraction of '%1' from '%2' failed",
919 $member->{fileName}, $self->archive ));
923 my $dir = $self->__get_extract_dir( \@files );
925 ### set what files where extract, and where they went ###
926 $self->files( \@files );
927 $self->extract_path( File::Spec->rel2abs($dir) );
932 sub __get_extract_dir {
934 my $files = shift || [];
936 return unless scalar @$files;
939 for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) {
940 my($dir,$pos) = @$aref;
942 ### add a catdir(), so that any trailing slashes get
943 ### take care of (removed)
944 ### also, a catdir() normalises './dir/foo' to 'dir/foo';
945 ### which was the problem in bug #23999
946 my $res = -d $files->[$pos]
947 ? File::Spec->catdir( $files->[$pos], '' )
948 : File::Spec->catdir( dirname( $files->[$pos] ) );
953 ### if the first and last dir don't match, make sure the
954 ### dirname is not set wrongly
957 ### dirs are the same, so we know for sure what the extract dir is
958 if( $dir1 eq $dir2 ) {
961 ### dirs are different.. do they share the base dir?
962 ### if so, use that, if not, fall back to '.'
964 my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0];
965 my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0];
967 $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' );
970 return File::Spec->rel2abs( $dir );
973 #################################
977 #################################
979 ### bunzip2 wrapper...
983 my @methods = qw[_bunzip2_cz2 _bunzip2_bin];
984 @methods = reverse @methods if $PREFER_BIN;
986 for my $method (@methods) {
987 $self->_extractor($method) && return 1 if $self->$method();
990 return $self->_error(loc("Unable to bunzip2 file '%1'", $self->archive));
996 ### check for /bin/gzip -- we need it ###
997 return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
998 unless $self->bin_bunzip2;
1001 my $fh = FileHandle->new('>'. $self->_gunzip_to) or
1002 return $self->_error(loc("Could not open '%1' for writing: %2",
1003 $self->_gunzip_to, $! ));
1005 my $cmd = [ $self->bin_bunzip2, '-c', $self->archive ];
1008 unless( scalar run( command => $cmd,
1010 buffer => \$buffer )
1012 return $self->_error(loc("Unable to bunzip2 '%1': %2",
1013 $self->archive, $buffer));
1016 ### no buffers available?
1017 if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
1018 $self->_error( $self->_no_buffer_content( $self->archive ) );
1021 print $fh $buffer if defined $buffer;
1025 ### set what files where extract, and where they went ###
1026 $self->files( [$self->_gunzip_to] );
1027 $self->extract_path( File::Spec->rel2abs(cwd()) );
1032 ### using cz2, the compact versions... this we use mainly in archive::tar
1034 # sub _bunzip2_cz1 {
1037 # my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
1038 # unless( can_load( modules => $use_list ) ) {
1039 # return $self->_error(loc("You do not have '%1' installed - Please " .
1040 # "install it as soon as possible.",
1041 # 'IO::Uncompress::Bunzip2'));
1044 # my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
1045 # return $self->_error(loc("Unable to open '%1': %2",
1047 # $IO::Uncompress::Bunzip2::Bunzip2Error));
1049 # my $fh = FileHandle->new('>'. $self->_gunzip_to) or
1050 # return $self->_error(loc("Could not open '%1' for writing: %2",
1051 # $self->_gunzip_to, $! ));
1054 # $fh->print($buffer) while $bz->read($buffer) > 0;
1057 # ### set what files where extract, and where they went ###
1058 # $self->files( [$self->_gunzip_to] );
1059 # $self->extract_path( File::Spec->rel2abs(cwd()) );
1067 my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
1068 unless( can_load( modules => $use_list ) ) {
1069 return $self->_error(loc("You do not have '%1' installed - Please " .
1070 "install it as soon as possible.",
1071 'IO::Uncompress::Bunzip2'));
1074 IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
1075 or return $self->_error(loc("Unable to uncompress '%1': %2",
1077 $IO::Uncompress::Bunzip2::Bunzip2Error));
1079 ### set what files where extract, and where they went ###
1080 $self->files( [$self->_gunzip_to] );
1081 $self->extract_path( File::Spec->rel2abs(cwd()) );
1087 #################################
1091 #################################
1097 $self->_error_msg( $error );
1098 $self->_error_msg_long( Carp::longmess($error) );
1100 ### set $Archive::Extract::WARN to 0 to disable printing
1103 carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
1111 return shift() ? $self->_error_msg_long : $self->_error_msg;
1114 sub _no_buffer_files {
1116 my $file = shift or return;
1117 return loc("No buffer captured, unable to tell ".
1118 "extracted files or extraction dir for '%1'", $file);
1121 sub _no_buffer_content {
1123 my $file = shift or return;
1124 return loc("No buffer captured, unable to get content for '%1'", $file);
1132 C<Archive::Extract> tries first to determine what type of archive you
1133 are passing it, by inspecting its suffix. It does not do this by using
1134 Mime magic, or something related. See C<CAVEATS> below.
1136 Once it has determined the file type, it knows which extraction methods
1137 it can use on the archive. It will try a perl solution first, then fall
1138 back to a commandline tool if that fails. If that also fails, it will
1139 return false, indicating it was unable to extract the archive.
1140 See the section on C<GLOBAL VARIABLES> to see how to alter this order.
1144 =head2 File Extensions
1146 C<Archive::Extract> trusts on the extension of the archive to determine
1147 what type it is, and what extractor methods therefore can be used. If
1148 your archives do not have any of the extensions as described in the
1149 C<new()> method, you will have to specify the type explicitly, or
1150 C<Archive::Extract> will not be able to extract the archive for you.
1152 =head2 Bzip2 Support
1154 There's currently no very reliable pure perl Bzip2 implementation
1155 available, so C<Archive::Extract> can only extract C<bzip2>
1156 compressed archives if you have a C</bin/bunzip2> program.
1158 =head1 GLOBAL VARIABLES
1160 =head2 $Archive::Extract::DEBUG
1162 Set this variable to C<true> to have all calls to command line tools
1163 be printed out, including all their output.
1164 This also enables C<Carp::longmess> errors, instead of the regular
1167 Good for tracking down why things don't work with your particular
1170 Defaults to C<false>.
1172 =head2 $Archive::Extract::WARN
1174 This variable controls whether errors encountered internally by
1175 C<Archive::Extract> should be C<carp>'d or not.
1177 Set to false to silence warnings. Inspect the output of the C<error()>
1178 method manually to see what went wrong.
1180 Defaults to C<true>.
1182 =head2 $Archive::Extract::PREFER_BIN
1184 This variables controls whether C<Archive::Extract> should prefer the
1185 use of perl modules, or commandline tools to extract archives.
1187 Set to C<true> to have C<Archive::Extract> prefer commandline tools.
1189 Defaults to C<false>.
1195 =item Mime magic support
1197 Maybe this module should use something like C<File::Type> to determine
1198 the type, rather than blindly trust the suffix.
1204 Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>.
1208 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1212 This library is free software; you may redistribute and/or modify it
1213 under the same terms as Perl itself.
1218 # c-indentation-style: bsd
1220 # indent-tabs-mode: nil
1222 # vim: expandtab shiftwidth=4: