use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG];
-$VERSION = '0.22_01';
+$VERSION = '0.24';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
$ar =~ /.+?\.gz$/i ? GZ :
$ar =~ /.+?\.tar$/i ? TAR :
$ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
- $ar =~ /.+?\.(?:tbz|tar\.bz2?)$/i ? TBZ :
+ $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
$ar =~ /.+?\.bz2$/i ? BZ2 :
$ar =~ /.+?\.Z$/ ? Z :
'';
{ ### a foo.gz file
if( $self->is_gz or $self->is_bz2 or $self->is_Z) {
- my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2|Z)$//i;
+ my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z)$//i;
### to is a dir?
if ( -d $to ) {
sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
sub bin_uncompress { return $PROGRAMS->{'uncompress'}
if $PROGRAMS->{'uncompress'} }
+=head2 $bool = $ae->have_old_bunzip2
+
+Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
+require all archive names to end in C<.bz2> or it will not extract
+them. This method checks if you have a recent version of C<bunzip2>
+that allows any extension, or an older one that doesn't.
+
+=cut
+
+sub have_old_bunzip2 {
+ my $self = shift;
+
+ ### no bunzip2? no old bunzip2 either :)
+ return unless $self->bin_bunzip2;
+
+ ### if we can't run this, we can't be sure if it's too old or not
+ ### XXX stupid stupid stupid bunzip2 doesn't understand --version
+ ### is not a request to extract data:
+ ### $ bunzip2 --version
+ ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001.
+ ### [...]
+ ### bunzip2: I won't read compressed data from a terminal.
+ ### bunzip2: For help, type: `bunzip2 --help'.
+ ### $ echo $?
+ ### 1
+ ### HATEFUL!
+ my $buffer;
+ scalar run( command => [$self->bin_bunzip2, '--version'],
+ verbose => 0,
+ buffer => \$buffer
+ );
+
+ ### no output
+ return unless $buffer;
+
+ my ($version) = $buffer =~ /version \s+ (\d+)/ix;
+
+ return 1 if $version < 1;
+ return;
+}
#################################
#
{ my $cmd =
$self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
$self->bin_tar, '-tf', '-'] :
- $self->is_tbz ? [$self->bin_bunzip2, '-c', $self->archive, '|',
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
$self->bin_tar, '-tf', '-'] :
[$self->bin_tar, '-tf', $self->archive];
{ my $cmd =
$self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
$self->bin_tar, '-xf', '-'] :
- $self->is_tbz ? [$self->bin_bunzip2, '-c', $self->archive, '|',
+ $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
$self->bin_tar, '-xf', '-'] :
[$self->bin_tar, '-xf', $self->archive];
### first, get the files.. it must be 2 different commands with 'unzip' :(
- { my $cmd;
- if (ON_VMS) {
- $cmd = [ $self->bin_unzip, '"-Z"', '-1', $self->archive ];
- } else {
- $cmd = [ $self->bin_unzip, '-Z', '-1', $self->archive ];
- }
-
+ { ### on VMS, capital letter options have to be quoted. This is
+ ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11
+ ### Subject: [patch@31735]Archive Extract fix on VMS.
+ my $opt = ON_VMS ? '"-Z"' : '-Z';
+ my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ];
+
my $buffer = '';
unless( scalar run( command => $cmd,
verbose => $DEBUG,
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
$self->_gunzip_to, $! ));
+
+ ### guard against broken bunzip2. See ->have_old_bunzip2()
+ ### for details
+ if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) {
+ return $self->_error(loc("Your bunzip2 version is too old and ".
+ "can only extract files ending in '%1'",
+ '.bz2'));
+ }
- my $cmd = [ $self->bin_bunzip2, '-c', $self->archive ];
+ my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ];
my $buffer;
unless( scalar run( command => $cmd,
C<new()> method, you will have to specify the type explicitly, or
C<Archive::Extract> will not be able to extract the archive for you.
+=head2 Supporting Very Large Files
+
+C<Archive::Extract> can use either pure perl modules or command line
+programs under the hood. Some of the pure perl modules (like
+C<Archive::Tar> take the entire contents of the archive into memory,
+which may not be feasible on your system. Consider setting the global
+variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
+the use of command line programs and won't consume so much memory.
+
+See the C<GLOBAL VARIABLES> section below for details.
+
+=head2 Bunzip2 support of arbitrary extensions.
+
+Older versions of C</bin/bunzip2> do not support arbitrary file
+extensions and insist on a C<.bz2> suffix. Although we do our best
+to guard against this, if you experience a bunzip2 error, it may
+be related to this. For details, please see the C<have_old_bunzip2>
+method.
+
=head1 GLOBAL VARIABLES
=head2 $Archive::Extract::DEBUG
BEGIN { chdir 't' if -d 't' };
BEGIN { mkdir 'out' unless -d 'out' };
-END { rmtree('out') };
+
+### left behind, at least on Win32. See core patch #31904
+END { rmtree('out') };
use strict;
use lib qw[../lib];
},
};
+### XXX special case: on older solaris boxes (8),
+### bunzip2 is version 0.9.x. Older versions (pre 1),
+### only extract files that end in .bz2, and nothing
+### else. So remove that test case if we have an older
+### bunzip2 :(
+{ if( $Class->have_old_bunzip2 ) {
+ delete $tmpl->{'y.tbz'};
+ diag "Old bunzip2 detected, skipping .tbz test";
+ }
+}
+
### show us the tools IPC::Cmd will use to run binary programs
if( $Debug ) {
diag( "IPC::Run enabled: $IPC::Cmd::USE_IPC_RUN " );
skip "No binaries or modules to extract ".$archive,
(10 * scalar @outs) if $mod_fail && $pgm_fail;
-
### we dont warnings spewed about missing modules, that might
### be a problem...
local $IPC::Cmd::WARN = 0;
### if something went wrong with determining the out
### path, don't go deleting stuff.. might be Really Bad
my $out_re = quotemeta( $OutDir );
- $out_re =~ s/\\(>|\])\z// if IS_VMS; # zap trailing bracket
-
+
+ ### VMS directory layout is different. Craig Berry
+ ### explains:
+ ### the test is trying to determine if C</disk1/foo/bar>
+ ### is part of C</disk1/foo/bar/baz>. Except in VMS
+ ### syntax, that would mean trying to determine whether
+ ### C<disk1:[foo.bar]> is part of C<disk1:[foo.bar.baz]>
+ ### Because we have both a directory delimiter
+ ### (dot) and a directory spec terminator (right
+ ### bracket), we have to trim the right bracket from
+ ### the first one to make it successfully match the
+ ### second one. Since we're asserting the same truth --
+ ### that one path spec is the leading part of the other
+ ### -- it seems to me ok to have this in the test only.
+ ###
+ ### so we strip the ']' of the back of the regex
+ $out_re =~ s/\\\]// if IS_VMS;
+
if( $ae->extract_path !~ /^$out_re/ ) {
ok( 0, "Extractpath WRONG (".$ae->extract_path.")");
skip( "Unsafe operation -- skip cleanup!!!" ), 1;
uupacktool.pl -p lib/Archive/Extract/t/src/double_dir.zip lib/Archive/Extract/t/src/double_dir.zip.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H``````&QH,S0````````````````%`!4`>"]Y+WI55`D``PR`ST,,
uupacktool.pl -p lib/Archive/Extract/t/src/x.Z lib/Archive/Extract/t/src/x.Z.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
''YV0>`(J````
uupacktool.pl -p lib/Archive/Extract/t/src/x.bz2 lib/Archive/Extract/t/src/x.bz2.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
.0EIH.1=R13A0D```````
uupacktool.pl -p lib/Archive/Extract/t/src/x.gz lib/Archive/Extract/t/src/x.gz.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
6'XL("+F;6D8``W@``P``````````````
uupacktool.pl -p lib/Archive/Extract/t/src/x.jar lib/Archive/Extract/t/src/x.jar.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4!
uupacktool.pl -p lib/Archive/Extract/t/src/x.par lib/Archive/Extract/t/src/x.par.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4!
uupacktool.pl -p lib/Archive/Extract/t/src/x.tar.gz lib/Archive/Extract/t/src/x.tar.gz.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M'XL(`````````^W.NPW"0!!%T2EE2YC%:[N>#7""1,"G?QM##!&.SDE&(]W@
uupacktool.pl -p lib/Archive/Extract/t/src/x.tar lib/Archive/Extract/t/src/x.tar.packed
-Created at Mon May 28 12:45:26 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M80``````````````````````````````````````````````````````````
uupacktool.pl -p lib/Archive/Extract/t/src/x.tgz lib/Archive/Extract/t/src/x.tgz.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M'XL(`````````^W.NPW"0!!%T2EE2YC%:[N>#7""1,"G?QM##!&.SDE&(]W@
uupacktool.pl -p lib/Archive/Extract/t/src/x.zip lib/Archive/Extract/t/src/x.zip.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H```````MAQ3`````````````````!`!``8558#`!)`B%!EIO!0/4!
uupacktool.pl -p lib/Archive/Extract/t/src/y.jar lib/Archive/Extract/t/src/y.jar.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H``````,NBB#$````````````````"`!``>2]56`P`M%6W06Y4MT'U
uupacktool.pl -p lib/Archive/Extract/t/src/y.par lib/Archive/Extract/t/src/y.par.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M4$L#!`H``````,NBB#$````````````````"`!``>2]56`P`M%6W06Y4MT'U
uupacktool.pl -p lib/Archive/Extract/t/src/y.tar.bz2 lib/Archive/Extract/t/src/y.tar.bz2.packed
-Created at Mon May 28 12:45:28 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M0EIH.3%!6293636W".T``+)[E,B``$!``/>```-B"1XP!```0``((`"2A*4]
uupacktool.pl -p lib/Archive/Extract/t/src/y.tar.gz lib/Archive/Extract/t/src/y.tar.gz.packed
-Created at Mon May 28 12:45:28 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M'XL(`````````^W1,0Z#,`R%81\E-R"F><EY&,I2J4.!`4Y?JH@5J4,JH?[?
uupacktool.pl -p lib/Archive/Extract/t/src/y.tar lib/Archive/Extract/t/src/y.tar.packed
-Created at Mon May 28 12:45:27 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M>2\`````````````````````````````````````````````````````````
uupacktool.pl -p lib/Archive/Extract/t/src/y.tbz lib/Archive/Extract/t/src/y.tbz.packed
-Created at Mon May 28 12:45:28 2007
+Created at Thu Sep 20 15:38:01 2007
#########################################################################
__UU__
M0EIH.3%!6293636W".T``+)[E,B``$!``/>```-B"1XP!```0``((`"2A*4]
uupacktool.pl -p lib/Archive/Extract/t/src/y.tgz lib/Archive/Extract/t/src/y.tgz.packed
-Created at Mon May 28 12:45:28 2007
+Created at Thu Sep 20 15:38:02 2007
#########################################################################
__UU__
M'XL(`````````^W1,0Z#,`R%81\E-R"F><EY&,I2J4.!`4Y?JH@5J4,JH?[?
uupacktool.pl -p lib/Archive/Extract/t/src/y.zip lib/Archive/Extract/t/src/y.zip.packed
-Created at Mon May 28 12:45:28 2007
+Created at Thu Sep 20 15:38:02 2007
#########################################################################
__UU__
M4$L#!`H``````,NBB#$````````````````"`!``>2]56`P`M%6W06Y4MT'U
projects / p5sagit/p5-mst-13.2.git / commitdiff