use constant LZMA => 'lzma';
use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
- $_ALLOW_BIN $_ALLOW_PURE_PERL
+ $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
];
-$VERSION = '0.32';
+$VERSION = '0.34';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
$_ALLOW_BIN = 1; # allow binary extractors
+$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available
# same as all constants
my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA );
$fh_to_read = $bz;
}
- ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
- ### localized $Archive::Tar::WARN already.
- $Archive::Tar::WARN = $Archive::Extract::WARN;
+ my @files;
+ {
+ ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
+ ### localized $Archive::Tar::WARN already.
+ $Archive::Tar::WARN = $Archive::Extract::WARN;
- my $tar = Archive::Tar->new();
+ ### only tell it it's compressed if it's a .tgz, as we give it a file
+ ### handle if it's a .tbz
+ my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );
- ### only tell it it's compressed if it's a .tgz, as we give it a file
- ### handle if it's a .tbz
- unless( $tar->read( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ) ) {
- return $self->_error(loc("Unable to read '%1': %2", $self->archive,
- $Archive::Tar::error));
- }
+ ### for version of Archive::Tar > 1.04
+ local $Archive::Tar::CHOWN = 0;
- ### workaround to prevent Archive::Tar from setting uid, which
- ### is a potential security hole. -autrijus
- ### have to do it here, since A::T needs to be /loaded/ first ###
- { no strict 'refs'; local $^W;
+ ### use the iterator if we can. it's a feature of A::T 1.40 and up
+ if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {
- ### older versions of archive::tar <= 0.23
- *Archive::Tar::chown = sub {};
- }
+ my $next;
+ unless ( $next = Archive::Tar->iter( @read ) ) {
+ return $self->_error(loc(
+ "Unable to read '%1': %2", $self->archive,
+ $Archive::Tar::error));
+ }
- ### for version of Archive::Tar > 1.04
- local $Archive::Tar::CHOWN = 0;
+ while ( my $file = $next->() ) {
+ push @files, $file->full_path;
- { local $^W; # quell 'splice() offset past end of array' warnings
- # on older versions of A::T
+ $file->extract or return $self->_error(loc(
+ "Unable to read '%1': %2",
+ $self->archive,
+ $Archive::Tar::error));
+ }
+
+ ### older version, read the archive into memory
+ } else {
- ### older archive::tar always returns $self, return value slightly
- ### fux0r3d because of it.
- $tar->extract()
- or return $self->_error(loc("Unable to extract '%1': %2",
- $self->archive, $Archive::Tar::error ));
+ my $tar = Archive::Tar->new();
+
+ unless( $tar->read( @read ) ) {
+ return $self->_error(loc("Unable to read '%1': %2",
+ $self->archive, $Archive::Tar::error));
+ }
+
+ ### workaround to prevent Archive::Tar from setting uid, which
+ ### is a potential security hole. -autrijus
+ ### have to do it here, since A::T needs to be /loaded/ first ###
+ { no strict 'refs'; local $^W;
+
+ ### older versions of archive::tar <= 0.23
+ *Archive::Tar::chown = sub {};
+ }
+
+ { local $^W; # quell 'splice() offset past end of array' warnings
+ # on older versions of A::T
+
+ ### older archive::tar always returns $self, return value
+ ### slightly fux0r3d because of it.
+ $tar->extract or return $self->_error(loc(
+ "Unable to extract '%1': %2",
+ $self->archive, $Archive::Tar::error ));
+ }
+
+ @files = $tar->list_files;
+ }
}
- my @files = $tar->list_files;
- my $dir = $self->__get_extract_dir( \@files );
+ my $dir = $self->__get_extract_dir( \@files );
### store the files that are in the archive ###
$self->files(\@files);
for my $archive (keys %$tmpl) {
- diag("Extracting $archive in config $cfg") if $Debug;
-
### check first if we can do the proper
my $ae = Archive::Extract->new(
archive => File::Spec->catfile($SrcDir,$archive) );
- isa_ok( $ae, $Class );
-
- my $method = $tmpl->{$archive}->{method};
- ok( $ae->$method(), "Archive type recognized properly" );
-
- ### 10 tests from here on down ###
- SKIP: {
- my $file = $tmpl->{$archive}->{outfile};
- my $dir = $tmpl->{$archive}->{outdir}; # can be undef
- my $rel_path = File::Spec->catfile( grep { defined } $dir, $file );
- my $abs_path = File::Spec->catfile( $OutDir, $rel_path );
- my $abs_dir = File::Spec->catdir(
- grep { defined } $OutDir, $dir );
- my $nix_path = File::Spec::Unix->catfile(
- grep { defined } $dir, $file );
-
- ### check if we can run this test ###
- my $pgm_fail; my $mod_fail;
- for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
- ### no binary extract method
- $pgm_fail++, next unless $pgm;
-
- ### we dont have the program
- $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
- $Archive::Extract::PROGRAMS->{$pgm};
-
- }
-
- for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
- ### no module extract method
- $mod_fail++, next unless $mod;
-
- ### we dont have the module
- $mod_fail++ unless check_install( module => $mod );
- }
-
- ### where to extract to -- try both dir and file for gz files
- ### XXX test me!
- #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
- my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma
- ? ($abs_path)
- : ($OutDir);
-
- skip "No binaries or modules to extract ".$archive,
- (10 * scalar @outs) if
- ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN)) ||
- ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL));
-
- ### we dont warnings spewed about missing modules, that might
- ### be a problem...
- local $IPC::Cmd::WARN = 0;
- local $IPC::Cmd::WARN = 0;
-
- for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
+ ### Do an extra run with _ALLOW_TAR_ITER = 0 if it's a tar file of some
+ ### sort
+ my @with_tar_iter = ( 1 );
+ push @with_tar_iter, 0 if grep { $ae->$_ } qw[is_tbz is_tgz is_tar];
- ### test buffers ###
- my $turn_off = !$use_buffer && !$pgm_fail &&
- $Archive::Extract::_ALLOW_BIN;
+ for my $tar_iter (@with_tar_iter) { SKIP: {
- ### whitebox test ###
- ### stupid warnings ###
- local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
- local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
- local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
- local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
+ ### Doesn't matter unless .tar, .tbz, .tgz
+ local $Archive::Extract::_ALLOW_TAR_ITER = $tar_iter;
+ diag("Archive::Tar->iter: $tar_iter") if $Debug;
- ### try extracting ###
- for my $to ( @outs ) {
+ isa_ok( $ae, $Class );
- diag("Extracting to: $to") if $Debug;
- diag("Buffers enabled: ".!$turn_off) if $Debug;
-
- my $rv = $ae->extract( to => $to );
-
- SKIP: {
- my $re = qr/^No buffer captured/;
- my $err = $ae->error || '';
-
- ### skip buffer tests if we dont have buffers or
- ### explicitly turned them off
- skip "No buffers available", 8
- if ( $turn_off || !IPC::Cmd->can_capture_buffer)
- && $err =~ $re;
-
- ### skip tests if we dont have an extractor
- skip "No extractor available", 8
- if $err =~ /Extract failed; no extractors available/;
-
- ok( $rv, "extract() for '$archive' reports success ($cfg)");
-
- diag("Extractor was: " . $ae->_extractor) if $Debug;
-
- ### if we /should/ have buffers, there should be
- ### no errors complaining we dont have them...
- unlike( $err, $re,
- "No errors capturing buffers" );
-
- ### might be 1 or 2, depending wether we extracted
- ### a dir too
- my $files = $ae->files || [];
- my $file_cnt = grep { defined } $file, $dir;
- is( scalar @$files, $file_cnt,
- "Found correct number of output files (@$files)" );
-
- ### due to prototypes on is(), if there's no -1 index on
- ### the array ref, it'll give a fatal exception:
- ### "Modification of non-creatable array value attempted,
- ### subscript -1 at -e line 1." So wrap it in do { }
- is( do { $files->[-1] }, $nix_path,
- "Found correct output file '$nix_path'" );
-
- ok( -e $abs_path,
- "Output file '$abs_path' exists" );
- ok( $ae->extract_path,
- "Extract dir found" );
- ok( -d $ae->extract_path,
- "Extract dir exists" );
- is( $ae->extract_path, $abs_dir,
- "Extract dir is expected '$abs_dir'" );
- }
+ my $method = $tmpl->{$archive}->{method};
+ ok( $ae->$method(), "Archive type recognized properly" );
- SKIP: {
- skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
- 1 while unlink $abs_path;
- ok( !(-e $abs_path), "Output file successfully removed" );
+ my $file = $tmpl->{$archive}->{outfile};
+ my $dir = $tmpl->{$archive}->{outdir}; # can be undef
+ my $rel_path = File::Spec->catfile( grep { defined } $dir, $file );
+ my $abs_path = File::Spec->catfile( $OutDir, $rel_path );
+ my $abs_dir = File::Spec->catdir(
+ grep { defined } $OutDir, $dir );
+ my $nix_path = File::Spec::Unix->catfile(
+ grep { defined } $dir, $file );
+
+ ### check if we can run this test ###
+ my $pgm_fail; my $mod_fail;
+ for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
+ ### no binary extract method
+ $pgm_fail++, next unless $pgm;
+
+ ### we dont have the program
+ $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
+ $Archive::Extract::PROGRAMS->{$pgm};
+
+ }
+
+ for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
+ ### no module extract method
+ $mod_fail++, next unless $mod;
+
+ ### we dont have the module
+ $mod_fail++ unless check_install( module => $mod );
+ }
+
+ ### where to extract to -- try both dir and file for gz files
+ ### XXX test me!
+ #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
+ my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma
+ ? ($abs_path)
+ : ($OutDir);
+
+ ### 10 tests from here on down ###
+ if( ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN))
+ ||
+ ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL))
+ ) {
+ skip "No binaries or modules to extract ".$archive,
+ (10 * scalar @outs);
+ }
+
+ ### we dont warnings spewed about missing modules, that might
+ ### be a problem...
+ local $IPC::Cmd::WARN = 0;
+ local $IPC::Cmd::WARN = 0;
+
+ for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {
+
+ ### test buffers ###
+ my $turn_off = !$use_buffer && !$pgm_fail &&
+ $Archive::Extract::_ALLOW_BIN;
+
+ ### whitebox test ###
+ ### stupid warnings ###
+ local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
+ local $IPC::Cmd::USE_IPC_RUN = 0 if $turn_off;
+ local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
+ local $IPC::Cmd::USE_IPC_OPEN3 = 0 if $turn_off;
+
+
+ ### try extracting ###
+ for my $to ( @outs ) {
+
+ diag("Extracting to: $to") if $Debug;
+ diag("Buffers enabled: ".!$turn_off) if $Debug;
+
+ my $rv = $ae->extract( to => $to );
SKIP: {
- skip "No extract path captured, can't remove paths", 2
- unless $ae->extract_path;
+ my $re = qr/^No buffer captured/;
+ my $err = $ae->error || '';
+
+ ### skip buffer tests if we dont have buffers or
+ ### explicitly turned them off
+ skip "No buffers available", 8
+ if ( $turn_off || !IPC::Cmd->can_capture_buffer)
+ && $err =~ $re;
+
+ ### skip tests if we dont have an extractor
+ skip "No extractor available", 8
+ if $err =~ /Extract failed; no extractors available/;
+
+ ### win32 + bin utils is notorious, and none of them are
+ ### officially supported by strawberry. So if we
+ ### encounter an error while extracting whlie running
+ ### with $PREFER_BIN on win32, just skip the tests.
+ ### See rt#46948: unable to install install on win32
+ ### for details on the pain
+ skip "Binary tools on Win32 are very unreliable", 8
+ if $err and $Archive::Extract::_ALLOW_BIN
+ and IS_WIN32;
- ### if something went wrong with determining the out
- ### path, don't go deleting stuff.. might be Really Bad
- my $out_re = quotemeta( $OutDir );
-
- ### 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;
+ ok( $rv, "extract() for '$archive' reports success ($cfg)");
+
+ diag("Extractor was: " . $ae->_extractor) if $Debug;
+
+ ### if we /should/ have buffers, there should be
+ ### no errors complaining we dont have them...
+ unlike( $err, $re,
+ "No errors capturing buffers" );
+
+ ### might be 1 or 2, depending wether we extracted
+ ### a dir too
+ my $files = $ae->files || [];
+ my $file_cnt = grep { defined } $file, $dir;
+ is( scalar @$files, $file_cnt,
+ "Found correct number of output files (@$files)" );
- if( $ae->extract_path !~ /^$out_re/ ) {
- ok( 0, "Extractpath WRONG (".$ae->extract_path.")");
- skip( "Unsafe operation -- skip cleanup!!!" ), 1;
- }
-
- eval { rmtree( $ae->extract_path ) };
- ok( !$@, " rmtree gave no error" );
- ok( !(-d $ae->extract_path ),
- " Extract dir succesfully removed" );
+ ### due to prototypes on is(), if there's no -1 index on
+ ### the array ref, it'll give a fatal exception:
+ ### "Modification of non-creatable array value attempted,
+ ### subscript -1 at -e line 1." So wrap it in do { }
+ is( do { $files->[-1] }, $nix_path,
+ "Found correct output file '$nix_path'" );
+
+ ok( -e $abs_path,
+ "Output file '$abs_path' exists" );
+ ok( $ae->extract_path,
+ "Extract dir found" );
+ ok( -d $ae->extract_path,
+ "Extract dir exists" );
+ is( $ae->extract_path, $abs_dir,
+ "Extract dir is expected '$abs_dir'" );
+ }
+
+ SKIP: {
+ skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;
+
+ 1 while unlink $abs_path;
+ ok( !(-e $abs_path), "Output file successfully removed" );
+
+ SKIP: {
+ skip "No extract path captured, can't remove paths", 2
+ unless $ae->extract_path;
+
+ ### if something went wrong with determining the out
+ ### path, don't go deleting stuff.. might be Really Bad
+ my $out_re = quotemeta( $OutDir );
+
+ ### 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;
+ }
+
+ eval { rmtree( $ae->extract_path ) };
+ ok( !$@, " rmtree gave no error" );
+ ok( !(-d $ae->extract_path ),
+ " Extract dir succesfully removed" );
+ }
}
}
}
- }
- } }
+ } }
+ }
}
projects / platform / upstream / perl.git / commitdiff