diff --git a/dev-tools/src/main/resources/license-check/check_license_and_sha.pl b/dev-tools/src/main/resources/license-check/check_license_and_sha.pl index 9a865afde53..824940ab2b5 100755 --- a/dev-tools/src/main/resources/license-check/check_license_and_sha.pl +++ b/dev-tools/src/main/resources/license-check/check_license_and_sha.pl @@ -3,26 +3,45 @@ use strict; use warnings; use v5.10; + +use FindBin qw($RealBin); +use lib "$RealBin/lib"; +use Archive::Ar(); +use Cwd(); +use File::Spec(); use Digest::SHA qw(sha1); use File::Temp(); use File::Basename qw(basename); -use File::Find(); -my $mode = shift(@ARGV) || die usage(); -my $dir = shift(@ARGV) || die usage(); -$dir =~ s{/$}{}; +use Archive::Extract(); +$Archive::Extract::PREFER_BIN = 1; -our $RELEASES_DIR = "$dir/target/releases/"; -our $LICENSE_DIR = "$dir/licenses/"; +our %Extract_Package = ( + zip => \&extract_zip, + gz => \&extract_tar_gz, + rpm => \&extract_rpm, + deb => \&extract_deb +); -$mode eq '--check' ? check_shas_and_licenses($dir) - : $mode eq '--update' ? write_shas($dir) - : die usage(); +my $mode = shift(@ARGV) || ""; +die usage() unless $mode =~ /^--(check|update)$/; + +my $License_Dir = shift(@ARGV) || die usage(); +my $Package = shift(@ARGV) || die usage(); +$License_Dir = File::Spec->rel2abs($License_Dir) . '/'; +$Package = File::Spec->rel2abs($Package); + +die "License dir is not a directory: $License_Dir\n" . usage() + unless -d $License_Dir; + +my %shas = get_shas_from_package($Package); +$mode eq '--check' + ? exit check_shas_and_licenses(%shas) + : exit write_shas(%shas); #=================================== sub check_shas_and_licenses { #=================================== - my %new = get_shas_from_zip(); - check_tar_has_same_shas(%new); + my %new = @_; my %old = get_sha_files(); my %licenses = get_files_with('LICENSE'); @@ -41,7 +60,8 @@ sub check_shas_and_licenses { } unless ( $old_sha eq $new{$jar} ) { - say STDERR "$jar: SHA has changed, expected $old_sha but found $new{$jar}"; + say STDERR + "$jar: SHA has changed, expected $old_sha but found $new{$jar}"; $error++; $sha_error++; next; @@ -101,18 +121,18 @@ sub check_shas_and_licenses { You can update the SHA files by running: - $0 --update core +$0 --update $License_Dir $Package SHAS } - - exit $error; + say "All SHAs and licenses OK" unless $error; + return $error; } #=================================== sub write_shas { #=================================== - my %new = get_shas_from_zip(); + my %new = @_; my %old = get_sha_files(); for my $jar ( sort keys %new ) { @@ -123,7 +143,7 @@ sub write_shas { else { say "Adding $jar"; } - open my $fh, '>', $LICENSE_DIR . $jar or die $!; + open my $fh, '>', $License_Dir . $jar or die $!; say $fh $new{$jar} or die $!; close $fh or die $!; } @@ -133,8 +153,10 @@ sub write_shas { for my $jar ( sort keys %old ) { say "Deleting $jar"; - unlink $LICENSE_DIR . $jar or die $!; + unlink $License_Dir . $jar or die $!; } + say "SHAs updated"; + return 0; } #=================================== @@ -142,7 +164,7 @@ sub get_files_with { #=================================== my $pattern = shift; my %files; - for my $path ( grep {-f} glob("$LICENSE_DIR/*$pattern*") ) { + for my $path ( grep {-f} glob("$License_Dir/*$pattern*") ) { my ($file) = ( $path =~ m{([^/]+)-${pattern}.*$} ); $files{$file} = 0; } @@ -154,10 +176,10 @@ sub get_sha_files { #=================================== my %shas; - die "Missing directory: $LICENSE_DIR\n" - unless -d $LICENSE_DIR; + die "Missing directory: $License_Dir\n" + unless -d $License_Dir; - for my $file ( grep {-f} glob("$LICENSE_DIR/*.sha1") ) { + for my $file ( grep {-f} glob("$License_Dir/*.sha1") ) { my ($jar) = ( $file =~ m{([^/]+)$} ); open my $fh, '<', $file or die $!; my $sha = <$fh>; @@ -169,58 +191,82 @@ sub get_sha_files { } #=================================== -sub get_shas_from_zip { +sub get_shas_from_package { #=================================== - my ($zip) = glob("$RELEASES_DIR/elasticsearch*.zip") - or die "No .zip file found in $RELEASES_DIR\n"; + my $package = shift; + my ($type) = ( $package =~ /\.(\w+)$/ ); + die "Unrecognised package type: $package" + unless $type && $Extract_Package{$type}; my $temp_dir = File::Temp->newdir; - my $dir_name = $temp_dir->dirname; - system( 'unzip', "-j", "-q", $zip, "*.jar", "-d" => $dir_name ) - && die "Error unzipping <$zip> to <" . $dir_name . ">: $!\n"; + my $files + = eval { $Extract_Package{$type}->( $package, $temp_dir->dirname ) } + or die "Couldn't extract $package: $@"; - my @jars = grep { !/\/elasticsearch[^\/]+.jar$/ } glob "$dir_name/*.jar"; + my @jars = map {"$temp_dir/$_"} + grep { /\.jar$/ && !/elasticsearch[^\/]*$/ } @$files; return calculate_shas(@jars); } #=================================== -sub check_tar_has_same_shas { +sub extract_zip { #=================================== - my %zip_shas = @_; - my ($tar) = glob("$RELEASES_DIR/elasticsearch*.tar.gz") - or return; + my ( $package, $dir ) = @_; + my $archive = Archive::Extract->new( archive => $package, type => 'zip' ); + $archive->extract( to => $dir ) || die $archive->error; + return $archive->files; +} - my $temp_dir = File::Temp->newdir; - my $dir_name = $temp_dir->dirname; - system( 'tar', "-xz", "-C" => $dir_name, "-f" => $tar ) - && die "Error unpacking <$tar> to <" . $dir_name . ">: $!\n"; +#=================================== +sub extract_tar_gz { +#=================================== + my ( $package, $dir ) = @_; + my $archive = Archive::Extract->new( archive => $package, type => 'tgz' ); + $archive->extract( to => $dir ) || die $archive->error; + return $archive->files; +} - my @jars; - File::Find::find( - { wanted => - sub { push @jars, $_ if /\.jar$/ && !/elasticsearch[^\/]*$/ }, - no_chdir => 1 - }, - $dir_name +#=================================== +sub extract_rpm { +#=================================== + my ( $package, $dir ) = @_; + my $cwd = Cwd::cwd(); + my @files; + eval { + chdir $dir; + say "Trying with rpm2cpio"; + my $out = eval {`rpm2cpio '$package' | cpio -idmv --quiet`}; + unless ($out) { + say "Trying with rpm2cpio.pl"; + $out = eval {`rpm2cpio.pl '$package' | cpio -idmv --quiet`}; + } + @files = split "\n", $out if $out; + }; + chdir $cwd; + die $@ if $@; + die "Couldn't extract $package\n" unless @files; + return \@files; +} + +#=================================== +sub extract_deb { +#=================================== + my ( $package, $dir ) = @_; + my $archive = Archive::Ar->new; + $archive->read($package) || die $archive->error; + my $cwd = Cwd::cwd(); + eval { + chdir $dir; + $archive->extract('data.tar.gz') || die $archive->error; + }; + chdir $cwd; + die $@ if $@; + $archive = Archive::Extract->new( + archive => $dir . '/data.tar.gz', + type => 'tgz' ); - - my %tar_shas = calculate_shas(@jars); - my @errors; - for ( sort keys %zip_shas ) { - my $sha = delete $tar_shas{$_}; - if ( !$sha ) { - push @errors, "$_: JAR present in zip but not in tar.gz"; - } - elsif ( $sha ne $zip_shas{$_} ) { - push @errors, "$_: JAR in zip and tar.gz are different"; - } - } - for ( sort keys %tar_shas ) { - push @errors, "$_: JAR present in tar.gz but not in zip"; - } - if (@errors) { - die join "\n", @errors; - } + $archive->extract( to => $dir ) || die $archive->error; + return $archive->files; } #=================================== @@ -242,11 +288,13 @@ sub usage { USAGE: - $0 --check dir # check the sha1 and LICENSE files for each jar - $0 --update dir # update the sha1 files for each jar + # check the sha1 and LICENSE files for each jar in the zip|gz|deb|rpm + $0 --check path/to/licenses/ path/to/package.zip -The can be set to e.g. 'core' or 'plugins/analysis-icu/' + # updates the sha1s for each jar in the zip|gz|deb|rpm + $0 --update path/to/licenses/ path/to/package.zip USAGE } + diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Ar.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Ar.pm new file mode 100644 index 00000000000..6d6439b37b4 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Ar.pm @@ -0,0 +1,806 @@ +########################################################### +# Archive::Ar - Pure perl module to handle ar achives +# +# Copyright 2003 - Jay Bonci +# Copyright 2014 - John Bazik +# Licensed under the same terms as perl itself +# +########################################################### +package Archive::Ar; + +use base qw(Exporter); +our @EXPORT_OK = qw(COMMON BSD GNU); + +use strict; +use File::Spec; +use Time::Local; +use Carp qw(carp longmess); + +use vars qw($VERSION); +$VERSION = '2.02'; + +use constant CAN_CHOWN => ($> == 0 and $^O ne 'MacOS' and $^O ne 'MSWin32'); + +use constant ARMAG => "!\n"; +use constant SARMAG => length(ARMAG); +use constant ARFMAG => "`\n"; +use constant AR_EFMT1 => "#1/"; + +use constant COMMON => 1; +use constant BSD => 2; +use constant GNU => 3; + +my $has_io_string; +BEGIN { + $has_io_string = eval { + require IO::String; + IO::String->import(); + 1; + } || 0; +} + +sub new { + my $class = shift; + my $file = shift; + my $opts = shift || 0; + my $self = bless {}, $class; + my $defopts = { + chmod => 1, + chown => 1, + same_perms => ($> == 0) ? 1:0, + symbols => undef, + }; + $opts = {warn => $opts} unless ref $opts; + + $self->clear(); + $self->{opts} = {(%$defopts, %{$opts})}; + if ($file) { + return unless $self->read($file); + } + return $self; +} + +sub set_opt { + my $self = shift; + my $name = shift; + my $val = shift; + + $self->{opts}->{$name} = $val; +} + +sub get_opt { + my $self = shift; + my $name = shift; + + return $self->{opts}->{$name}; +} + +sub type { + return shift->{type}; +} + +sub clear { + my $self = shift; + + $self->{names} = []; + $self->{files} = {}; + $self->{type} = undef; +} + +sub read { + my $self = shift; + my $file = shift; + + my $fh = $self->_get_handle($file); + local $/ = undef; + my $data = <$fh>; + close $fh; + + return $self->read_memory($data); +} + +sub read_memory { + my $self = shift; + my $data = shift; + + $self->clear(); + return unless $self->_parse($data); + return length($data); +} + +sub contains_file { + my $self = shift; + my $filename = shift; + + return unless defined $filename; + return exists $self->{files}->{$filename}; +} + +sub extract { + my $self = shift; + + for my $filename (@_ ? @_ : @{$self->{names}}) { + $self->extract_file($filename) or return; + } + return 1; +} + +sub extract_file { + my $self = shift; + my $filename = shift; + my $target = shift || $filename; + + my $meta = $self->{files}->{$filename}; + return $self->_error("$filename: not in archive") unless $meta; + open my $fh, '>', $target or return $self->_error("$target: $!"); + binmode $fh; + syswrite $fh, $meta->{data} or return $self->_error("$filename: $!"); + close $fh or return $self->_error("$filename: $!"); + if (CAN_CHOWN && $self->{opts}->{chown}) { + chown $meta->{uid}, $meta->{gid}, $filename or + return $self->_error("$filename: $!"); + } + if ($self->{opts}->{chmod}) { + my $mode = $meta->{mode}; + unless ($self->{opts}->{same_perms}) { + $mode &= ~(oct(7000) | (umask | 0)); + } + chmod $mode, $filename or return $self->_error("$filename: $!"); + } + utime $meta->{date}, $meta->{date}, $filename or + return $self->_error("$filename: $!"); + return 1; +} + +sub rename { + my $self = shift; + my $filename = shift; + my $target = shift; + + if ($self->{files}->{$filename}) { + $self->{files}->{$target} = $self->{files}->{$filename}; + delete $self->{files}->{$filename}; + for (@{$self->{names}}) { + if ($_ eq $filename) { + $_ = $target; + last; + } + } + } +} + +sub chmod { + my $self = shift; + my $filename = shift; + my $mode = shift; # octal string or numeric + + return unless $self->{files}->{$filename}; + $self->{files}->{$filename}->{mode} = + $mode + 0 eq $mode ? $mode : oct($mode); + return 1; +} + +sub chown { + my $self = shift; + my $filename = shift; + my $uid = shift; + my $gid = shift; + + return unless $self->{files}->{$filename}; + $self->{files}->{$filename}->{uid} = $uid if $uid >= 0; + $self->{files}->{$filename}->{gid} = $gid if defined $gid && $gid >= 0; + return 1; +} + +sub remove { + my $self = shift; + my $files = ref $_[0] ? shift : \@_; + + my $nfiles_orig = scalar @{$self->{names}}; + + for my $file (@$files) { + next unless $file; + if (exists($self->{files}->{$file})) { + delete $self->{files}->{$file}; + } + else { + $self->_error("$file: no such member") + } + } + @{$self->{names}} = grep($self->{files}->{$_}, @{$self->{names}}); + + return $nfiles_orig - scalar @{$self->{names}}; +} + +sub list_files { + my $self = shift; + + return wantarray ? @{$self->{names}} : $self->{names}; +} + +sub add_files { + my $self = shift; + my $files = ref $_[0] ? shift : \@_; + + for my $path (@$files) { + if (open my $fd, $path) { + my @st = stat $fd or return $self->_error("$path: $!"); + local $/ = undef; + binmode $fd; + my $content = <$fd>; + close $fd; + + my $filename = (File::Spec->splitpath($path))[2]; + + $self->_add_data($filename, $content, @st[9,4,5,2,7]); + } + else { + $self->_error("$path: $!"); + } + } + return scalar @{$self->{names}}; +} + +sub add_data { + my $self = shift; + my $path = shift; + my $content = shift; + my $params = shift || {}; + + return $self->_error("No filename given") unless $path; + + my $filename = (File::Spec->splitpath($path))[2]; + + $self->_add_data($filename, $content, + $params->{date} || timelocal(localtime()), + $params->{uid} || 0, + $params->{gid} || 0, + $params->{mode} || 0100644) or return; + + return $self->{files}->{$filename}->{size}; +} + +sub write { + my $self = shift; + my $filename = shift; + my $opts = {(%{$self->{opts}}, %{shift || {}})}; + my $type = $opts->{type} || $self->{type} || COMMON; + + my @body = ( ARMAG ); + + my %gnuindex; + my @filenames = @{$self->{names}}; + if ($type eq GNU) { + # + # construct extended filename index, if needed + # + if (my @longs = grep(length($_) > 15, @filenames)) { + my $ptr = 0; + for my $long (@longs) { + $gnuindex{$long} = $ptr; + $ptr += length($long) + 2; + } + push @body, pack('A16A32A10A2', '//', '', $ptr, ARFMAG), + join("/\n", @longs, ''); + push @body, "\n" if $ptr % 2; # padding + } + } + for my $fn (@filenames) { + my $meta = $self->{files}->{$fn}; + my $mode = sprintf('%o', $meta->{mode}); + my $size = $meta->{size}; + my $name; + + if ($type eq GNU) { + $fn = '' if defined $opts->{symbols} && $fn eq $opts->{symbols}; + $name = $fn . '/'; + } + else { + $name = $fn; + } + if (length($name) <= 16 || $type eq COMMON) { + push @body, pack('A16A12A6A6A8A10A2', $name, + @$meta{qw/date uid gid/}, $mode, $size, ARFMAG); + } + elsif ($type eq GNU) { + push @body, pack('A1A15A12A6A6A8A10A2', '/', $gnuindex{$fn}, + @$meta{qw/date uid gid/}, $mode, $size, ARFMAG); + } + elsif ($type eq BSD) { + $size += length($name); + push @body, pack('A3A13A12A6A6A8A10A2', AR_EFMT1, length($name), + @$meta{qw/date uid gid/}, $mode, $size, ARFMAG), + $name; + } + else { + return $self->_error("$type: unexpected ar type"); + } + push @body, $meta->{data}; + push @body, "\n" if $size % 2; # padding + } + if ($filename) { + my $fh = $self->_get_handle($filename, '>'); + print $fh @body; + close $fh; + my $len = 0; + $len += length($_) for @body; + return $len; + } + else { + return join '', @body; + } +} + +sub get_content { + my $self = shift; + my ($filename) = @_; + + unless ($filename) { + $self->_error("get_content can't continue without a filename"); + return; + } + + unless (exists($self->{files}->{$filename})) { + $self->_error( + "get_content failed because there is not a file named $filename"); + return; + } + + return $self->{files}->{$filename}; +} + +sub get_data { + my $self = shift; + my $filename = shift; + + return $self->_error("$filename: no such member") + unless exists $self->{files}->{$filename}; + return $self->{files}->{$filename}->{data}; +} + +sub get_handle { + my $self = shift; + my $filename = shift; + my $fh; + + return $self->_error("$filename: no such member") + unless exists $self->{files}->{$filename}; + if ($has_io_string) { + $fh = IO::String->new($self->{files}->{$filename}->{data}); + } + else { + my $data = $self->{files}->{$filename}->{data}; + open $fh, '<', \$data or return $self->_error("in-memory file: $!"); + } + return $fh; +} + +sub error { + my $self = shift; + + return shift() ? $self->{longmess} : $self->{error}; +} + +# +# deprecated +# +sub DEBUG { + my $self = shift; + my $debug = shift; + + $self->{opts}->{warn} = 1 unless (defined($debug) and int($debug) == 0); +} + +sub _parse { + my $self = shift; + my $data = shift; + + unless (substr($data, 0, SARMAG, '') eq ARMAG) { + return $self->_error("Bad magic number - not an ar archive"); + } + my $type; + my $names; + while ($data =~ /\S/) { + my ($name, $date, $uid, $gid, $mode, $size, $magic) = + unpack('A16A12A6A6A8A10a2', substr($data, 0, 60, '')); + unless ($magic eq "`\n") { + return $self->_error("Bad file header"); + } + if ($name =~ m|^/|) { + $type = GNU; + if ($name eq '//') { + $names = substr($data, 0, $size, ''); + substr($data, 0, $size % 2, ''); + next; + } + elsif ($name eq '/') { + $name = $self->{opts}->{symbols}; + unless (defined $name && $name) { + substr($data, 0, $size + $size % 2, ''); + next; + } + } + else { + $name = substr($names, int(substr($name, 1))); + $name =~ s/\n.*//; + chop $name; + } + } + elsif ($name =~ m|^#1/|) { + $type = BSD; + $name = substr($data, 0, int(substr($name, 3)), ''); + $size -= length($name); + } + else { + if ($name =~ m|/$|) { + $type ||= GNU; # only gnu has trailing slashes + chop $name; + } + } + $uid = int($uid); + $gid = int($gid); + $mode = oct($mode); + my $content = substr($data, 0, $size, ''); + substr($data, 0, $size % 2, ''); + + $self->_add_data($name, $content, $date, $uid, $gid, $mode, $size); + } + $self->{type} = $type || COMMON; + return scalar @{$self->{names}}; +} + +sub _add_data { + my $self = shift; + my $filename = shift; + my $content = shift || ''; + my $date = shift; + my $uid = shift; + my $gid = shift; + my $mode = shift; + my $size = shift; + + if (exists($self->{files}->{$filename})) { + return $self->_error("$filename: entry already exists"); + } + $self->{files}->{$filename} = { + name => $filename, + date => defined $date ? $date : timelocal(localtime()), + uid => defined $uid ? $uid : 0, + gid => defined $gid ? $gid : 0, + mode => defined $mode ? $mode : 0100644, + size => defined $size ? $size : length($content), + data => $content, + }; + push @{$self->{names}}, $filename; + return 1; +} + +sub _get_handle { + my $self = shift; + my $file = shift; + my $mode = shift || '<'; + + if (ref $file) { + return $file if eval{*$file{IO}} or $file->isa('IO::Handle'); + return $self->_error("Not a filehandle"); + } + else { + open my $fh, $mode, $file or return $self->_error("$file: $!"); + binmode $fh; + return $fh; + } +} + +sub _error { + my $self = shift; + my $msg = shift; + + $self->{error} = $msg; + $self->{longerror} = longmess($msg); + if ($self->{opts}->{warn} > 1) { + carp $self->{longerror}; + } + elsif ($self->{opts}->{warn}) { + carp $self->{error}; + } + return; +} + +1; + +__END__ + +=head1 NAME + +Archive::Ar - Interface for manipulating ar archives + +=head1 SYNOPSIS + + use Archive::Ar; + + my $ar = Archive::Ar->new; + + $ar->read('./foo.ar'); + $ar->extract; + + $ar->add_files('./bar.tar.gz', 'bat.pl') + $ar->add_data('newfile.txt','Some contents'); + + $ar->chmod('file1', 0644); + $ar->chown('file1', $uid, $gid); + + $ar->remove('file1', 'file2'); + + my $filehash = $ar->get_content('bar.tar.gz'); + my $data = $ar->get_data('bar.tar.gz'); + my $handle = $ar->get_handle('bar.tar.gz'); + + my @files = $ar->list_files(); + + my $archive = $ar->write; + my $size = $ar->write('outbound.ar'); + + $ar->error(); + + +=head1 DESCRIPTION + +Archive::Ar is a pure-perl way to handle standard ar archives. + +This is useful if you have those types of archives on the system, but it +is also useful because .deb packages for the Debian GNU/Linux distribution are +ar archives. This is one building block in a future chain of modules to build, +manipulate, extract, and test debian modules with no platform or architecture +dependence. + +You may notice that the API to Archive::Ar is similar to Archive::Tar, and +this was done intentionally to keep similarity between the Archive::* +modules. + +=head1 METHODS + +=head2 new + + $ar = Archive::Ar->new() + $ar = Archive::Ar->new($filename) + $ar = Archive::Ar->new($filehandle) + +Returns a new Archive::Ar object. Without an argument, it returns +an empty object. If passed a filename or an open filehandle, it will +read the referenced archive into memory. If the read fails for any +reason, returns undef. + +=head2 set_opt + + $ar->set_opt($name, $val) + +Assign option $name value $val. Possible options are: + +=over 4 + +=item * warn + +Warning level. Levels are zero for no warnings, 1 for brief warnings, +and 2 for warnings with a stack trace. Default is zero. + +=item * chmod + +Change the file permissions of files created when extracting. Default +is true (non-zero). + +=item * same_perms + +When setting file permissions, use the values in the archive unchanged. +If false, removes setuid bits and applies the user's umask. Default is +true for the root user, false otherwise. + +=item * chown + +Change the owners of extracted files, if possible. Default is true. + +=item * type + +Archive type. May be GNU, BSD or COMMON, or undef if no archive has +been read. Defaults to the type of the archive read, or undef. + +=item * symbols + +Provide a filename for the symbol table, if present. If set, the symbol +table is treated as a file that can be read from or written to an archive. +It is an error if the filename provided matches the name of a file in the +archive. If undefined, the symbol table is ignored. Defaults to undef. + +=back + +=head2 get_opt + + $val = $ar->get_opt($name) + +Returns the value of option $name. + +=head2 type + + $type = $ar->type() + +Returns the type of the ar archive. The type is undefined until an +archive is loaded. If the archive displays characteristics of a gnu-style +archive, GNU is returned. If it looks like a bsd-style archive, BSD +is returned. Otherwise, COMMON is returned. Note that unless filenames +exceed 16 characters in length, bsd archives look like the common format. + +=head2 clear + + $ar->clear() + +Clears the current in-memory archive. + +=head2 read + + $len = $ar->read($filename) + $len = $ar->read($filehandle) + +This reads a new file into the object, removing any ar archive already +represented in the object. The argument may be a filename, filehandle +or IO::Handle object. Returns the size of the file contents or undef +if it fails. + +=head2 read_memory + + $len = $ar->read_memory($data) + +Parses the string argument as an archive, reading it into memory. Replaces +any previously loaded archive. Returns the number of bytes read, or undef +if it fails. + +=head2 contains_file + + $bool = $ar->contains_file($filename) + +Returns true if the archive contains a file with $filename. Returns +undef otherwise. + +=head2 extract + + $ar->extract() + $ar->extract_file($filename) + +Extracts files from the archive. The first form extracts all files, the +latter extracts just the named file. Extracted files are assigned the +permissions and modification time stored in the archive, and, if possible, +the user and group ownership. Returns non-zero upon success, or undef if +failure. + +=head2 rename + + $ar->rename($filename, $newname) + +Changes the name of a file in the in-memory archive. + +=head2 chmod + + $ar->chmod($filename, $mode); + +Change the mode of the member to C<$mode>. + +=head2 chown + + $ar->chown($filename, $uid, $gid); + $ar->chown($filename, $uid); + +Change the ownership of the member to user id C<$uid> and (optionally) +group id C<$gid>. Negative id values are ignored. + +=head2 remove + + $ar->remove(@filenames) + $ar->remove($arrayref) + +Removes files from the in-memory archive. Returns the number of files +removed. + +=head2 list_files + + @filenames = $ar->list_files() + +Returns a list of the names of all the files in the archive. +If called in a scalar context, returns a reference to an array. + +=head2 add_files + + $ar->add_files(@filenames) + $ar->add_files($arrayref) + +Adds files to the archive. The arguments can be paths, but only the +filenames are stored in the archive. Stores the uid, gid, mode, size, +and modification timestamp of the file as returned by C. + +Returns the number of files successfully added, or undef if failure. + +=head2 add_data + + $ar->add_data("filename", $data) + $ar->add_data("filename", $data, $options) + +Adds a file to the in-memory archive with name $filename and content +$data. File properties can be set with $optional_hashref: + + $options = { + 'data' => $data, + 'uid' => $uid, #defaults to zero + 'gid' => $gid, #defaults to zero + 'date' => $date, #date in epoch seconds. Defaults to now. + 'mode' => $mode, #defaults to 0100644; + } + +You cannot add_data over another file however. This returns the file length in +bytes if it is successful, undef otherwise. + +=head2 write + + $data = $ar->write() + $len = $ar->write($filename) + +Returns the archive as a string, or writes it to disk as $filename. +Returns the archive size upon success when writing to disk. Returns +undef if failure. + +=head2 get_content + + $content = $ar->get_content($filename) + +This returns a hash with the file content in it, including the data +that the file would contain. If the file does not exist or no filename +is given, this returns undef. On success, a hash is returned: + + $content = { + 'name' => $filename, + 'date' => $mtime, + 'uid' => $uid, + 'gid' => $gid, + 'mode' => $mode, + 'size' => $size, + 'data' => $file_contents, + } + +=head2 get_data + + $data = $ar->get_data("filename") + +Returns a scalar containing the file data of the given archive +member. Upon error, returns undef. + +=head2 get_handle + + $handle = $ar->get_handle("filename")> + +Returns a file handle to the in-memory file data of the given archive member. +Upon error, returns undef. This can be useful for unpacking nested archives. +Uses IO::String if it's loaded. + +=head2 error + + $errstr = $ar->error($trace) + +Returns the current error string, which is usually the last error reported. +If a true value is provided, returns the error message and stack trace. + +=head1 BUGS + +See https://github.com/jbazik/Archive-Ar/issues/ to report and view bugs. + +=head1 SOURCE + +The source code repository for Archive::Ar can be found at http://github.com/jbazik/Archive-Ar/. + +=head1 COPYRIGHT + +Copyright 2009-2014 John Bazik Ejbazik@cpan.orgE. + +Copyright 2003 Jay Bonci Ejaybonci@cpan.orgE. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Extract.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Extract.pm new file mode 100644 index 00000000000..e88cf11f037 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Extract.pm @@ -0,0 +1,1694 @@ +package Archive::Extract; +use if $] > 5.017, 'deprecate'; + +use strict; + +use Cwd qw[cwd chdir]; +use Carp qw[carp]; +use IPC::Cmd qw[run can_run]; +use FileHandle; +use File::Path qw[mkpath]; +use File::Spec; +use File::Basename qw[dirname basename]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Style => 'gettext'; + +### solaris has silly /bin/tar output ### +use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0; +use constant ON_NETBSD => $^O eq 'netbsd' ? 1 : 0; +use constant ON_OPENBSD => $^O =~ m!^(openbsd|bitrig)$! ? 1 : 0; +use constant ON_FREEBSD => $^O =~ m!^(free|midnight|dragonfly)(bsd)?$! ? 1 : 0; +use constant ON_LINUX => $^O eq 'linux' ? 1 : 0; +use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; + +### VMS may require quoting upper case command options +use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; + +### Windows needs special treatment of Tar options +use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0; + +### we can't use this extraction method, because of missing +### modules/binaries: +use constant METHOD_NA => []; + +### If these are changed, update @TYPES and the new() POD +use constant TGZ => 'tgz'; +use constant TAR => 'tar'; +use constant GZ => 'gz'; +use constant ZIP => 'zip'; +use constant BZ2 => 'bz2'; +use constant TBZ => 'tbz'; +use constant Z => 'Z'; +use constant LZMA => 'lzma'; +use constant XZ => 'xz'; +use constant TXZ => 'txz'; + +use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG + $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER + ]; + +$VERSION = '0.76'; +$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, XZ, TXZ ); + +local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +Archive::Extract - A generic archive extracting mechanism + +=head1 SYNOPSIS + + use Archive::Extract; + + ### build an Archive::Extract object ### + my $ae = Archive::Extract->new( archive => 'foo.tgz' ); + + ### extract to cwd() ### + my $ok = $ae->extract; + + ### extract to /tmp ### + my $ok = $ae->extract( to => '/tmp' ); + + ### what if something went wrong? + my $ok = $ae->extract or die $ae->error; + + ### files from the archive ### + my $files = $ae->files; + + ### dir that was extracted to ### + my $outdir = $ae->extract_path; + + + ### quick check methods ### + $ae->is_tar # is it a .tar file? + $ae->is_tgz # is it a .tar.gz or .tgz file? + $ae->is_gz; # is it a .gz file? + $ae->is_zip; # is it a .zip file? + $ae->is_bz2; # is it a .bz2 file? + $ae->is_tbz; # is it a .tar.bz2 or .tbz file? + $ae->is_lzma; # is it a .lzma file? + $ae->is_xz; # is it a .xz file? + $ae->is_txz; # is it a .tar.xz or .txz file? + + ### absolute path to the archive you provided ### + $ae->archive; + + ### commandline tools, if found ### + $ae->bin_tar # path to /bin/tar, if found + $ae->bin_gzip # path to /bin/gzip, if found + $ae->bin_unzip # path to /bin/unzip, if found + $ae->bin_bunzip2 # path to /bin/bunzip2 if found + $ae->bin_unlzma # path to /bin/unlzma if found + $ae->bin_unxz # path to /bin/unxz if found + +=head1 DESCRIPTION + +Archive::Extract is a generic archive extraction mechanism. + +It allows you to extract any archive file of the type .tar, .tar.gz, +.gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma +without having to worry how it +does so, or use different interfaces for each type by using either +perl modules, or commandline tools on your system. + +See the C section further down for details. + +=cut + + +### see what /bin/programs are available ### +$PROGRAMS = {}; +CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) { + if ( $pgm eq 'unzip' and ON_FREEBSD and my $unzip = can_run('info-unzip') ) { + $PROGRAMS->{$pgm} = $unzip; + next CMD; + } + if ( $pgm eq 'unzip' and ( ON_NETBSD or ON_FREEBSD ) ) { + local $IPC::Cmd::INSTANCES = 1; + ($PROGRAMS->{$pgm}) = grep { ON_NETBSD ? m!/usr/pkg/! : m!/usr/local! } can_run($pgm); + next CMD; + } + if ( $pgm eq 'unzip' and ON_LINUX ) { + # Check if 'unzip' is busybox masquerading + local $IPC::Cmd::INSTANCES = 1; + my $opt = ON_VMS ? '"-Z"' : '-Z'; + ($PROGRAMS->{$pgm}) = grep { scalar run(command=> [ $_, $opt, '-1' ]) } can_run($pgm); + next CMD; + } + if ( $pgm eq 'tar' and ( ON_OPENBSD || ON_SOLARIS || ON_NETBSD ) ) { + # try gtar first + next CMD if $PROGRAMS->{$pgm} = can_run('gtar'); + } + $PROGRAMS->{$pgm} = can_run($pgm); +} + +### mapping from types to extractor methods ### +my $Mapping = { # binary program # pure perl module + is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, + is_tar => { bin => '_untar_bin', pp => '_untar_at' }, + is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, + is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, + is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, + is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, + is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, + is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, + is_xz => { bin => '_unxz_bin', pp => '_unxz_cz' }, + is_txz => { bin => '_untar_bin', pp => '_untar_at' }, +}; + +{ ### use subs so we re-generate array refs etc for the no-override flags + ### if we don't, then we reuse the same arrayref, meaning objects store + ### previous errors + my $tmpl = { + archive => sub { { required => 1, allow => FILE_EXISTS } }, + type => sub { { default => '', allow => [ @Types ] } }, + _error_msg => sub { { no_override => 1, default => [] } }, + _error_msg_long => sub { { no_override => 1, default => [] } }, + }; + + ### build accessors ### + for my $method( keys %$tmpl, + qw[_extractor _gunzip_to files extract_path], + ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method} = $_[0] if @_; + return $self->{$method}; + } + } + +=head1 METHODS + +=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) + +Creates a new C object based on the archive file you +passed it. Automatically determines the type of archive based on the +extension, but you can override that by explicitly providing the +C argument. + +Valid values for C are: + +=over 4 + +=item tar + +Standard tar files, as produced by, for example, C. +Corresponds to a C<.tar> suffix. + +=item tgz + +Gzip compressed tar files, as produced by, for example C. +Corresponds to a C<.tgz> or C<.tar.gz> suffix. + +=item gz + +Gzip compressed file, as produced by, for example C. +Corresponds to a C<.gz> suffix. + +=item Z + +Lempel-Ziv compressed file, as produced by, for example C. +Corresponds to a C<.Z> suffix. + +=item zip + +Zip compressed file, as produced by, for example C. +Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. + +=item bz2 + +Bzip2 compressed file, as produced by, for example, C. +Corresponds to a C<.bz2> suffix. + +=item tbz + +Bzip2 compressed tar file, as produced by, for example C. +Corresponds to a C<.tbz> or C<.tar.bz2> suffix. + +=item lzma + +Lzma compressed file, as produced by C. +Corresponds to a C<.lzma> suffix. + +=item xz + +Xz compressed file, as produced by C. +Corresponds to a C<.xz> suffix. + +=item txz + +Xz compressed tar file, as produced by, for example C. +Corresponds to a C<.txz> or C<.tar.xz> suffix. + +=back + +Returns a C object on success, or false on failure. + +=cut + + ### constructor ### + sub new { + my $class = shift; + my %hash = @_; + + ### see above why we use subs here and generate the template; + ### it's basically to not re-use arrayrefs + my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; + + my $parsed = check( \%utmpl, \%hash ) or return; + + ### make sure we have an absolute path ### + my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); + + ### figure out the type, if it wasn't already specified ### + unless ( $parsed->{type} ) { + $parsed->{type} = + $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ : + $ar =~ /.+?\.gz$/i ? GZ : + $ar =~ /.+?\.tar$/i ? TAR : + $ar =~ /.+?\.(zip|jar|ear|war|par)$/i ? ZIP : + $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ : + $ar =~ /.+?\.bz2$/i ? BZ2 : + $ar =~ /.+?\.Z$/ ? Z : + $ar =~ /.+?\.lzma$/ ? LZMA : + $ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ : + $ar =~ /.+?\.xz$/ ? XZ : + ''; + + } + + bless $parsed, $class; + + ### don't know what type of file it is + ### XXX this *has* to be an object call, not a package call + return $parsed->_error(loc("Cannot determine file type for '%1'", + $parsed->{archive} )) unless $parsed->{type}; + return $parsed; + } +} + +=head2 $ae->extract( [to => '/output/path'] ) + +Extracts the archive represented by the C object to +the path of your choice as specified by the C argument. Defaults to +C. + +Since C<.gz> files never hold a directory, but only a single file; if +the C argument is an existing directory, the file is extracted +there, with its C<.gz> suffix stripped. +If the C argument is not an existing directory, the C argument +is understood to be a filename, if the archive type is C. +In the case that you did not specify a C argument, the output +file will be the name of the archive file, stripped from its C<.gz> +suffix, in the current working directory. + +C will try a pure perl solution first, and then fall back to +commandline tools if they are available. See the C +section below on how to alter this behaviour. + +It will return true on success, and false on failure. + +On success, it will also set the follow attributes in the object: + +=over 4 + +=item $ae->extract_path + +This is the directory that the files where extracted to. + +=item $ae->files + +This is an array ref with the paths of all the files in the archive, +relative to the C argument you specified. +To get the full path to an extracted file, you would use: + + File::Spec->catfile( $to, $ae->files->[0] ); + +Note that all files from a tar archive will be in unix format, as per +the tar specification. + +=back + +=cut + +sub extract { + my $self = shift; + my %hash = @_; + + ### reset error messages + $self->_error_msg( [] ); + $self->_error_msg_long( [] ); + + my $to; + my $tmpl = { + to => { default => '.', store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + ### so 'to' could be a file or a dir, depending on whether it's a .gz + ### file, or basically anything else. + ### so, check that, then act accordingly. + ### set an accessor specifically so _gunzip can know what file to extract + ### to. + my $dir; + { ### a foo.gz file + if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) { + + my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i; + + ### to is a dir? + if ( -d $to ) { + $dir = $to; + $self->_gunzip_to( basename($cp) ); + + ### then it's a filename + } else { + $dir = dirname($to); + $self->_gunzip_to( basename($to) ); + } + + ### not a foo.gz file + } else { + $dir = $to; + } + } + + ### make the dir if it doesn't exist ### + unless( -d $dir ) { + eval { mkpath( $dir ) }; + + return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) + if $@; + } + + ### get the current dir, to restore later ### + my $cwd = cwd(); + + my $ok = 1; + EXTRACT: { + + ### chdir to the target dir ### + unless( chdir $dir ) { + $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); + $ok = 0; last EXTRACT; + } + + ### set files to an empty array ref, so there's always an array + ### ref IN the accessor, to avoid errors like: + ### Can't use an undefined value as an ARRAY reference at + ### ../lib/Archive/Extract.pm line 742. (rt #19815) + $self->files( [] ); + + ### find out the dispatch methods needed for this type of + ### archive. Do a $self->is_XXX to figure out the type, then + ### get the hashref with bin + pure perl dispatchers. + my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; + + ### add pure perl extractor if allowed & add bin extractor if allowed + my @methods; + push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; + push @methods, $map->{'bin'} if $_ALLOW_BIN; + + ### reverse it if we prefer bin extractors + @methods = reverse @methods if $PREFER_BIN; + + my($na, $fail); + for my $method (@methods) { + $self->debug( "# Extracting with ->$method\n" ); + + my $rv = $self->$method; + + ### a positive extraction + if( $rv and $rv ne METHOD_NA ) { + $self->debug( "# Extraction succeeded\n" ); + $self->_extractor($method); + last; + + ### method is not available + } elsif ( $rv and $rv eq METHOD_NA ) { + $self->debug( "# Extraction method not available\n" ); + $na++; + } else { + $self->debug( "# Extraction method failed\n" ); + $fail++; + } + } + + ### warn something went wrong if we didn't get an extractor + unless( $self->_extractor ) { + my $diag = $fail ? loc("Extract failed due to errors") : + $na ? loc("Extract failed; no extractors available") : + ''; + + $self->_error($diag); + $ok = 0; + } + } + + ### and chdir back ### + unless( chdir $cwd ) { + $self->_error(loc("Could not chdir back to start dir '%1': %2'", + $cwd, $!)); + } + + return $ok; +} + +=pod + +=head1 ACCESSORS + +=head2 $ae->error([BOOL]) + +Returns the last encountered error as string. +Pass it a true value to get the C output instead. + +=head2 $ae->extract_path + +This is the directory the archive got extracted to. +See C for details. + +=head2 $ae->files + +This is an array ref holding all the paths from the archive. +See C for details. + +=head2 $ae->archive + +This is the full path to the archive file represented by this +C object. + +=head2 $ae->type + +This is the type of archive represented by this C +object. See accessors below for an easier way to use this. +See the C method for details. + +=head2 $ae->types + +Returns a list of all known C for C's +C method. + +=cut + +sub types { return @Types } + +=head2 $ae->is_tgz + +Returns true if the file is of type C<.tar.gz>. +See the C method for details. + +=head2 $ae->is_tar + +Returns true if the file is of type C<.tar>. +See the C method for details. + +=head2 $ae->is_gz + +Returns true if the file is of type C<.gz>. +See the C method for details. + +=head2 $ae->is_Z + +Returns true if the file is of type C<.Z>. +See the C method for details. + +=head2 $ae->is_zip + +Returns true if the file is of type C<.zip>. +See the C method for details. + +=head2 $ae->is_lzma + +Returns true if the file is of type C<.lzma>. +See the C method for details. + +=head2 $ae->is_xz + +Returns true if the file is of type C<.xz>. +See the C method for details. + +=cut + +### quick check methods ### +sub is_tgz { return $_[0]->type eq TGZ } +sub is_tar { return $_[0]->type eq TAR } +sub is_gz { return $_[0]->type eq GZ } +sub is_zip { return $_[0]->type eq ZIP } +sub is_tbz { return $_[0]->type eq TBZ } +sub is_bz2 { return $_[0]->type eq BZ2 } +sub is_Z { return $_[0]->type eq Z } +sub is_lzma { return $_[0]->type eq LZMA } +sub is_xz { return $_[0]->type eq XZ } +sub is_txz { return $_[0]->type eq TXZ } + +=pod + +=head2 $ae->bin_tar + +Returns the full path to your tar binary, if found. + +=head2 $ae->bin_gzip + +Returns the full path to your gzip binary, if found + +=head2 $ae->bin_unzip + +Returns the full path to your unzip binary, if found + +=head2 $ae->bin_unlzma + +Returns the full path to your unlzma binary, if found + +=head2 $ae->bin_unxz + +Returns the full path to your unxz binary, if found + +=cut + +### paths to commandline tools ### +sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} } +sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} } +sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} } +sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} } +sub bin_uncompress { return $PROGRAMS->{'uncompress'} + if $PROGRAMS->{'uncompress'} } +sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} } +sub bin_unxz { return $PROGRAMS->{'unxz'} if $PROGRAMS->{'unxz'} } + +=head2 $bool = $ae->have_old_bunzip2 + +Older versions of C, from before the C 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 +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! + + ### double hateful: bunzip2 --version also hangs if input is a pipe + ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] + ### So, we have to provide *another* argument which is a fake filename, + ### just so it wont try to read from stdin to print its version.. + ### *sigh* + ### Even if the file exists, it won't clobber or change it. + my $buffer; + scalar run( + command => [$self->bin_bunzip2, '--version', 'NoSuchFile'], + verbose => 0, + buffer => \$buffer + ); + + ### no output + return unless $buffer; + + my ($version) = $buffer =~ /version \s+ (\d+)/ix; + + return 1 if $version < 1; + return; +} + +################################# +# +# Untar code +# +################################# + +### annoying issue with (gnu) tar on win32, as illustrated by this +### bug: https://rt.cpan.org/Ticket/Display.html?id=40138 +### which shows that (gnu) tar will interpret a file name with a : +### in it as a remote file name, so C:\tmp\foo.txt is interpreted +### as a remote shell, and the extract fails. +{ my @ExtraTarFlags; + if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) { + + ### if this is gnu tar we are running, we need to use --force-local + push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i; + } + + + ### use /bin/tar to extract ### + sub _untar_bin { + my $self = shift; + + ### check for /bin/tar ### + ### check for /bin/gzip if we need it ### + ### if any of the binaries are not available, return NA + { my $diag = !$self->bin_tar ? + loc("No '%1' program found", '/bin/tar') : + $self->is_tgz && !$self->bin_gzip ? + loc("No '%1' program found", '/bin/gzip') : + $self->is_tbz && !$self->bin_bunzip2 ? + loc("No '%1' program found", '/bin/bunzip2') : + $self->is_txz && !$self->bin_unxz ? + loc("No '%1' program found", '/bin/unxz') : + ''; + + if( $diag ) { + $self->_error( $diag ); + return METHOD_NA; + } + } + + ### XXX figure out how to make IPC::Run do this in one call -- + ### currently i don't know how to get output of a command after a pipe + ### trapped in a scalar. Mailed barries about this 5th of june 2004. + + ### see what command we should run, based on whether + ### it's a .tgz or .tar + + ### GNU tar can't handled VMS filespecs, but VMSTAR can handle Unix filespecs. + my $archive = $self->archive; + $archive = VMS::Filespec::unixify($archive) if ON_VMS; + + ### XXX solaris tar and bsdtar are having different outputs + ### depending whether you run with -x or -t + ### compensate for this insanity by running -t first, then -x + { my $cmd = + $self->is_tgz ? [$self->bin_gzip, '-c', '-d', '-f', $archive, '|', + $self->bin_tar, '-tf', '-'] : + $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', + $self->bin_tar, '-tf', '-'] : + $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', + $self->bin_tar, '-tf', '-'] : + [$self->bin_tar, @ExtraTarFlags, '-tf', $archive]; + + ### run the command + ### newer versions of 'tar' (1.21 and up) now print record size + ### to STDERR as well if v OR t is given (used to be both). This + ### is a 'feature' according to the changelog, so we must now only + ### inspect STDOUT, otherwise, failures like these occur: + ### http://www.cpantesters.org/cpan/report/3230366 + my $buffer = ''; + my @out = run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ); + + ### command was unsuccessful + unless( $out[0] ) { + return $self->_error(loc( + "Error listing contents of archive '%1': %2", + $archive, $buffer )); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_files( $archive ) ); + + } else { + ### if we're on solaris we /might/ be using /bin/tar, which has + ### a weird output format... we might also be using + ### /usr/local/bin/tar, which is gnu tar, which is perfectly + ### fine... so we have to do some guessing here =/ + my @files = map { chomp; + !ON_SOLARIS ? $_ + : (m|^ x \s+ # 'xtract' -- sigh + (.+?), # the actual file name + \s+ [\d,.]+ \s bytes, + \s+ [\d,.]+ \s tape \s blocks + |x ? $1 : $_); + + ### only STDOUT, see above. Sometimes, extra whitespace + ### is present, so make sure we only pick lines with + ### a length + } grep { length } map { split $/, $_ } join '', @{$out[3]}; + + ### store the files that are in the archive ### + $self->files(\@files); + } + } + + ### now actually extract it ### + { my $cmd = + $self->is_tgz ? [$self->bin_gzip, '-c', '-d', '-f', $archive, '|', + $self->bin_tar, '-xf', '-'] : + $self->is_tbz ? [$self->bin_bunzip2, '-cd', $archive, '|', + $self->bin_tar, '-xf', '-'] : + $self->is_txz ? [$self->bin_unxz, '-cd', $archive, '|', + $self->bin_tar, '-xf', '-'] : + [$self->bin_tar, @ExtraTarFlags, '-xf', $archive]; + + my $buffer = ''; + unless( scalar run( command => $cmd, + buffer => \$buffer, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Error extracting archive '%1': %2", + $archive, $buffer )); + } + + ### we might not have them, due to lack of buffers + if( $self->files ) { + ### now that we've extracted, figure out where we extracted to + my $dir = $self->__get_extract_dir( $self->files ); + + ### store the extraction dir ### + $self->extract_path( $dir ); + } + } + + ### we got here, no error happened + return 1; + } +} + + +### use archive::tar to extract ### +sub _untar_at { + my $self = shift; + + ### Loading Archive::Tar is going to set it to 1, so make it local + ### within this block, starting with its initial value. Whatever + ### Achive::Tar does will be undone when we return. + ### + ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN + ### so users don't have to even think about this variable. If they + ### do, they still get their set value outside of this call. + local $Archive::Tar::WARN = $Archive::Tar::WARN; + + ### we definitely need Archive::Tar, so load that first + { my $use_list = { 'Archive::Tar' => '0.0' }; + + unless( can_load( modules => $use_list ) ) { + + $self->_error(loc("You do not have '%1' installed - " . + "Please install it as soon as possible.", + 'Archive::Tar')); + + return METHOD_NA; + } + } + + ### we might pass it a filehandle if it's a .tbz file.. + my $fh_to_read = $self->archive; + + ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib + ### if A::T's version is 0.99 or higher + if( $self->is_tgz ) { + my $use_list = { 'Compress::Zlib' => '0.0' }; + $use_list->{ 'IO::Zlib' } = '0.0' + if $Archive::Tar::VERSION >= '0.99'; + + unless( can_load( modules => $use_list ) ) { + my $which = join '/', sort keys %$use_list; + + $self->_error(loc( + "You do not have '%1' installed - Please ". + "install it as soon as possible.", $which) + ); + + return METHOD_NA; + } + + } elsif ( $self->is_tbz ) { + my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc( + "You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2') + ); + + return METHOD_NA; + } + + my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, + $IO::Uncompress::Bunzip2::Bunzip2Error)); + + $fh_to_read = $bz; + } elsif ( $self->is_txz ) { + my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc( + "You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::UnXz') + ); + + return METHOD_NA; + } + + my $xz = IO::Uncompress::UnXz->new( $self->archive ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, + $IO::Uncompress::UnXz::UnXzError)); + + $fh_to_read = $xz; + } + + 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; + + ### 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 ) ); + + ### for version of Archive::Tar > 1.04 + local $Archive::Tar::CHOWN = 0; + + ### 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' ) ) { + + my $next; + unless ( $next = Archive::Tar->iter( @read ) ) { + return $self->_error(loc( + "Unable to read '%1': %2", $self->archive, + $Archive::Tar::error)); + } + + while ( my $file = $next->() ) { + push @files, $file->full_path; + + $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 { + + 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 $dir = $self->__get_extract_dir( \@files ); + + ### store the files that are in the archive ### + $self->files(\@files); + + ### store the extraction dir ### + $self->extract_path( $dir ); + + ### check if the dir actually appeared ### + return 1 if -d $self->extract_path; + + ### no dir, we failed ### + return $self->_error(loc("Unable to extract '%1': %2", + $self->archive, $Archive::Tar::error )); +} + +################################# +# +# Gunzip code +# +################################# + +sub _gunzip_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_gzip ) { + $self->_error(loc("No '%1' program found", '/bin/gzip')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_gzip, '-c', '-d', '-f', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to gunzip '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _gunzip_cz { + my $self = shift; + + my $use_list = { 'Compress::Zlib' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Compress::Zlib')); + return METHOD_NA; + } + + my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or + return $self->_error(loc("Unable to open '%1': %2", + $self->archive, $Compress::Zlib::gzerrno)); + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $buffer; + $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0; + $fh->close; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# Uncompress code +# +################################# + +sub _uncompress_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_uncompress ) { + $self->_error(loc("No '%1' program found", '/bin/uncompress')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_uncompress, '-c', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + + +################################# +# +# Unzip code +# +################################# + + +sub _unzip_bin { + my $self = shift; + + ### check for /bin/gzip if we need it ### + unless( $self->bin_unzip ) { + $self->_error(loc("No '%1' program found", '/bin/unzip')); + return METHOD_NA; + } + + ### first, get the files.. it must be 2 different commands with 'unzip' :( + { ### on VMS, capital letter options have to be quoted. This is + ### reported 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, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_files( $self->archive ) ); + + } else { + ### Annoyingly, pesky MSWin32 can either have 'native' tools + ### which have \r\n line endings or Cygwin-based tools which + ### have \n line endings. Jan Dubois suggested using this fix + my $split = ON_WIN32 ? qr/\r?\n/ : "\n"; + $self->files( [split $split, $buffer] ); + } + } + + ### now, extract the archive ### + { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unzip '%1': %2", + $self->archive, $buffer)); + } + + if( scalar @{$self->files} ) { + my $files = $self->files; + my $dir = $self->__get_extract_dir( $files ); + + $self->extract_path( $dir ); + } + } + + return 1; +} + +sub _unzip_az { + my $self = shift; + + my $use_list = { 'Archive::Zip' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", 'Archive::Zip')); + return METHOD_NA; + } + + my $zip = Archive::Zip->new(); + + unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Unable to read '%1'", $self->archive)); + } + + my @files; + + + ### Address: #43278: Explicitly tell Archive::Zip where to put the files: + ### "In my BackPAN indexing, Archive::Zip was extracting things + ### in my script's directory instead of the current working directory. + ### I traced this back through Archive::Zip::_asLocalName which + ### eventually calls File::Spec::Win32::rel2abs which on Windows might + ### call Cwd::getdcwd. getdcwd returns the wrong directory in my + ### case, even though I think I'm on the same drive. + ### + ### To fix this, I pass the optional second argument to + ### extractMember using the cwd from Archive::Extract." --bdfoy + + ## store cwd() before looping; calls to cwd() can be expensive, and + ### it won't change during the loop + my $extract_dir = cwd(); + + ### have to extract every member individually ### + for my $member ($zip->members) { + push @files, $member->{fileName}; + + ### file to extract to, to avoid the above problem + my $to = File::Spec->catfile( $extract_dir, $member->{fileName} ); + + unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) { + return $self->_error(loc("Extraction of '%1' from '%2' failed", + $member->{fileName}, $self->archive )); + } + } + + my $dir = $self->__get_extract_dir( \@files ); + + ### set what files where extract, and where they went ### + $self->files( \@files ); + $self->extract_path( File::Spec->rel2abs($dir) ); + + return 1; +} + +sub __get_extract_dir { + my $self = shift; + my $files = shift || []; + + return unless scalar @$files; + + my($dir1, $dir2); + for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { + my($dir,$pos) = @$aref; + + ### add a catdir(), so that any trailing slashes get + ### take care of (removed) + ### also, a catdir() normalises './dir/foo' to 'dir/foo'; + ### which was the problem in bug #23999 + my $res = -d $files->[$pos] + ? File::Spec->catdir( $files->[$pos], '' ) + : File::Spec->catdir( dirname( $files->[$pos] ) ); + + $$dir = $res; + } + + ### if the first and last dir don't match, make sure the + ### dirname is not set wrongly + my $dir; + + ### dirs are the same, so we know for sure what the extract dir is + if( $dir1 eq $dir2 ) { + $dir = $dir1; + + ### dirs are different.. do they share the base dir? + ### if so, use that, if not, fall back to '.' + } else { + my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0]; + my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0]; + + $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' ); + } + + return File::Spec->rel2abs( $dir ); +} + +################################# +# +# Bunzip2 code +# +################################# + +sub _bunzip2_bin { + my $self = shift; + + ### check for /bin/gzip -- we need it ### + unless( $self->bin_bunzip2 ) { + $self->_error(loc("No '%1' program found", '/bin/bunzip2')); + return METHOD_NA; + } + + 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, '-cd', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to bunzip2 '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +### using cz2, the compact versions... this we use mainly in archive::tar +### extractor.. +# sub _bunzip2_cz1 { +# my $self = shift; +# +# my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; +# unless( can_load( modules => $use_list ) ) { +# return $self->_error(loc("You do not have '%1' installed - Please " . +# "install it as soon as possible.", +# 'IO::Uncompress::Bunzip2')); +# } +# +# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or +# return $self->_error(loc("Unable to open '%1': %2", +# $self->archive, +# $IO::Uncompress::Bunzip2::Bunzip2Error)); +# +# my $fh = FileHandle->new('>'. $self->_gunzip_to) or +# return $self->_error(loc("Could not open '%1' for writing: %2", +# $self->_gunzip_to, $! )); +# +# my $buffer; +# $fh->print($buffer) while $bz->read($buffer) > 0; +# $fh->close; +# +# ### set what files where extract, and where they went ### +# $self->files( [$self->_gunzip_to] ); +# $self->extract_path( File::Spec->rel2abs(cwd()) ); +# +# return 1; +# } + +sub _bunzip2_bz2 { + my $self = shift; + + my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::Bunzip2')); + return METHOD_NA; + } + + IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::Bunzip2::Bunzip2Error)); + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# UnXz code +# +################################# + +sub _unxz_bin { + my $self = shift; + + ### check for /bin/unxz -- we need it ### + unless( $self->bin_unxz ) { + $self->_error(loc("No '%1' program found", '/bin/unxz')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_unxz, '-c', '-d', '-f', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unxz '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _unxz_cz { + my $self = shift; + + my $use_list = { 'IO::Uncompress::UnXz' => '0.0' }; + unless( can_load( modules => $use_list ) ) { + $self->_error(loc("You do not have '%1' installed - Please " . + "install it as soon as possible.", + 'IO::Uncompress::UnXz')); + return METHOD_NA; + } + + IO::Uncompress::UnXz::unxz($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::UnXz::UnXzError)); + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + + +################################# +# +# unlzma code +# +################################# + +sub _unlzma_bin { + my $self = shift; + + ### check for /bin/unlzma -- we need it ### + unless( $self->bin_unlzma ) { + $self->_error(loc("No '%1' program found", '/bin/unlzma')); + return METHOD_NA; + } + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $cmd = [ $self->bin_unlzma, '-c', $self->archive ]; + + my $buffer; + unless( scalar run( command => $cmd, + verbose => $DEBUG, + buffer => \$buffer ) + ) { + return $self->_error(loc("Unable to unlzma '%1': %2", + $self->archive, $buffer)); + } + + ### no buffers available? + if( !IPC::Cmd->can_capture_buffer and !$buffer ) { + $self->_error( $self->_no_buffer_content( $self->archive ) ); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +sub _unlzma_cz { + my $self = shift; + + my $use_list1 = { 'IO::Uncompress::UnLzma' => '0.0' }; + my $use_list2 = { 'Compress::unLZMA' => '0.0' }; + + if (can_load( modules => $use_list1 ) ) { + IO::Uncompress::UnLzma::unlzma($self->archive => $self->_gunzip_to) + or return $self->_error(loc("Unable to uncompress '%1': %2", + $self->archive, + $IO::Uncompress::UnLzma::UnLzmaError)); + } + elsif (can_load( modules => $use_list2 ) ) { + + my $fh = FileHandle->new('>'. $self->_gunzip_to) or + return $self->_error(loc("Could not open '%1' for writing: %2", + $self->_gunzip_to, $! )); + + my $buffer; + $buffer = Compress::unLZMA::uncompressfile( $self->archive ); + unless ( defined $buffer ) { + return $self->_error(loc("Could not unlzma '%1': %2", + $self->archive, $@)); + } + + $self->_print($fh, $buffer) if defined $buffer; + + close $fh; + } + else { + $self->_error(loc("You do not have '%1' or '%2' installed - Please " . + "install it as soon as possible.", 'Compress::unLZMA', 'IO::Uncompress::UnLzma')); + return METHOD_NA; + } + + ### set what files where extract, and where they went ### + $self->files( [$self->_gunzip_to] ); + $self->extract_path( File::Spec->rel2abs(cwd()) ); + + return 1; +} + +################################# +# +# Error code +# +################################# + +# For printing binaries that avoids interfering globals +sub _print { + my $self = shift; + my $fh = shift; + + local( $\, $", $, ) = ( undef, ' ', '' ); + return print $fh @_; +} + +sub _error { + my $self = shift; + my $error = shift; + my $lerror = Carp::longmess($error); + + push @{$self->_error_msg}, $error; + push @{$self->_error_msg_long}, $lerror; + + ### set $Archive::Extract::WARN to 0 to disable printing + ### of errors + if( $WARN ) { + carp $DEBUG ? $lerror : $error; + } + + return; +} + +sub error { + my $self = shift; + + ### make sure we have a fallback aref + my $aref = do { + shift() + ? $self->_error_msg_long + : $self->_error_msg + } || []; + + return join $/, @$aref; +} + +=head2 debug( MESSAGE ) + +This method outputs MESSAGE to the default filehandle if C<$DEBUG> is +true. It's a small method, but it's here if you'd like to subclass it +so you can so something else with any debugging output. + +=cut + +### this is really a stub for subclassing +sub debug { + return unless $DEBUG; + + print $_[1]; +} + +sub _no_buffer_files { + my $self = shift; + my $file = shift or return; + return loc("No buffer captured, unable to tell ". + "extracted files or extraction dir for '%1'", $file); +} + +sub _no_buffer_content { + my $self = shift; + my $file = shift or return; + return loc("No buffer captured, unable to get content for '%1'", $file); +} +1; + +=pod + +=head1 HOW IT WORKS + +C tries first to determine what type of archive you +are passing it, by inspecting its suffix. It does not do this by using +Mime magic, or something related. See C below. + +Once it has determined the file type, it knows which extraction methods +it can use on the archive. It will try a perl solution first, then fall +back to a commandline tool if that fails. If that also fails, it will +return false, indicating it was unable to extract the archive. +See the section on C to see how to alter this order. + +=head1 CAVEATS + +=head2 File Extensions + +C trusts on the extension of the archive to determine +what type it is, and what extractor methods therefore can be used. If +your archives do not have any of the extensions as described in the +C method, you will have to specify the type explicitly, or +C will not be able to extract the archive for you. + +=head2 Supporting Very Large Files + +C can use either pure perl modules or command line +programs under the hood. Some of the pure perl modules (like +C and Compress::unLZMA) 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 section below for details. + +=head2 Bunzip2 support of arbitrary extensions. + +Older versions of C 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 +method. + +=head1 GLOBAL VARIABLES + +=head2 $Archive::Extract::DEBUG + +Set this variable to C to have all calls to command line tools +be printed out, including all their output. +This also enables C errors, instead of the regular +C errors. + +Good for tracking down why things don't work with your particular +setup. + +Defaults to C. + +=head2 $Archive::Extract::WARN + +This variable controls whether errors encountered internally by +C should be C'd or not. + +Set to false to silence warnings. Inspect the output of the C +method manually to see what went wrong. + +Defaults to C. + +=head2 $Archive::Extract::PREFER_BIN + +This variables controls whether C should prefer the +use of perl modules, or commandline tools to extract archives. + +Set to C to have C prefer commandline tools. + +Defaults to C. + +=head1 TODO / CAVEATS + +=over 4 + +=item Mime magic support + +Maybe this module should use something like C to determine +the type, rather than blindly trust the suffix. + +=item Thread safety + +Currently, C does a C to the extraction dir before +extraction, and a C back again after. This is not necessarily +thread safe. See C bug C<#45671> for details. + +=back + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-archive-extract@rt.cpan.orgE. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip.pm new file mode 100644 index 00000000000..0fdbf17bb39 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip.pm @@ -0,0 +1,2136 @@ +package Archive::Zip; + +use 5.006; +use strict; +use Carp (); +use Cwd (); +use IO::File (); +use IO::Seekable (); +use Compress::Raw::Zlib (); +use File::Spec (); +use File::Temp (); +use FileHandle (); + +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + + require Exporter; + @ISA = qw( Exporter ); +} + +use vars qw( $ChunkSize $ErrorHandler ); + +BEGIN { + # This is the size we'll try to read, write, and (de)compress. + # You could set it to something different if you had lots of memory + # and needed more speed. + $ChunkSize ||= 32768; + + $ErrorHandler = \&Carp::carp; +} + +# BEGIN block is necessary here so that other modules can use the constants. +use vars qw( @EXPORT_OK %EXPORT_TAGS ); + +BEGIN { + @EXPORT_OK = ('computeCRC32'); + %EXPORT_TAGS = ( + CONSTANTS => [ + qw( + FA_MSDOS + FA_UNIX + GPBF_ENCRYPTED_MASK + GPBF_DEFLATING_COMPRESSION_MASK + GPBF_HAS_DATA_DESCRIPTOR_MASK + COMPRESSION_STORED + COMPRESSION_DEFLATED + COMPRESSION_LEVEL_NONE + COMPRESSION_LEVEL_DEFAULT + COMPRESSION_LEVEL_FASTEST + COMPRESSION_LEVEL_BEST_COMPRESSION + IFA_TEXT_FILE_MASK + IFA_TEXT_FILE + IFA_BINARY_FILE + ) + ], + + MISC_CONSTANTS => [ + qw( + FA_AMIGA + FA_VAX_VMS + FA_VM_CMS + FA_ATARI_ST + FA_OS2_HPFS + FA_MACINTOSH + FA_Z_SYSTEM + FA_CPM + FA_TOPS20 + FA_WINDOWS_NTFS + FA_QDOS + FA_ACORN + FA_VFAT + FA_MVS + FA_BEOS + FA_TANDEM + FA_THEOS + GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK + GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK + GPBF_IS_COMPRESSED_PATCHED_DATA_MASK + COMPRESSION_SHRUNK + DEFLATING_COMPRESSION_NORMAL + DEFLATING_COMPRESSION_MAXIMUM + DEFLATING_COMPRESSION_FAST + DEFLATING_COMPRESSION_SUPER_FAST + COMPRESSION_REDUCED_1 + COMPRESSION_REDUCED_2 + COMPRESSION_REDUCED_3 + COMPRESSION_REDUCED_4 + COMPRESSION_IMPLODED + COMPRESSION_TOKENIZED + COMPRESSION_DEFLATED_ENHANCED + COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED + ) + ], + + ERROR_CODES => [ + qw( + AZ_OK + AZ_STREAM_END + AZ_ERROR + AZ_FORMAT_ERROR + AZ_IO_ERROR + ) + ], + + # For Internal Use Only + PKZIP_CONSTANTS => [ + qw( + SIGNATURE_FORMAT + SIGNATURE_LENGTH + LOCAL_FILE_HEADER_SIGNATURE + LOCAL_FILE_HEADER_FORMAT + LOCAL_FILE_HEADER_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE + DATA_DESCRIPTOR_FORMAT + DATA_DESCRIPTOR_LENGTH + DATA_DESCRIPTOR_SIGNATURE + DATA_DESCRIPTOR_FORMAT_NO_SIG + DATA_DESCRIPTOR_LENGTH_NO_SIG + CENTRAL_DIRECTORY_FILE_HEADER_FORMAT + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH + END_OF_CENTRAL_DIRECTORY_SIGNATURE + END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING + END_OF_CENTRAL_DIRECTORY_FORMAT + END_OF_CENTRAL_DIRECTORY_LENGTH + ) + ], + + # For Internal Use Only + UTILITY_METHODS => [ + qw( + _error + _printError + _ioError + _formatError + _subclassResponsibility + _binmode + _isSeekable + _newFileHandle + _readSignature + _asZipDirName + ) + ], + ); + + # Add all the constant names and error code names to @EXPORT_OK + Exporter::export_ok_tags( + qw( + CONSTANTS + ERROR_CODES + PKZIP_CONSTANTS + UTILITY_METHODS + MISC_CONSTANTS + )); + +} + +# Error codes +use constant AZ_OK => 0; +use constant AZ_STREAM_END => 1; +use constant AZ_ERROR => 2; +use constant AZ_FORMAT_ERROR => 3; +use constant AZ_IO_ERROR => 4; + +# File types +# Values of Archive::Zip::Member->fileAttributeFormat() + +use constant FA_MSDOS => 0; +use constant FA_AMIGA => 1; +use constant FA_VAX_VMS => 2; +use constant FA_UNIX => 3; +use constant FA_VM_CMS => 4; +use constant FA_ATARI_ST => 5; +use constant FA_OS2_HPFS => 6; +use constant FA_MACINTOSH => 7; +use constant FA_Z_SYSTEM => 8; +use constant FA_CPM => 9; +use constant FA_TOPS20 => 10; +use constant FA_WINDOWS_NTFS => 11; +use constant FA_QDOS => 12; +use constant FA_ACORN => 13; +use constant FA_VFAT => 14; +use constant FA_MVS => 15; +use constant FA_BEOS => 16; +use constant FA_TANDEM => 17; +use constant FA_THEOS => 18; + +# general-purpose bit flag masks +# Found in Archive::Zip::Member->bitFlag() + +use constant GPBF_ENCRYPTED_MASK => 1 << 0; +use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1; +use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3; + +# deflating compression types, if compressionMethod == COMPRESSION_DEFLATED +# ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK ) + +use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1; +use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1; +use constant DEFLATING_COMPRESSION_FAST => 2 << 1; +use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1; + +# compression method + +# these two are the only ones supported in this module +use constant COMPRESSION_STORED => 0; # file is stored (no compression) +use constant COMPRESSION_DEFLATED => 8; # file is Deflated +use constant COMPRESSION_LEVEL_NONE => 0; +use constant COMPRESSION_LEVEL_DEFAULT => -1; +use constant COMPRESSION_LEVEL_FASTEST => 1; +use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9; + +# internal file attribute bits +# Found in Archive::Zip::Member::internalFileAttributes() + +use constant IFA_TEXT_FILE_MASK => 1; +use constant IFA_TEXT_FILE => 1; +use constant IFA_BINARY_FILE => 0; + +# PKZIP file format miscellaneous constants (for internal use only) +use constant SIGNATURE_FORMAT => "V"; +use constant SIGNATURE_LENGTH => 4; + +# these lengths are without the signature. +use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50; +use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2"; +use constant LOCAL_FILE_HEADER_LENGTH => 26; + +# PKZIP docs don't mention the signature, but Info-Zip writes it. +use constant DATA_DESCRIPTOR_SIGNATURE => 0x08074b50; +use constant DATA_DESCRIPTOR_FORMAT => "V3"; +use constant DATA_DESCRIPTOR_LENGTH => 12; + +# but the signature is apparently optional. +use constant DATA_DESCRIPTOR_FORMAT_NO_SIG => "V2"; +use constant DATA_DESCRIPTOR_LENGTH_NO_SIG => 8; + +use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50; +use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2"; +use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42; + +use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50; +use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING => + pack("V", END_OF_CENTRAL_DIRECTORY_SIGNATURE); +use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v"; +use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18; + +use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1; +use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2; +use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5; + +# the rest of these are not supported in this module +use constant COMPRESSION_SHRUNK => 1; # file is Shrunk +use constant COMPRESSION_REDUCED_1 => 2; # file is Reduced CF=1 +use constant COMPRESSION_REDUCED_2 => 3; # file is Reduced CF=2 +use constant COMPRESSION_REDUCED_3 => 4; # file is Reduced CF=3 +use constant COMPRESSION_REDUCED_4 => 5; # file is Reduced CF=4 +use constant COMPRESSION_IMPLODED => 6; # file is Imploded +use constant COMPRESSION_TOKENIZED => 7; # reserved for Tokenizing compr. +use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating +use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10; + +# Load the various required classes +require Archive::Zip::Archive; +require Archive::Zip::Member; +require Archive::Zip::FileMember; +require Archive::Zip::DirectoryMember; +require Archive::Zip::ZipFileMember; +require Archive::Zip::NewFileMember; +require Archive::Zip::StringMember; + +# Convenience functions + +sub _ISA ($$) { + + # Can't rely on Scalar::Util, so use the next best way + local $@; + !!eval { ref $_[0] and $_[0]->isa($_[1]) }; +} + +sub _CAN ($$) { + local $@; + !!eval { ref $_[0] and $_[0]->can($_[1]) }; +} + +##################################################################### +# Methods + +sub new { + my $class = shift; + return Archive::Zip::Archive->new(@_); +} + +sub computeCRC32 { + my ($data, $crc); + + if (ref($_[0]) eq 'HASH') { + $data = $_[0]->{string}; + $crc = $_[0]->{checksum}; + } else { + $data = shift; + $data = shift if ref($data); + $crc = shift; + } + + return Compress::Raw::Zlib::crc32($data, $crc); +} + +# Report or change chunk size used for reading and writing. +# Also sets Zlib's default buffer size (eventually). +sub setChunkSize { + shift if ref($_[0]) eq 'Archive::Zip::Archive'; + my $chunkSize = (ref($_[0]) eq 'HASH') ? shift->{chunkSize} : shift; + my $oldChunkSize = $Archive::Zip::ChunkSize; + $Archive::Zip::ChunkSize = $chunkSize if ($chunkSize); + return $oldChunkSize; +} + +sub chunkSize { + return $Archive::Zip::ChunkSize; +} + +sub setErrorHandler { + my $errorHandler = (ref($_[0]) eq 'HASH') ? shift->{subroutine} : shift; + $errorHandler = \&Carp::carp unless defined($errorHandler); + my $oldErrorHandler = $Archive::Zip::ErrorHandler; + $Archive::Zip::ErrorHandler = $errorHandler; + return $oldErrorHandler; +} + +###################################################################### +# Private utility functions (not methods). + +sub _printError { + my $string = join(' ', @_, "\n"); + my $oldCarpLevel = $Carp::CarpLevel; + $Carp::CarpLevel += 2; + &{$ErrorHandler}($string); + $Carp::CarpLevel = $oldCarpLevel; +} + +# This is called on format errors. +sub _formatError { + shift if ref($_[0]); + _printError('format error:', @_); + return AZ_FORMAT_ERROR; +} + +# This is called on IO errors. +sub _ioError { + shift if ref($_[0]); + _printError('IO error:', @_, ':', $!); + return AZ_IO_ERROR; +} + +# This is called on generic errors. +sub _error { + shift if ref($_[0]); + _printError('error:', @_); + return AZ_ERROR; +} + +# Called when a subclass should have implemented +# something but didn't +sub _subclassResponsibility { + Carp::croak("subclass Responsibility\n"); +} + +# Try to set the given file handle or object into binary mode. +sub _binmode { + my $fh = shift; + return _CAN($fh, 'binmode') ? $fh->binmode() : binmode($fh); +} + +# Attempt to guess whether file handle is seekable. +# Because of problems with Windows, this only returns true when +# the file handle is a real file. +sub _isSeekable { + my $fh = shift; + return 0 unless ref $fh; + _ISA($fh, "IO::Scalar") # IO::Scalar objects are brokenly-seekable + and return 0; + _ISA($fh, "IO::String") + and return 1; + if (_ISA($fh, "IO::Seekable")) { + + # Unfortunately, some things like FileHandle objects + # return true for Seekable, but AREN'T!!!!! + _ISA($fh, "FileHandle") + and return 0; + return 1; + } + + # open my $fh, "+<", \$data; + ref $fh eq "GLOB" && eval { seek $fh, 0, 1 } and return 1; + _CAN($fh, "stat") + and return -f $fh; + return (_CAN($fh, "seek") and _CAN($fh, "tell")) ? 1 : 0; +} + +# Print to the filehandle, while making sure the pesky Perl special global +# variables don't interfere. +sub _print { + my ($self, $fh, @data) = @_; + + local $\; + + return $fh->print(@data); +} + +# Return an opened IO::Handle +# my ( $status, fh ) = _newFileHandle( 'fileName', 'w' ); +# Can take a filename, file handle, or ref to GLOB +# Or, if given something that is a ref but not an IO::Handle, +# passes back the same thing. +sub _newFileHandle { + my $fd = shift; + my $status = 1; + my $handle; + + if (ref($fd)) { + if (_ISA($fd, 'IO::Scalar') or _ISA($fd, 'IO::String')) { + $handle = $fd; + } elsif (_ISA($fd, 'IO::Handle') or ref($fd) eq 'GLOB') { + $handle = IO::File->new; + $status = $handle->fdopen($fd, @_); + } else { + $handle = $fd; + } + } else { + $handle = IO::File->new; + $status = $handle->open($fd, @_); + } + + return ($status, $handle); +} + +# Returns next signature from given file handle, leaves +# file handle positioned afterwards. +# In list context, returns ($status, $signature) +# ( $status, $signature) = _readSignature( $fh, $fileName ); + +sub _readSignature { + my $fh = shift; + my $fileName = shift; + my $expectedSignature = shift; # optional + + my $signatureData; + my $bytesRead = $fh->read($signatureData, SIGNATURE_LENGTH); + if ($bytesRead != SIGNATURE_LENGTH) { + return _ioError("reading header signature"); + } + my $signature = unpack(SIGNATURE_FORMAT, $signatureData); + my $status = AZ_OK; + + # compare with expected signature, if any, or any known signature. + if ( + (defined($expectedSignature) && $signature != $expectedSignature) + || ( !defined($expectedSignature) + && $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE + && $signature != LOCAL_FILE_HEADER_SIGNATURE + && $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE + && $signature != DATA_DESCRIPTOR_SIGNATURE) + ) { + my $errmsg = sprintf("bad signature: 0x%08x", $signature); + if (_isSeekable($fh)) { + $errmsg .= sprintf(" at offset %d", $fh->tell() - SIGNATURE_LENGTH); + } + + $status = _formatError("$errmsg in file $fileName"); + } + + return ($status, $signature); +} + +# Utility method to make and open a temp file. +# Will create $temp_dir if it does not exist. +# Returns file handle and name: +# +# my ($fh, $name) = Archive::Zip::tempFile(); +# my ($fh, $name) = Archive::Zip::tempFile('mytempdir'); +# + +sub tempFile { + my $dir = (ref($_[0]) eq 'HASH') ? shift->{tempDir} : shift; + my ($fh, $filename) = File::Temp::tempfile( + SUFFIX => '.zip', + UNLINK => 1, + $dir ? (DIR => $dir) : ()); + return (undef, undef) unless $fh; + my ($status, $newfh) = _newFileHandle($fh, 'w+'); + return ($newfh, $filename); +} + +# Return the normalized directory name as used in a zip file (path +# separators become slashes, etc.). +# Will translate internal slashes in path components (i.e. on Macs) to +# underscores. Discards volume names. +# When $forceDir is set, returns paths with trailing slashes (or arrays +# with trailing blank members). +# +# If third argument is a reference, returns volume information there. +# +# input output +# . ('.') '.' +# ./a ('a') a +# ./a/b ('a','b') a/b +# ./a/b/ ('a','b') a/b +# a/b/ ('a','b') a/b +# /a/b/ ('','a','b') a/b +# c:\a\b\c.doc ('','a','b','c.doc') a/b/c.doc # on Windows +# "i/o maps:whatever" ('i_o maps', 'whatever') "i_o maps/whatever" # on Macs +sub _asZipDirName { + my $name = shift; + my $forceDir = shift; + my $volReturn = shift; + my ($volume, $directories, $file) = + File::Spec->splitpath(File::Spec->canonpath($name), $forceDir); + $$volReturn = $volume if (ref($volReturn)); + my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories); + if (@dirs > 0) { pop(@dirs) unless $dirs[-1] } # remove empty component + push(@dirs, defined($file) ? $file : ''); + + #return wantarray ? @dirs : join ( '/', @dirs ); + + my $normalised_path = join '/', @dirs; + + # Leading directory separators should not be stored in zip archives. + # Example: + # C:\a\b\c\ a/b/c + # C:\a\b\c.txt a/b/c.txt + # /a/b/c/ a/b/c + # /a/b/c.txt a/b/c.txt + $normalised_path =~ s{^/}{}; # remove leading separator + + return $normalised_path; +} + +# Return an absolute local name for a zip name. +# Assume a directory if zip name has trailing slash. +# Takes an optional volume name in FS format (like 'a:'). +# +sub _asLocalName { + my $name = shift; # zip format + my $volume = shift; + $volume = '' unless defined($volume); # local FS format + + my @paths = split(/\//, $name); + my $filename = pop(@paths); + $filename = '' unless defined($filename); + my $localDirs = @paths ? File::Spec->catdir(@paths) : ''; + my $localName = File::Spec->catpath($volume, $localDirs, $filename); + unless ($volume) { + $localName = File::Spec->rel2abs($localName, Cwd::getcwd()); + } + return $localName; +} + +1; + +__END__ + +=pod + +=encoding utf8 + +=head1 NAME + +Archive::Zip - Provide an interface to ZIP archive files. + +=head1 SYNOPSIS + + # Create a Zip file + use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); + my $zip = Archive::Zip->new(); + + # Add a directory + my $dir_member = $zip->addDirectory( 'dirname/' ); + + # Add a file from a string with compression + my $string_member = $zip->addString( 'This is a test', 'stringMember.txt' ); + $string_member->desiredCompressionMethod( COMPRESSION_DEFLATED ); + + # Add a file from disk + my $file_member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' ); + + # Save the Zip file + unless ( $zip->writeToFileNamed('someZip.zip') == AZ_OK ) { + die 'write error'; + } + + # Read a Zip file + my $somezip = Archive::Zip->new(); + unless ( $somezip->read( 'someZip.zip' ) == AZ_OK ) { + die 'read error'; + } + + # Change the compression type for a file in the Zip + my $member = $somezip->memberNamed( 'stringMember.txt' ); + $member->desiredCompressionMethod( COMPRESSION_STORED ); + unless ( $zip->writeToFileNamed( 'someOtherZip.zip' ) == AZ_OK ) { + die 'write error'; + } + +=head1 DESCRIPTION + +The Archive::Zip module allows a Perl program to create, manipulate, read, +and write Zip archive files. + +Zip archives can be created, or you can read from existing zip files. + +Once created, they can be written to files, streams, or strings. Members +can be added, removed, extracted, replaced, rearranged, and enumerated. +They can also be renamed or have their dates, comments, or other attributes +queried or modified. Their data can be compressed or uncompressed as needed. + +Members can be created from members in existing Zip files, or from existing +directories, files, or strings. + +This module uses the L library to read and write the +compressed streams inside the files. + +One can use L to read the zip file archive members +as if they were files. + +=head2 File Naming + +Regardless of what your local file system uses for file naming, names in a +Zip file are in Unix format (I slashes (/) separating directory +names, etc.). + +C tries to be consistent with file naming conventions, and will +translate back and forth between native and Zip file names. + +However, it can't guess which format names are in. So two rules control what +kind of file name you must pass various routines: + +=over 4 + +=item Names of files are in local format. + +C and C are used for various file +operations. When you're referring to a file on your system, use its +file naming conventions. + +=item Names of archive members are in Unix format. + +This applies to every method that refers to an archive member, or +provides a name for new archive members. The C methods +that can take one or two names will convert from local to zip names +if you call them with a single name. + +=back + +=head2 Archive::Zip Object Model + +=head3 Overview + +Archive::Zip::Archive objects are what you ordinarily deal with. +These maintain the structure of a zip file, without necessarily +holding data. When a zip is read from a disk file, the (possibly +compressed) data still lives in the file, not in memory. Archive +members hold information about the individual members, but not +(usually) the actual member data. When the zip is written to a +(different) file, the member data is compressed or copied as needed. +It is possible to make archive members whose data is held in a string +in memory, but this is not done when a zip file is read. Directory +members don't have any data. + +=head2 Inheritance + + Exporter + Archive::Zip Common base class, has defs. + Archive::Zip::Archive A Zip archive. + Archive::Zip::Member Abstract superclass for all members. + Archive::Zip::StringMember Member made from a string + Archive::Zip::FileMember Member made from an external file + Archive::Zip::ZipFileMember Member that lives in a zip file + Archive::Zip::NewFileMember Member whose data is in a file + Archive::Zip::DirectoryMember Member that is a directory + +=head1 EXPORTS + +=over 4 + +=item :CONSTANTS + +Exports the following constants: + +FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK +GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK +COMPRESSION_STORED COMPRESSION_DEFLATED IFA_TEXT_FILE_MASK +IFA_TEXT_FILE IFA_BINARY_FILE COMPRESSION_LEVEL_NONE +COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST +COMPRESSION_LEVEL_BEST_COMPRESSION + +=item :MISC_CONSTANTS + +Exports the following constants (only necessary for extending the +module): + +FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST FA_OS2_HPFS +FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS +GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK +GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK +GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK +DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM +DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST +COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3 +COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED +COMPRESSION_DEFLATED_ENHANCED +COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED + +=item :ERROR_CODES + +Explained below. Returned from most methods. + +AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR + +=back + +=head1 ERROR CODES + +Many of the methods in Archive::Zip return error codes. These are implemented +as inline subroutines, using the C pragma. They can be imported +into your namespace using the C<:ERROR_CODES> tag: + + use Archive::Zip qw( :ERROR_CODES ); + + ... + + unless ( $zip->read( 'myfile.zip' ) == AZ_OK ) { + die "whoops!"; + } + +=over 4 + +=item AZ_OK (0) + +Everything is fine. + +=item AZ_STREAM_END (1) + +The read stream (or central directory) ended normally. + +=item AZ_ERROR (2) + +There was some generic kind of error. + +=item AZ_FORMAT_ERROR (3) + +There is a format error in a ZIP file being read. + +=item AZ_IO_ERROR (4) + +There was an IO error. + +=back + +=head2 Compression + +Archive::Zip allows each member of a ZIP file to be compressed (using the +Deflate algorithm) or uncompressed. + +Other compression algorithms that some versions of ZIP have been able to +produce are not supported. Each member has two compression methods: the +one it's stored as (this is always COMPRESSION_STORED for string and external +file members), and the one you desire for the member in the zip file. + +These can be different, of course, so you can make a zip member that is not +compressed out of one that is, and vice versa. + +You can inquire about the current compression and set the desired +compression method: + + my $member = $zip->memberNamed( 'xyz.txt' ); + $member->compressionMethod(); # return current compression + + # set to read uncompressed + $member->desiredCompressionMethod( COMPRESSION_STORED ); + + # set to read compressed + $member->desiredCompressionMethod( COMPRESSION_DEFLATED ); + +There are two different compression methods: + +=over 4 + +=item COMPRESSION_STORED + +File is stored (no compression) + +=item COMPRESSION_DEFLATED + +File is Deflated + +=back + +=head2 Compression Levels + +If a member's desiredCompressionMethod is COMPRESSION_DEFLATED, you +can choose different compression levels. This choice may affect the +speed of compression and decompression, as well as the size of the +compressed member data. + + $member->desiredCompressionLevel( 9 ); + +The levels given can be: + +=over 4 + +=item * 0 or COMPRESSION_LEVEL_NONE + +This is the same as saying + + $member->desiredCompressionMethod( COMPRESSION_STORED ); + +=item * 1 .. 9 + +1 gives the best speed and worst compression, and 9 gives the +best compression and worst speed. + +=item * COMPRESSION_LEVEL_FASTEST + +This is a synonym for level 1. + +=item * COMPRESSION_LEVEL_BEST_COMPRESSION + +This is a synonym for level 9. + +=item * COMPRESSION_LEVEL_DEFAULT + +This gives a good compromise between speed and compression, +and is currently equivalent to 6 (this is in the zlib code). +This is the level that will be used if not specified. + +=back + +=head1 Archive::Zip Methods + +The Archive::Zip class (and its invisible subclass Archive::Zip::Archive) +implement generic zip file functionality. Creating a new Archive::Zip object +actually makes an Archive::Zip::Archive object, but you don't have to worry +about this unless you're subclassing. + +=head2 Constructor + +=over 4 + +=item new( [$fileName] ) + +=item new( { filename => $fileName } ) + +Make a new, empty zip archive. + + my $zip = Archive::Zip->new(); + +If an additional argument is passed, new() will call read() +to read the contents of an archive: + + my $zip = Archive::Zip->new( 'xyz.zip' ); + +If a filename argument is passed and the read fails for any +reason, new will return undef. For this reason, it may be +better to call read separately. + +=back + +=head2 Zip Archive Utility Methods + +These Archive::Zip methods may be called as functions or as object +methods. Do not call them as class methods: + + $zip = Archive::Zip->new(); + $crc = Archive::Zip::computeCRC32( 'ghijkl' ); # OK + $crc = $zip->computeCRC32( 'ghijkl' ); # also OK + $crc = Archive::Zip->computeCRC32( 'ghijkl' ); # NOT OK + +=over 4 + +=item Archive::Zip::computeCRC32( $string [, $crc] ) + +=item Archive::Zip::computeCRC32( { string => $string [, checksum => $crc ] } ) + +This is a utility function that uses the Compress::Raw::Zlib CRC +routine to compute a CRC-32. You can get the CRC of a string: + + $crc = Archive::Zip::computeCRC32( $string ); + +Or you can compute the running CRC: + + $crc = 0; + $crc = Archive::Zip::computeCRC32( 'abcdef', $crc ); + $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc ); + +=item Archive::Zip::setChunkSize( $number ) + +=item Archive::Zip::setChunkSize( { chunkSize => $number } ) + +Report or change chunk size used for reading and writing. +This can make big differences in dealing with large files. +Currently, this defaults to 32K. This also changes the chunk +size used for Compress::Raw::Zlib. You must call setChunkSize() +before reading or writing. This is not exportable, so you +must call it like: + + Archive::Zip::setChunkSize( 4096 ); + +or as a method on a zip (though this is a global setting). +Returns old chunk size. + +=item Archive::Zip::chunkSize() + +Returns the current chunk size: + + my $chunkSize = Archive::Zip::chunkSize(); + +=item Archive::Zip::setErrorHandler( \&subroutine ) + +=item Archive::Zip::setErrorHandler( { subroutine => \&subroutine } ) + +Change the subroutine called with error strings. This +defaults to \&Carp::carp, but you may want to change it to +get the error strings. This is not exportable, so you must +call it like: + + Archive::Zip::setErrorHandler( \&myErrorHandler ); + +If myErrorHandler is undef, resets handler to default. +Returns old error handler. Note that if you call Carp::carp +or a similar routine or if you're chaining to the default +error handler from your error handler, you may want to +increment the number of caller levels that are skipped (do +not just set it to a number): + + $Carp::CarpLevel++; + +=item Archive::Zip::tempFile( [ $tmpdir ] ) + +=item Archive::Zip::tempFile( { tempDir => $tmpdir } ) + +Create a uniquely named temp file. It will be returned open +for read/write. If C<$tmpdir> is given, it is used as the +name of a directory to create the file in. If not given, +creates the file using C. Generally, you can +override this choice using the + + $ENV{TMPDIR} + +environment variable. But see the L +documentation for your system. Note that on many systems, if you're +running in taint mode, then you must make sure that C<$ENV{TMPDIR}> is +untainted for it to be used. +Will I create C<$tmpdir> if it does not exist (this is a change +from prior versions!). Returns file handle and name: + + my ($fh, $name) = Archive::Zip::tempFile(); + my ($fh, $name) = Archive::Zip::tempFile('myTempDir'); + my $fh = Archive::Zip::tempFile(); # if you don't need the name + +=back + +=head2 Zip Archive Accessors + +=over 4 + +=item members() + +Return a copy of the members array + + my @members = $zip->members(); + +=item numberOfMembers() + +Return the number of members I have + +=item memberNames() + +Return a list of the (internal) file names of the zip members + +=item memberNamed( $string ) + +=item memberNamed( { zipName => $string } ) + +Return ref to member whose filename equals given filename or +undef. C<$string> must be in Zip (Unix) filename format. + +=item membersMatching( $regex ) + +=item membersMatching( { regex => $regex } ) + +Return array of members whose filenames match given regular +expression in list context. Returns number of matching +members in scalar context. + + my @textFileMembers = $zip->membersMatching( '.*\.txt' ); + # or + my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' ); + +=item diskNumber() + +Return the disk that I start on. Not used for writing zips, +but might be interesting if you read a zip in. This should be +0, as Archive::Zip does not handle multi-volume archives. + +=item diskNumberWithStartOfCentralDirectory() + +Return the disk number that holds the beginning of the +central directory. Not used for writing zips, but might be +interesting if you read a zip in. This should be 0, as +Archive::Zip does not handle multi-volume archives. + +=item numberOfCentralDirectoriesOnThisDisk() + +Return the number of CD structures in the zipfile last read in. +Not used for writing zips, but might be interesting if you read a zip +in. + +=item numberOfCentralDirectories() + +Return the number of CD structures in the zipfile last read in. +Not used for writing zips, but might be interesting if you read a zip +in. + +=item centralDirectorySize() + +Returns central directory size, as read from an external zip +file. Not used for writing zips, but might be interesting if +you read a zip in. + +=item centralDirectoryOffsetWRTStartingDiskNumber() + +Returns the offset into the zip file where the CD begins. Not +used for writing zips, but might be interesting if you read a +zip in. + +=item zipfileComment( [ $string ] ) + +=item zipfileComment( [ { comment => $string } ] ) + +Get or set the zipfile comment. Returns the old comment. + + print $zip->zipfileComment(); + $zip->zipfileComment( 'New Comment' ); + +=item eocdOffset() + +Returns the (unexpected) number of bytes between where the +EOCD was found and where it expected to be. This is normally +0, but would be positive if something (a virus, perhaps) had +added bytes somewhere before the EOCD. Not used for writing +zips, but might be interesting if you read a zip in. Here is +an example of how you can diagnose this: + + my $zip = Archive::Zip->new('somefile.zip'); + if ($zip->eocdOffset()) + { + warn "A virus has added ", $zip->eocdOffset, " bytes of garbage\n"; + } + +The C is used to adjust the starting position of member +headers, if necessary. + +=item fileName() + +Returns the name of the file last read from. If nothing has +been read yet, returns an empty string; if read from a file +handle, returns the handle in string form. + +=back + +=head2 Zip Archive Member Operations + +Various operations on a zip file modify members. When a member is +passed as an argument, you can either use a reference to the member +itself, or the name of a member. Of course, using the name requires +that names be unique within a zip (this is not enforced). + +=over 4 + +=item removeMember( $memberOrName ) + +=item removeMember( { memberOrZipName => $memberOrName } ) + +Remove and return the given member, or match its name and +remove it. Returns undef if member or name does not exist in this +Zip. No-op if member does not belong to this zip. + +=item replaceMember( $memberOrName, $newMember ) + +=item replaceMember( { memberOrZipName => $memberOrName, + newMember => $newMember } ) + +Remove and return the given member, or match its name and +remove it. Replace with new member. Returns undef if member or +name does not exist in this Zip, or if C<$newMember> is undefined. + +It is an (undiagnosed) error to provide a C<$newMember> that is a +member of the zip being modified. + + my $member1 = $zip->removeMember( 'xyz' ); + my $member2 = $zip->replaceMember( 'abc', $member1 ); + # now, $member2 (named 'abc') is not in $zip, + # and $member1 (named 'xyz') is, having taken $member2's place. + +=item extractMember( $memberOrName [, $extractedName ] ) + +=item extractMember( { memberOrZipName => $memberOrName + [, name => $extractedName ] } ) + +Extract the given member, or match its name and extract it. +Returns undef if member does not exist in this Zip. If +optional second arg is given, use it as the name of the +extracted member. Otherwise, the internal filename of the +member is used as the name of the extracted file or +directory. +If you pass C<$extractedName>, it should be in the local file +system's format. +All necessary directories will be created. Returns C +on success. + +=item extractMemberWithoutPaths( $memberOrName [, $extractedName ] ) + +=item extractMemberWithoutPaths( { memberOrZipName => $memberOrName + [, name => $extractedName ] } ) + +Extract the given member, or match its name and extract it. +Does not use path information (extracts into the current +directory). Returns undef if member does not exist in this +Zip. +If optional second arg is given, use it as the name of the +extracted member (its paths will be deleted too). Otherwise, +the internal filename of the member (minus paths) is used as +the name of the extracted file or directory. Returns C +on success. + +=item addMember( $member ) + +=item addMember( { member => $member } ) + +Append a member (possibly from another zip file) to the zip +file. Returns the new member. Generally, you will use +addFile(), addDirectory(), addFileOrDirectory(), addString(), +or read() to add members. + + # Move member named 'abc' to end of zip: + my $member = $zip->removeMember( 'abc' ); + $zip->addMember( $member ); + +=item updateMember( $memberOrName, $fileName ) + +=item updateMember( { memberOrZipName => $memberOrName, name => $fileName } ) + +Update a single member from the file or directory named C<$fileName>. +Returns the (possibly added or updated) member, if any; C on +errors. +The comparison is based on C and (in the case of a +non-directory) the size of the file. + +=item addFile( $fileName [, $newName, $compressionLevel ] ) + +=item addFile( { filename => $fileName + [, zipName => $newName, compressionLevel => $compressionLevel } ] ) + +Append a member whose data comes from an external file, +returning the member or undef. The member will have its file +name set to the name of the external file, and its +desiredCompressionMethod set to COMPRESSION_DEFLATED. The +file attributes and last modification time will be set from +the file. +If the name given does not represent a readable plain file or +symbolic link, undef will be returned. C<$fileName> must be +in the format required for the local file system. +The optional C<$newName> argument sets the internal file name +to something different than the given $fileName. C<$newName>, +if given, must be in Zip name format (i.e. Unix). +The text mode bit will be set if the contents appears to be +text (as returned by the C<-T> perl operator). + + +I that you should not (generally) use absolute path names +in zip member names, as this will cause problems with some zip +tools as well as introduce a security hole and make the zip +harder to use. + +=item addDirectory( $directoryName [, $fileName ] ) + +=item addDirectory( { directoryName => $directoryName + [, zipName => $fileName ] } ) + + +Append a member created from the given directory name. The +directory name does not have to name an existing directory. +If the named directory exists, the file modification time and +permissions are set from the existing directory, otherwise +they are set to now and permissive default permissions. +C<$directoryName> must be in local file system format. +The optional second argument sets the name of the archive +member (which defaults to C<$directoryName>). If given, it +must be in Zip (Unix) format. +Returns the new member. + +=item addFileOrDirectory( $name [, $newName, $compressionLevel ] ) + +=item addFileOrDirectory( { name => $name [, zipName => $newName, + compressionLevel => $compressionLevel ] } ) + + +Append a member from the file or directory named $name. If +$newName is given, use it for the name of the new member. +Will add or remove trailing slashes from $newName as needed. +C<$name> must be in local file system format. +The optional second argument sets the name of the archive +member (which defaults to C<$name>). If given, it must be in +Zip (Unix) format. + +=item addString( $stringOrStringRef, $name, [$compressionLevel] ) + +=item addString( { string => $stringOrStringRef [, zipName => $name, + compressionLevel => $compressionLevel ] } ) + +Append a member created from the given string or string +reference. The name is given by the second argument. +Returns the new member. The last modification time will be +set to now, and the file attributes will be set to permissive +defaults. + + my $member = $zip->addString( 'This is a test', 'test.txt' ); + +=item contents( $memberOrMemberName [, $newContents ] ) + +=item contents( { memberOrZipName => $memberOrMemberName + [, contents => $newContents ] } ) + + +Returns the uncompressed data for a particular member, or +undef. + + print "xyz.txt contains " . $zip->contents( 'xyz.txt' ); + +Also can change the contents of a member: + + $zip->contents( 'xyz.txt', 'This is the new contents' ); + +If called expecting an array as the return value, it will include +the status as the second value in the array. + + ($content, $status) = $zip->contents( 'xyz.txt'); + +=back + +=head2 Zip Archive I/O operations + + +A Zip archive can be written to a file or file handle, or read from +one. + +=over 4 + +=item writeToFileNamed( $fileName ) + +=item writeToFileNamed( { fileName => $fileName } ) + +Write a zip archive to named file. Returns C on +success. + + my $status = $zip->writeToFileNamed( 'xx.zip' ); + die "error somewhere" if $status != AZ_OK; + +Note that if you use the same name as an existing zip file +that you read in, you will clobber ZipFileMembers. So +instead, write to a different file name, then delete the +original. +If you use the C or C methods, you can +re-write the original zip in this way. +C<$fileName> should be a valid file name on your system. + +=item writeToFileHandle( $fileHandle [, $seekable] ) + +Write a zip archive to a file handle. Return AZ_OK on +success. The optional second arg tells whether or not to try +to seek backwards to re-write headers. If not provided, it is +set if the Perl C<-f> test returns true. This could fail on +some operating systems, though. + + my $fh = IO::File->new( 'someFile.zip', 'w' ); + unless ( $zip->writeToFileHandle( $fh ) == AZ_OK ) { + # error handling + } + +If you pass a file handle that is not seekable (like if +you're writing to a pipe or a socket), pass a false second +argument: + + my $fh = IO::File->new( '| cat > somefile.zip', 'w' ); + $zip->writeToFileHandle( $fh, 0 ); # fh is not seekable + +If this method fails during the write of a member, that +member and all following it will return false from +C. See writeCentralDirectory() for a way to +deal with this. +If you want, you can write data to the file handle before +passing it to writeToFileHandle(); this could be used (for +instance) for making self-extracting archives. However, this +only works reliably when writing to a real file (as opposed +to STDOUT or some other possible non-file). + +See examples/selfex.pl for how to write a self-extracting +archive. + +=item writeCentralDirectory( $fileHandle [, $offset ] ) + +=item writeCentralDirectory( { fileHandle => $fileHandle + [, offset => $offset ] } ) + +Writes the central directory structure to the given file +handle. + +Returns AZ_OK on success. If given an $offset, will +seek to that point before writing. This can be used for +recovery in cases where writeToFileHandle or writeToFileNamed +returns an IO error because of running out of space on the +destination file. + +You can truncate the zip by seeking backwards and then writing the +directory: + + my $fh = IO::File->new( 'someFile.zip', 'w' ); + my $retval = $zip->writeToFileHandle( $fh ); + if ( $retval == AZ_IO_ERROR ) { + my @unwritten = grep { not $_->wasWritten() } $zip->members(); + if (@unwritten) { + $zip->removeMember( $member ) foreach my $member ( @unwritten ); + $zip->writeCentralDirectory( $fh, + $unwritten[0]->writeLocalHeaderRelativeOffset()); + } + } + +=item overwriteAs( $newName ) + +=item overwriteAs( { filename => $newName } ) + +Write the zip to the specified file, as safely as possible. +This is done by first writing to a temp file, then renaming +the original if it exists, then renaming the temp file, then +deleting the renamed original if it exists. Returns AZ_OK if +successful. + +=item overwrite() + +Write back to the original zip file. See overwriteAs() above. +If the zip was not ever read from a file, this generates an +error. + +=item read( $fileName ) + +=item read( { filename => $fileName } ) + +Read zipfile headers from a zip file, appending new members. +Returns C or error code. + + my $zipFile = Archive::Zip->new(); + my $status = $zipFile->read( '/some/FileName.zip' ); + +=item readFromFileHandle( $fileHandle, $filename ) + +=item readFromFileHandle( { fileHandle => $fileHandle, filename => $filename } ) + +Read zipfile headers from an already-opened file handle, +appending new members. Does not close the file handle. +Returns C or error code. Note that this requires a +seekable file handle; reading from a stream is not yet +supported, but using in-memory data is. + + my $fh = IO::File->new( '/some/FileName.zip', 'r' ); + my $zip1 = Archive::Zip->new(); + my $status = $zip1->readFromFileHandle( $fh ); + my $zip2 = Archive::Zip->new(); + $status = $zip2->readFromFileHandle( $fh ); + +Read zip using in-memory data (recursable): + + open my $fh, "<", "archive.zip" or die $!; + my $zip_data = do { local $.; <$fh> }; + my $zip = Archive::Zip->new; + open my $dh, "+<", \$zip_data; + $zip->readFromFileHandle ($dh); + +=back + +=head2 Zip Archive Tree operations + +These used to be in Archive::Zip::Tree but got moved into +Archive::Zip. They enable operation on an entire tree of members or +files. +A usage example: + + use Archive::Zip; + my $zip = Archive::Zip->new(); + + # add all readable files and directories below . as xyz/* + $zip->addTree( '.', 'xyz' ); + + # add all readable plain files below /abc as def/* + $zip->addTree( '/abc', 'def', sub { -f && -r } ); + + # add all .c files below /tmp as stuff/* + $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' ); + + # add all .o files below /tmp as stuff/* if they aren't writable + $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } ); + + # add all .so files below /tmp that are smaller than 200 bytes as stuff/* + $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } ); + + # and write them into a file + $zip->writeToFileNamed('xxx.zip'); + + # now extract the same files into /tmpx + $zip->extractTree( 'stuff', '/tmpx' ); + +=over 4 + +=item $zip->addTree( $root, $dest [, $pred, $compressionLevel ] ) -- Add tree of files to a zip + +=item $zip->addTree( { root => $root, zipName => $dest [, select => $pred, + compressionLevel => $compressionLevel ] ) + +C<$root> is the root of the tree of files and directories to be +added. It is a valid directory name on your system. C<$dest> is +the name for the root in the zip file (undef or blank means +to use relative pathnames). It is a valid ZIP directory name +(that is, it uses forward slashes (/) for separating +directory components). C<$pred> is an optional subroutine +reference to select files: it is passed the name of the +prospective file or directory using C<$_>, and if it returns +true, the file or directory will be included. The default is +to add all readable files and directories. For instance, +using + + my $pred = sub { /\.txt/ }; + $zip->addTree( '.', '', $pred ); + +will add all the .txt files in and below the current +directory, using relative names, and making the names +identical in the zipfile: + + original name zip member name + ./xyz xyz + ./a/ a/ + ./a/b a/b + +To translate absolute to relative pathnames, just pass them +in: $zip->addTree( '/c/d', 'a' ); + + original name zip member name + /c/d/xyz a/xyz + /c/d/a/ a/a/ + /c/d/a/b a/a/b + +Returns AZ_OK on success. Note that this will not follow +symbolic links to directories. Note also that this does not +check for the validity of filenames. + +Note that you generally I want to make zip archive member names +absolute. + +=item $zip->addTreeMatching( $root, $dest, $pattern [, $pred, $compressionLevel ] ) + +=item $zip->addTreeMatching( { root => $root, zipName => $dest, pattern => + $pattern [, select => $pred, compressionLevel => $compressionLevel ] } ) + +$root is the root of the tree of files and directories to be +added $dest is the name for the root in the zip file (undef +means to use relative pathnames) $pattern is a (non-anchored) +regular expression for filenames to match $pred is an +optional subroutine reference to select files: it is passed +the name of the prospective file or directory in C<$_>, and +if it returns true, the file or directory will be included. +The default is to add all readable files and directories. To +add all files in and below the current directory whose names +end in C<.pl>, and make them extract into a subdirectory +named C, do this: + + $zip->addTreeMatching( '.', 'xyz', '\.pl$' ) + +To add all I files in and below the directory named +C whose names end in C<.pl>, and make them extract into +a subdirectory named C, do this: + + $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } ) + +Returns AZ_OK on success. Note that this will not follow +symbolic links to directories. + +=item $zip->updateTree( $root [, $dest , $pred , $mirror, $compressionLevel ] ); + +=item $zip->updateTree( { root => $root [, zipName => $dest, select => $pred, + mirror => $mirror, compressionLevel => $compressionLevel ] } ); + +Update a zip file from a directory tree. + +C takes the same arguments as C, but first +checks to see whether the file or directory already exists in the zip +file, and whether it has been changed. + +If the fourth argument C<$mirror> is true, then delete all my members +if corresponding files were not found. + +Returns an error code or AZ_OK if all is well. + +=item $zip->extractTree( [ $root, $dest, $volume } ] ) + +=item $zip->extractTree( [ { root => $root, zipName => $dest, volume => $volume } ] ) + +If you don't give any arguments at all, will extract all the +files in the zip with their original names. + +If you supply one argument for C<$root>, C will extract +all the members whose names start with C<$root> into the current +directory, stripping off C<$root> first. +C<$root> is in Zip (Unix) format. +For instance, + + $zip->extractTree( 'a' ); + +when applied to a zip containing the files: +a/x a/b/c ax/d/e d/e will extract: + +a/x as ./x + +a/b/c as ./b/c + +If you give two arguments, C extracts all the members +whose names start with C<$root>. It will translate C<$root> into +C<$dest> to construct the destination file name. +C<$root> and C<$dest> are in Zip (Unix) format. +For instance, + + $zip->extractTree( 'a', 'd/e' ); + +when applied to a zip containing the files: +a/x a/b/c ax/d/e d/e will extract: + +a/x to d/e/x + +a/b/c to d/e/b/c and ignore ax/d/e and d/e + +If you give three arguments, C extracts all the members +whose names start with C<$root>. It will translate C<$root> into +C<$dest> to construct the destination file name, and then it will +convert to local file system format, using C<$volume> as the name of +the destination volume. + +C<$root> and C<$dest> are in Zip (Unix) format. + +C<$volume> is in local file system format. + +For instance, under Windows, + + $zip->extractTree( 'a', 'd/e', 'f:' ); + +when applied to a zip containing the files: +a/x a/b/c ax/d/e d/e will extract: + +a/x to f:d/e/x + +a/b/c to f:d/e/b/c and ignore ax/d/e and d/e + +If you want absolute paths (the prior example used paths relative to +the current directory on the destination volume, you can specify these +in C<$dest>: + + $zip->extractTree( 'a', '/d/e', 'f:' ); + +when applied to a zip containing the files: +a/x a/b/c ax/d/e d/e will extract: + +a/x to f:\d\e\x + +a/b/c to f:\d\e\b\c and ignore ax/d/e and d/e + +Returns an error code or AZ_OK if everything worked OK. + +=back + +=head1 Archive::Zip Global Variables + +=over 4 + +=item $Archive::Zip::UNICODE + +This variable governs how Unicode file and directory names are added +to or extracted from an archive. If set, file and directory names are considered +to be UTF-8 encoded. This is I. Please report problems. + + { + local $Archive::Zip::UNICODE = 1; + $zip->addFile('Déjà vu.txt'); + } + +=back + +=head1 MEMBER OPERATIONS + +=head2 Member Class Methods + +Several constructors allow you to construct members without adding +them to a zip archive. These work the same as the addFile(), +addDirectory(), and addString() zip instance methods described above, +but they don't add the new members to a zip. + +=over 4 + +=item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName ] ) + +=item Archive::Zip::Member->newFromString( { string => $stringOrStringRef + [, zipName => $fileName ] ) + +Construct a new member from the given string. Returns undef +on error. + + my $member = Archive::Zip::Member->newFromString( 'This is a test', + +=item newFromFile( $fileName [, $zipName ] ) + +=item newFromFile( { filename => $fileName [, zipName => $zipName ] } ) + +Construct a new member from the given file. Returns undef on +error. + + my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' ); + +=item newDirectoryNamed( $directoryName [, $zipname ] ) + +=item newDirectoryNamed( { directoryName => $directoryName + [, zipName => $zipname ] } ) + +Construct a new member from the given directory. +C<$directoryName> must be a valid name on your file system; it does not +have to exist. + +If given, C<$zipname> will be the name of the zip member; it must be a +valid Zip (Unix) name. If not given, it will be converted from +C<$directoryName>. + +Returns undef on error. + + my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' ); + +=back + +=head2 Member Simple accessors + +These methods get (and/or set) member attribute values. + +=over 4 + +=item versionMadeBy() + +Gets the field from the member header. + +=item fileAttributeFormat( [ $format ] ) + +=item fileAttributeFormat( [ { format => $format ] } ) + +Gets or sets the field from the member header. These are +C values. + +=item versionNeededToExtract() + +Gets the field from the member header. + +=item bitFlag() + +Gets the general purpose bit field from the member header. +This is where the C bits live. + +=item compressionMethod() + +Returns the member compression method. This is the method +that is currently being used to compress the member data. +This will be COMPRESSION_STORED for added string or file +members, or any of the C values for members +from a zip file. However, this module can only handle members +whose data is in COMPRESSION_STORED or COMPRESSION_DEFLATED +format. + +=item desiredCompressionMethod( [ $method ] ) + +=item desiredCompressionMethod( [ { compressionMethod => $method } ] ) + +Get or set the member's C. This is +the compression method that will be used when the member is +written. Returns prior desiredCompressionMethod. Only +COMPRESSION_DEFLATED or COMPRESSION_STORED are valid +arguments. Changing to COMPRESSION_STORED will change the +member desiredCompressionLevel to 0; changing to +COMPRESSION_DEFLATED will change the member +desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT. + +=item desiredCompressionLevel( [ $level ] ) + +=item desiredCompressionLevel( [ { compressionLevel => $level } ] ) + +Get or set the member's desiredCompressionLevel This is the +method that will be used to write. Returns prior +desiredCompressionLevel. Valid arguments are 0 through 9, +COMPRESSION_LEVEL_NONE, COMPRESSION_LEVEL_DEFAULT, +COMPRESSION_LEVEL_BEST_COMPRESSION, and +COMPRESSION_LEVEL_FASTEST. 0 or COMPRESSION_LEVEL_NONE will +change the desiredCompressionMethod to COMPRESSION_STORED. +All other arguments will change the desiredCompressionMethod +to COMPRESSION_DEFLATED. + +=item externalFileName() + +Return the member's external file name, if any, or undef. + +=item fileName() + +Get or set the member's internal filename. Returns the +(possibly new) filename. Names will have backslashes +converted to forward slashes, and will have multiple +consecutive slashes converted to single ones. + +=item lastModFileDateTime() + +Return the member's last modification date/time stamp in +MS-DOS format. + +=item lastModTime() + +Return the member's last modification date/time stamp, +converted to unix localtime format. + + print "Mod Time: " . scalar( localtime( $member->lastModTime() ) ); + +=item setLastModFileDateTimeFromUnix() + +Set the member's lastModFileDateTime from the given unix +time. + + $member->setLastModFileDateTimeFromUnix( time() ); + +=item internalFileAttributes() + +Return the internal file attributes field from the zip +header. This is only set for members read from a zip file. + +=item externalFileAttributes() + +Return member attributes as read from the ZIP file. Note that +these are NOT UNIX! + +=item unixFileAttributes( [ $newAttributes ] ) + +=item unixFileAttributes( [ { attributes => $newAttributes } ] ) + +Get or set the member's file attributes using UNIX file +attributes. Returns old attributes. + + my $oldAttribs = $member->unixFileAttributes( 0666 ); + +Note that the return value has more than just the file +permissions, so you will have to mask off the lowest bits for +comparisons. + +=item localExtraField( [ $newField ] ) + +=item localExtraField( [ { field => $newField } ] ) + +Gets or sets the extra field that was read from the local +header. This is not set for a member from a zip file until +after the member has been written out. The extra field must +be in the proper format. + +=item cdExtraField( [ $newField ] ) + +=item cdExtraField( [ { field => $newField } ] ) + +Gets or sets the extra field that was read from the central +directory header. The extra field must be in the proper +format. + +=item extraFields() + +Return both local and CD extra fields, concatenated. + +=item fileComment( [ $newComment ] ) + +=item fileComment( [ { comment => $newComment } ] ) + +Get or set the member's file comment. + +=item hasDataDescriptor() + +Get or set the data descriptor flag. If this is set, the +local header will not necessarily have the correct data +sizes. Instead, a small structure will be stored at the end +of the member data with these values. This should be +transparent in normal operation. + +=item crc32() + +Return the CRC-32 value for this member. This will not be set +for members that were constructed from strings or external +files until after the member has been written. + +=item crc32String() + +Return the CRC-32 value for this member as an 8 character +printable hex string. This will not be set for members that +were constructed from strings or external files until after +the member has been written. + +=item compressedSize() + +Return the compressed size for this member. This will not be +set for members that were constructed from strings or +external files until after the member has been written. + +=item uncompressedSize() + +Return the uncompressed size for this member. + +=item password( [ $password ] ) + +Returns the password for this member to be used on decryption. +If $password is given, it will set the password for the decryption. + +=item isEncrypted() + +Return true if this member is encrypted. The Archive::Zip +module does not currently support creation of encrypted +members. Decryption works more or less like this: + + my $zip = Archive::Zip->new; + $zip->read ("encrypted.zip"); + for my $m (map { $zip->memberNamed ($_) } $zip->memberNames) { + $m->password ("secret"); + $m->contents; # is "" when password was wrong + +That shows that the password has to be set per member, and not per +archive. This might change in the future. + +=item isTextFile( [ $flag ] ) + +=item isTextFile( [ { flag => $flag } ] ) + +Returns true if I am a text file. Also can set the status if +given an argument (then returns old state). Note that this +module does not currently do anything with this flag upon +extraction or storage. That is, bytes are stored in native +format whether or not they came from a text file. + +=item isBinaryFile() + +Returns true if I am a binary file. Also can set the status +if given an argument (then returns old state). Note that this +module does not currently do anything with this flag upon +extraction or storage. That is, bytes are stored in native +format whether or not they came from a text file. + +=item extractToFileNamed( $fileName ) + +=item extractToFileNamed( { name => $fileName } ) + +Extract me to a file with the given name. The file will be +created with default modes. Directories will be created as +needed. +The C<$fileName> argument should be a valid file name on your +file system. +Returns AZ_OK on success. + +=item isDirectory() + +Returns true if I am a directory. + +=item writeLocalHeaderRelativeOffset() + +Returns the file offset in bytes the last time I was written. + +=item wasWritten() + +Returns true if I was successfully written. Reset at the +beginning of a write attempt. + +=back + +=head2 Low-level member data reading + +It is possible to use lower-level routines to access member data +streams, rather than the extract* methods and contents(). For +instance, here is how to print the uncompressed contents of a member +in chunks using these methods: + + my ( $member, $status, $bufferRef ); + $member = $zip->memberNamed( 'xyz.txt' ); + $member->desiredCompressionMethod( COMPRESSION_STORED ); + $status = $member->rewindData(); + die "error $status" unless $status == AZ_OK; + while ( ! $member->readIsDone() ) + { + ( $bufferRef, $status ) = $member->readChunk(); + die "error $status" + if $status != AZ_OK && $status != AZ_STREAM_END; + # do something with $bufferRef: + print $$bufferRef; + } + $member->endRead(); + +=over 4 + +=item readChunk( [ $chunkSize ] ) + +=item readChunk( [ { chunkSize => $chunkSize } ] ) + +This reads the next chunk of given size from the member's +data stream and compresses or uncompresses it as necessary, +returning a reference to the bytes read and a status. If size +argument is not given, defaults to global set by +Archive::Zip::setChunkSize. Status is AZ_OK on success until +the last chunk, where it returns AZ_STREAM_END. Returns C<( +\$bytes, $status)>. + + my ( $outRef, $status ) = $self->readChunk(); + print $$outRef if $status != AZ_OK && $status != AZ_STREAM_END; + +=item rewindData() + +Rewind data and set up for reading data streams or writing +zip files. Can take options for C or +C, but this is not likely to be necessary. +Subclass overrides should call this method. Returns C +on success. + +=item endRead() + +Reset the read variables and free the inflater or deflater. +Must be called to close files, etc. Returns AZ_OK on success. + +=item readIsDone() + +Return true if the read has run out of data or encountered an error. + +=item contents() + +Return the entire uncompressed member data or undef in scalar +context. When called in array context, returns C<( $string, +$status )>; status will be AZ_OK on success: + + my $string = $member->contents(); + # or + my ( $string, $status ) = $member->contents(); + die "error $status" unless $status == AZ_OK; + +Can also be used to set the contents of a member (this may +change the class of the member): + + $member->contents( "this is my new contents" ); + +=item extractToFileHandle( $fh ) + +=item extractToFileHandle( { fileHandle => $fh } ) + +Extract (and uncompress, if necessary) the member's contents +to the given file handle. Return AZ_OK on success. + +=back + +=head1 Archive::Zip::FileMember methods + +The Archive::Zip::FileMember class extends Archive::Zip::Member. It is the +base class for both ZipFileMember and NewFileMember classes. This class adds +an C and an C member to keep track of the external +file. + +=over 4 + +=item externalFileName() + +Return the member's external filename. + +=item fh() + +Return the member's read file handle. Automatically opens file if +necessary. + +=back + +=head1 Archive::Zip::ZipFileMember methods + +The Archive::Zip::ZipFileMember class represents members that have been read +from external zip files. + +=over 4 + +=item diskNumberStart() + +Returns the disk number that the member's local header resides in. +Should be 0. + +=item localHeaderRelativeOffset() + +Returns the offset into the zip file where the member's local header +is. + +=item dataOffset() + +Returns the offset from the beginning of the zip file to the member's +data. + +=back + +=head1 REQUIRED MODULES + +L requires several other modules: + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +=head1 BUGS AND CAVEATS + +=head2 When not to use Archive::Zip + +If you are just going to be extracting zips (and/or other archives) you +are recommended to look at using L instead, as it is much +easier to use and factors out archive-specific functionality. + +=head2 Try to avoid IO::Scalar + +One of the most common ways to use Archive::Zip is to generate Zip files +in-memory. Most people use L for this purpose. + +Unfortunately, as of 1.11 this module no longer works with L +as it incorrectly implements seeking. + +Anybody using L should consider porting to L, +which is smaller, lighter, and is implemented to be perfectly compatible +with regular seekable filehandles. + +Support for L most likely will B be restored in the +future, as L itself cannot change the way it is implemented +due to back-compatibility issues. + +=head2 Wrong password for encrypted members + +When an encrypted member is read using the wrong password, you currently +have to re-read the entire archive to try again with the correct password. + +=head1 TO DO + +* auto-choosing storing vs compression + +* extra field hooks (see notes.txt) + +* check for duplicates on addition/renaming? + +* Text file extraction (line end translation) + +* Reading zip files from non-seekable inputs + (Perhaps by proxying through IO::String?) + +* separate unused constants into separate module + +* cookbook style docs + +* Handle tainted paths correctly + +* Work on better compatibility with other IO:: modules + +* Support encryption + +* More user-friendly decryption + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker + +L + +For other issues contact the maintainer + +=head1 AUTHOR + +Currently maintained by Fred Moyer + +Previously maintained by Adam Kennedy + +Previously maintained by Steve Peters Esteve@fisharerojo.orgE. + +File attributes code by Maurice Aubrey Emaurice@lovelyfilth.comE. + +Originally by Ned Konz Enedkonz@cpan.orgE. + +=head1 COPYRIGHT + +Some parts copyright 2006 - 2012 Adam Kennedy. + +Some parts copyright 2005 Steve Peters. + +Original work copyright 2000 - 2004 Ned Konz. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +Look at L which is a wrapper that allows one to +read Zip archive members as if they were files. + +L, L, L + +=cut diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Archive.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Archive.pm new file mode 100644 index 00000000000..c185612390e --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Archive.pm @@ -0,0 +1,1020 @@ +package Archive::Zip::Archive; + +# Represents a generic ZIP archive + +use strict; +use File::Path; +use File::Find (); +use File::Spec (); +use File::Copy (); +use File::Basename; +use Cwd; + +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw( Archive::Zip ); + + if ($^O eq 'MSWin32') { + require Win32; + require Encode; + Encode->import(qw{ encode_utf8 decode_utf8 }); + } +} + +use Archive::Zip qw( + :CONSTANTS + :ERROR_CODES + :PKZIP_CONSTANTS + :UTILITY_METHODS +); + +our $UNICODE; + +# Note that this returns undef on read errors, else new zip object. + +sub new { + my $class = shift; + my $self = bless( + { + 'diskNumber' => 0, + 'diskNumberWithStartOfCentralDirectory' => 0, + 'numberOfCentralDirectoriesOnThisDisk' => + 0, # should be # of members + 'numberOfCentralDirectories' => 0, # should be # of members + 'centralDirectorySize' => 0, # must re-compute on write + 'centralDirectoryOffsetWRTStartingDiskNumber' => + 0, # must re-compute + 'writeEOCDOffset' => 0, + 'writeCentralDirectoryOffset' => 0, + 'zipfileComment' => '', + 'eocdOffset' => 0, + 'fileName' => '' + }, + $class + ); + $self->{'members'} = []; + my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift; + if ($fileName) { + my $status = $self->read($fileName); + return $status == AZ_OK ? $self : undef; + } + return $self; +} + +sub storeSymbolicLink { + my $self = shift; + $self->{'storeSymbolicLink'} = shift; +} + +sub members { + @{shift->{'members'}}; +} + +sub numberOfMembers { + scalar(shift->members()); +} + +sub memberNames { + my $self = shift; + return map { $_->fileName() } $self->members(); +} + +# return ref to member with given name or undef +sub memberNamed { + my $self = shift; + my $fileName = (ref($_[0]) eq 'HASH') ? shift->{zipName} : shift; + foreach my $member ($self->members()) { + return $member if $member->fileName() eq $fileName; + } + return undef; +} + +sub membersMatching { + my $self = shift; + my $pattern = (ref($_[0]) eq 'HASH') ? shift->{regex} : shift; + return grep { $_->fileName() =~ /$pattern/ } $self->members(); +} + +sub diskNumber { + shift->{'diskNumber'}; +} + +sub diskNumberWithStartOfCentralDirectory { + shift->{'diskNumberWithStartOfCentralDirectory'}; +} + +sub numberOfCentralDirectoriesOnThisDisk { + shift->{'numberOfCentralDirectoriesOnThisDisk'}; +} + +sub numberOfCentralDirectories { + shift->{'numberOfCentralDirectories'}; +} + +sub centralDirectorySize { + shift->{'centralDirectorySize'}; +} + +sub centralDirectoryOffsetWRTStartingDiskNumber { + shift->{'centralDirectoryOffsetWRTStartingDiskNumber'}; +} + +sub zipfileComment { + my $self = shift; + my $comment = $self->{'zipfileComment'}; + if (@_) { + my $new_comment = (ref($_[0]) eq 'HASH') ? shift->{comment} : shift; + $self->{'zipfileComment'} = pack('C0a*', $new_comment); # avoid Unicode + } + return $comment; +} + +sub eocdOffset { + shift->{'eocdOffset'}; +} + +# Return the name of the file last read. +sub fileName { + shift->{'fileName'}; +} + +sub removeMember { + my $self = shift; + my $member = (ref($_[0]) eq 'HASH') ? shift->{memberOrZipName} : shift; + $member = $self->memberNamed($member) unless ref($member); + return undef unless $member; + my @newMembers = grep { $_ != $member } $self->members(); + $self->{'members'} = \@newMembers; + return $member; +} + +sub replaceMember { + my $self = shift; + + my ($oldMember, $newMember); + if (ref($_[0]) eq 'HASH') { + $oldMember = $_[0]->{memberOrZipName}; + $newMember = $_[0]->{newMember}; + } else { + ($oldMember, $newMember) = @_; + } + + $oldMember = $self->memberNamed($oldMember) unless ref($oldMember); + return undef unless $oldMember; + return undef unless $newMember; + my @newMembers = + map { ($_ == $oldMember) ? $newMember : $_ } $self->members(); + $self->{'members'} = \@newMembers; + return $oldMember; +} + +sub extractMember { + my $self = shift; + + my ($member, $name); + if (ref($_[0]) eq 'HASH') { + $member = $_[0]->{memberOrZipName}; + $name = $_[0]->{name}; + } else { + ($member, $name) = @_; + } + + $member = $self->memberNamed($member) unless ref($member); + return _error('member not found') unless $member; + my $originalSize = $member->compressedSize(); + my ($volumeName, $dirName, $fileName); + if (defined($name)) { + ($volumeName, $dirName, $fileName) = File::Spec->splitpath($name); + $dirName = File::Spec->catpath($volumeName, $dirName, ''); + } else { + $name = $member->fileName(); + ($dirName = $name) =~ s{[^/]*$}{}; + $dirName = Archive::Zip::_asLocalName($dirName); + $name = Archive::Zip::_asLocalName($name); + } + if ($dirName && !-d $dirName) { + mkpath($dirName); + return _ioError("can't create dir $dirName") if (!-d $dirName); + } + my $rc = $member->extractToFileNamed($name, @_); + + # TODO refactor this fix into extractToFileNamed() + $member->{'compressedSize'} = $originalSize; + return $rc; +} + +sub extractMemberWithoutPaths { + my $self = shift; + + my ($member, $name); + if (ref($_[0]) eq 'HASH') { + $member = $_[0]->{memberOrZipName}; + $name = $_[0]->{name}; + } else { + ($member, $name) = @_; + } + + $member = $self->memberNamed($member) unless ref($member); + return _error('member not found') unless $member; + my $originalSize = $member->compressedSize(); + return AZ_OK if $member->isDirectory(); + unless ($name) { + $name = $member->fileName(); + $name =~ s{.*/}{}; # strip off directories, if any + $name = Archive::Zip::_asLocalName($name); + } + my $rc = $member->extractToFileNamed($name, @_); + $member->{'compressedSize'} = $originalSize; + return $rc; +} + +sub addMember { + my $self = shift; + my $newMember = (ref($_[0]) eq 'HASH') ? shift->{member} : shift; + push(@{$self->{'members'}}, $newMember) if $newMember; + return $newMember; +} + +sub addFile { + my $self = shift; + + my ($fileName, $newName, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $fileName = $_[0]->{filename}; + $newName = $_[0]->{zipName}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($fileName, $newName, $compressionLevel) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $fileName = Win32::GetANSIPathName($fileName); + } + + my $newMember = Archive::Zip::Member->newFromFile($fileName, $newName); + $newMember->desiredCompressionLevel($compressionLevel); + if ($self->{'storeSymbolicLink'} && -l $fileName) { + my $newMember = + Archive::Zip::Member->newFromString(readlink $fileName, $newName); + + # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP + $newMember->{'externalFileAttributes'} = 0xA1FF0000; + $self->addMember($newMember); + } else { + $self->addMember($newMember); + } + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $newMember->{'fileName'} = + encode_utf8(Win32::GetLongPathName($fileName)); + } + return $newMember; +} + +sub addString { + my $self = shift; + + my ($stringOrStringRef, $name, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $stringOrStringRef = $_[0]->{string}; + $name = $_[0]->{zipName}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($stringOrStringRef, $name, $compressionLevel) = @_; + } + + my $newMember = + Archive::Zip::Member->newFromString($stringOrStringRef, $name); + $newMember->desiredCompressionLevel($compressionLevel); + return $self->addMember($newMember); +} + +sub addDirectory { + my $self = shift; + + my ($name, $newName); + if (ref($_[0]) eq 'HASH') { + $name = $_[0]->{directoryName}; + $newName = $_[0]->{zipName}; + } else { + ($name, $newName) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = Win32::GetANSIPathName($name); + } + + my $newMember = Archive::Zip::Member->newDirectoryNamed($name, $newName); + if ($self->{'storeSymbolicLink'} && -l $name) { + my $link = readlink $name; + ($newName =~ s{/$}{}) if $newName; # Strip trailing / + my $newMember = Archive::Zip::Member->newFromString($link, $newName); + + # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP + $newMember->{'externalFileAttributes'} = 0xA1FF0000; + $self->addMember($newMember); + } else { + $self->addMember($newMember); + } + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $newMember->{'fileName'} = encode_utf8(Win32::GetLongPathName($name)); + } + return $newMember; +} + +# add either a file or a directory. + +sub addFileOrDirectory { + my $self = shift; + + my ($name, $newName, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $name = $_[0]->{name}; + $newName = $_[0]->{zipName}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($name, $newName, $compressionLevel) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = Win32::GetANSIPathName($name); + } + + $name =~ s{/$}{}; + if ($newName) { + $newName =~ s{/$}{}; + } else { + $newName = $name; + } + if (-f $name) { + return $self->addFile($name, $newName, $compressionLevel); + } elsif (-d $name) { + return $self->addDirectory($name, $newName); + } else { + return _error("$name is neither a file nor a directory"); + } +} + +sub contents { + my $self = shift; + + my ($member, $newContents); + if (ref($_[0]) eq 'HASH') { + $member = $_[0]->{memberOrZipName}; + $newContents = $_[0]->{contents}; + } else { + ($member, $newContents) = @_; + } + + return _error('No member name given') unless $member; + $member = $self->memberNamed($member) unless ref($member); + return undef unless $member; + return $member->contents($newContents); +} + +sub writeToFileNamed { + my $self = shift; + my $fileName = + (ref($_[0]) eq 'HASH') ? shift->{filename} : shift; # local FS format + foreach my $member ($self->members()) { + if ($member->_usesFileNamed($fileName)) { + return _error("$fileName is needed by member " + . $member->fileName() + . "; consider using overwrite() or overwriteAs() instead."); + } + } + my ($status, $fh) = _newFileHandle($fileName, 'w'); + return _ioError("Can't open $fileName for write") unless $status; + my $retval = $self->writeToFileHandle($fh, 1); + $fh->close(); + $fh = undef; + + return $retval; +} + +# It is possible to write data to the FH before calling this, +# perhaps to make a self-extracting archive. +sub writeToFileHandle { + my $self = shift; + + my ($fh, $fhIsSeekable); + if (ref($_[0]) eq 'HASH') { + $fh = $_[0]->{fileHandle}; + $fhIsSeekable = + exists($_[0]->{seek}) ? $_[0]->{seek} : _isSeekable($fh); + } else { + $fh = shift; + $fhIsSeekable = @_ ? shift : _isSeekable($fh); + } + + return _error('No filehandle given') unless $fh; + return _ioError('filehandle not open') unless $fh->opened(); + _binmode($fh); + + # Find out where the current position is. + my $offset = $fhIsSeekable ? $fh->tell() : 0; + $offset = 0 if $offset < 0; + + foreach my $member ($self->members()) { + my $retval = $member->_writeToFileHandle($fh, $fhIsSeekable, $offset); + $member->endRead(); + return $retval if $retval != AZ_OK; + $offset += $member->_localHeaderSize() + $member->_writeOffset(); + $offset += + $member->hasDataDescriptor() + ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH + : 0; + + # changed this so it reflects the last successful position + $self->{'writeCentralDirectoryOffset'} = $offset; + } + return $self->writeCentralDirectory($fh); +} + +# Write zip back to the original file, +# as safely as possible. +# Returns AZ_OK if successful. +sub overwrite { + my $self = shift; + return $self->overwriteAs($self->{'fileName'}); +} + +# Write zip to the specified file, +# as safely as possible. +# Returns AZ_OK if successful. +sub overwriteAs { + my $self = shift; + my $zipName = (ref($_[0]) eq 'HASH') ? $_[0]->{filename} : shift; + return _error("no filename in overwriteAs()") unless defined($zipName); + + my ($fh, $tempName) = Archive::Zip::tempFile(); + return _error("Can't open temp file", $!) unless $fh; + + (my $backupName = $zipName) =~ s{(\.[^.]*)?$}{.zbk}; + + my $status = $self->writeToFileHandle($fh); + $fh->close(); + $fh = undef; + + if ($status != AZ_OK) { + unlink($tempName); + _printError("Can't write to $tempName"); + return $status; + } + + my $err; + + # rename the zip + if (-f $zipName && !rename($zipName, $backupName)) { + $err = $!; + unlink($tempName); + return _error("Can't rename $zipName as $backupName", $err); + } + + # move the temp to the original name (possibly copying) + unless (File::Copy::move($tempName, $zipName) + || File::Copy::copy($tempName, $zipName)) { + $err = $!; + rename($backupName, $zipName); + unlink($tempName); + return _error("Can't move $tempName to $zipName", $err); + } + + # unlink the backup + if (-f $backupName && !unlink($backupName)) { + $err = $!; + return _error("Can't unlink $backupName", $err); + } + + return AZ_OK; +} + +# Used only during writing +sub _writeCentralDirectoryOffset { + shift->{'writeCentralDirectoryOffset'}; +} + +sub _writeEOCDOffset { + shift->{'writeEOCDOffset'}; +} + +# Expects to have _writeEOCDOffset() set +sub _writeEndOfCentralDirectory { + my ($self, $fh) = @_; + + $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING) + or return _ioError('writing EOCD Signature'); + my $zipfileCommentLength = length($self->zipfileComment()); + + my $header = pack( + END_OF_CENTRAL_DIRECTORY_FORMAT, + 0, # {'diskNumber'}, + 0, # {'diskNumberWithStartOfCentralDirectory'}, + $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'}, + $self->numberOfMembers(), # {'numberOfCentralDirectories'}, + $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(), + $self->_writeCentralDirectoryOffset(), + $zipfileCommentLength + ); + $self->_print($fh, $header) + or return _ioError('writing EOCD header'); + if ($zipfileCommentLength) { + $self->_print($fh, $self->zipfileComment()) + or return _ioError('writing zipfile comment'); + } + return AZ_OK; +} + +# $offset can be specified to truncate a zip file. +sub writeCentralDirectory { + my $self = shift; + + my ($fh, $offset); + if (ref($_[0]) eq 'HASH') { + $fh = $_[0]->{fileHandle}; + $offset = $_[0]->{offset}; + } else { + ($fh, $offset) = @_; + } + + if (defined($offset)) { + $self->{'writeCentralDirectoryOffset'} = $offset; + $fh->seek($offset, IO::Seekable::SEEK_SET) + or return _ioError('seeking to write central directory'); + } else { + $offset = $self->_writeCentralDirectoryOffset(); + } + + foreach my $member ($self->members()) { + my $status = $member->_writeCentralDirectoryFileHeader($fh); + return $status if $status != AZ_OK; + $offset += $member->_centralDirectoryHeaderSize(); + $self->{'writeEOCDOffset'} = $offset; + } + return $self->_writeEndOfCentralDirectory($fh); +} + +sub read { + my $self = shift; + my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift; + return _error('No filename given') unless $fileName; + my ($status, $fh) = _newFileHandle($fileName, 'r'); + return _ioError("opening $fileName for read") unless $status; + + $status = $self->readFromFileHandle($fh, $fileName); + return $status if $status != AZ_OK; + + $fh->close(); + $self->{'fileName'} = $fileName; + return AZ_OK; +} + +sub readFromFileHandle { + my $self = shift; + + my ($fh, $fileName); + if (ref($_[0]) eq 'HASH') { + $fh = $_[0]->{fileHandle}; + $fileName = $_[0]->{filename}; + } else { + ($fh, $fileName) = @_; + } + + $fileName = $fh unless defined($fileName); + return _error('No filehandle given') unless $fh; + return _ioError('filehandle not open') unless $fh->opened(); + + _binmode($fh); + $self->{'fileName'} = "$fh"; + + # TODO: how to support non-seekable zips? + return _error('file not seekable') + unless _isSeekable($fh); + + $fh->seek(0, 0); # rewind the file + + my $status = $self->_findEndOfCentralDirectory($fh); + return $status if $status != AZ_OK; + + my $eocdPosition = $fh->tell(); + + $status = $self->_readEndOfCentralDirectory($fh); + return $status if $status != AZ_OK; + + $fh->seek($eocdPosition - $self->centralDirectorySize(), + IO::Seekable::SEEK_SET) + or return _ioError("Can't seek $fileName"); + + # Try to detect garbage at beginning of archives + # This should be 0 + $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here + - $self->centralDirectoryOffsetWRTStartingDiskNumber(); + + for (; ;) { + my $newMember = + Archive::Zip::Member->_newFromZipFile($fh, $fileName, + $self->eocdOffset()); + my $signature; + ($status, $signature) = _readSignature($fh, $fileName); + return $status if $status != AZ_OK; + last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE; + $status = $newMember->_readCentralDirectoryFileHeader(); + return $status if $status != AZ_OK; + $status = $newMember->endRead(); + return $status if $status != AZ_OK; + $newMember->_becomeDirectoryIfNecessary(); + push(@{$self->{'members'}}, $newMember); + } + + return AZ_OK; +} + +# Read EOCD, starting from position before signature. +# Return AZ_OK on success. +sub _readEndOfCentralDirectory { + my $self = shift; + my $fh = shift; + + # Skip past signature + $fh->seek(SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR) + or return _ioError("Can't seek past EOCD signature"); + + my $header = ''; + my $bytesRead = $fh->read($header, END_OF_CENTRAL_DIRECTORY_LENGTH); + if ($bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH) { + return _ioError("reading end of central directory"); + } + + my $zipfileCommentLength; + ( + $self->{'diskNumber'}, + $self->{'diskNumberWithStartOfCentralDirectory'}, + $self->{'numberOfCentralDirectoriesOnThisDisk'}, + $self->{'numberOfCentralDirectories'}, + $self->{'centralDirectorySize'}, + $self->{'centralDirectoryOffsetWRTStartingDiskNumber'}, + $zipfileCommentLength + ) = unpack(END_OF_CENTRAL_DIRECTORY_FORMAT, $header); + + if ($self->{'diskNumber'} == 0xFFFF || + $self->{'diskNumberWithStartOfCentralDirectory'} == 0xFFFF || + $self->{'numberOfCentralDirectoriesOnThisDisk'} == 0xFFFF || + $self->{'numberOfCentralDirectories'} == 0xFFFF || + $self->{'centralDirectorySize'} == 0xFFFFFFFF || + $self->{'centralDirectoryOffsetWRTStartingDiskNumber'} == 0xFFFFFFFF) { + return _formatError("zip64 not supported"); + } + + if ($zipfileCommentLength) { + my $zipfileComment = ''; + $bytesRead = $fh->read($zipfileComment, $zipfileCommentLength); + if ($bytesRead != $zipfileCommentLength) { + return _ioError("reading zipfile comment"); + } + $self->{'zipfileComment'} = $zipfileComment; + } + + return AZ_OK; +} + +# Seek in my file to the end, then read backwards until we find the +# signature of the central directory record. Leave the file positioned right +# before the signature. Returns AZ_OK if success. +sub _findEndOfCentralDirectory { + my $self = shift; + my $fh = shift; + my $data = ''; + $fh->seek(0, IO::Seekable::SEEK_END) + or return _ioError("seeking to end"); + + my $fileLength = $fh->tell(); + if ($fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4) { + return _formatError("file is too short"); + } + + my $seekOffset = 0; + my $pos = -1; + for (; ;) { + $seekOffset += 512; + $seekOffset = $fileLength if ($seekOffset > $fileLength); + $fh->seek(-$seekOffset, IO::Seekable::SEEK_END) + or return _ioError("seek failed"); + my $bytesRead = $fh->read($data, $seekOffset); + if ($bytesRead != $seekOffset) { + return _ioError("read failed"); + } + $pos = rindex($data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING); + last + if ( $pos >= 0 + or $seekOffset == $fileLength + or $seekOffset >= $Archive::Zip::ChunkSize); + } + + if ($pos >= 0) { + $fh->seek($pos - $seekOffset, IO::Seekable::SEEK_CUR) + or return _ioError("seeking to EOCD"); + return AZ_OK; + } else { + return _formatError("can't find EOCD signature"); + } +} + +# Used to avoid taint problems when chdir'ing. +# Not intended to increase security in any way; just intended to shut up the -T +# complaints. If your Cwd module is giving you unreliable returns from cwd() +# you have bigger problems than this. +sub _untaintDir { + my $dir = shift; + $dir =~ m/\A(.+)\z/s; + return $1; +} + +sub addTree { + my $self = shift; + + my ($root, $dest, $pred, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $root = $_[0]->{root}; + $dest = $_[0]->{zipName}; + $pred = $_[0]->{select}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($root, $dest, $pred, $compressionLevel) = @_; + } + + return _error("root arg missing in call to addTree()") + unless defined($root); + $dest = '' unless defined($dest); + $pred = sub { -r } + unless defined($pred); + + my @files; + my $startDir = _untaintDir(cwd()); + + return _error('undef returned by _untaintDir on cwd ', cwd()) + unless $startDir; + + # This avoids chdir'ing in Find, in a way compatible with older + # versions of File::Find. + my $wanted = sub { + local $main::_ = $File::Find::name; + my $dir = _untaintDir($File::Find::dir); + chdir($startDir); + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + push(@files, Win32::GetANSIPathName($File::Find::name)) if (&$pred); + $dir = Win32::GetANSIPathName($dir); + } else { + push(@files, $File::Find::name) if (&$pred); + } + chdir($dir); + }; + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $root = Win32::GetANSIPathName($root); + } + File::Find::find($wanted, $root); + + my $rootZipName = _asZipDirName($root, 1); # with trailing slash + my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E"; + + $dest = _asZipDirName($dest, 1); # with trailing slash + + foreach my $fileName (@files) { + my $isDir; + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $isDir = -d Win32::GetANSIPathName($fileName); + } else { + $isDir = -d $fileName; + } + + # normalize, remove leading ./ + my $archiveName = _asZipDirName($fileName, $isDir); + if ($archiveName eq $rootZipName) { $archiveName = $dest } + else { $archiveName =~ s{$pattern}{$dest} } + next if $archiveName =~ m{^\.?/?$}; # skip current dir + my $member = + $isDir + ? $self->addDirectory($fileName, $archiveName) + : $self->addFile($fileName, $archiveName); + $member->desiredCompressionLevel($compressionLevel); + + return _error("add $fileName failed in addTree()") if !$member; + } + return AZ_OK; +} + +sub addTreeMatching { + my $self = shift; + + my ($root, $dest, $pattern, $pred, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $root = $_[0]->{root}; + $dest = $_[0]->{zipName}; + $pattern = $_[0]->{pattern}; + $pred = $_[0]->{select}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($root, $dest, $pattern, $pred, $compressionLevel) = @_; + } + + return _error("root arg missing in call to addTreeMatching()") + unless defined($root); + $dest = '' unless defined($dest); + return _error("pattern missing in call to addTreeMatching()") + unless defined($pattern); + my $matcher = + $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r }; + return $self->addTree($root, $dest, $matcher, $compressionLevel); +} + +# $zip->extractTree( $root, $dest [, $volume] ); +# +# $root and $dest are Unix-style. +# $volume is in local FS format. +# +sub extractTree { + my $self = shift; + + my ($root, $dest, $volume); + if (ref($_[0]) eq 'HASH') { + $root = $_[0]->{root}; + $dest = $_[0]->{zipName}; + $volume = $_[0]->{volume}; + } else { + ($root, $dest, $volume) = @_; + } + + $root = '' unless defined($root); + if (defined $dest) { + if ($dest !~ m{/$}) { + $dest .= '/'; + } + } else { + $dest = './'; + } + + my $pattern = "^\Q$root"; + my @members = $self->membersMatching($pattern); + + foreach my $member (@members) { + my $fileName = $member->fileName(); # in Unix format + $fileName =~ s{$pattern}{$dest}; # in Unix format + # convert to platform format: + $fileName = Archive::Zip::_asLocalName($fileName, $volume); + my $status = $member->extractToFileNamed($fileName); + return $status if $status != AZ_OK; + } + return AZ_OK; +} + +# $zip->updateMember( $memberOrName, $fileName ); +# Returns (possibly updated) member, if any; undef on errors. + +sub updateMember { + my $self = shift; + + my ($oldMember, $fileName); + if (ref($_[0]) eq 'HASH') { + $oldMember = $_[0]->{memberOrZipName}; + $fileName = $_[0]->{name}; + } else { + ($oldMember, $fileName) = @_; + } + + if (!defined($fileName)) { + _error("updateMember(): missing fileName argument"); + return undef; + } + + my @newStat = stat($fileName); + if (!@newStat) { + _ioError("Can't stat $fileName"); + return undef; + } + + my $isDir = -d _; + + my $memberName; + + if (ref($oldMember)) { + $memberName = $oldMember->fileName(); + } else { + $oldMember = $self->memberNamed($memberName = $oldMember) + || $self->memberNamed($memberName = + _asZipDirName($oldMember, $isDir)); + } + + unless (defined($oldMember) + && $oldMember->lastModTime() == $newStat[9] + && $oldMember->isDirectory() == $isDir + && ($isDir || ($oldMember->uncompressedSize() == $newStat[7]))) { + + # create the new member + my $newMember = + $isDir + ? Archive::Zip::Member->newDirectoryNamed($fileName, $memberName) + : Archive::Zip::Member->newFromFile($fileName, $memberName); + + unless (defined($newMember)) { + _error("creation of member $fileName failed in updateMember()"); + return undef; + } + + # replace old member or append new one + if (defined($oldMember)) { + $self->replaceMember($oldMember, $newMember); + } else { + $self->addMember($newMember); + } + + return $newMember; + } + + return $oldMember; +} + +# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] ); +# +# This takes the same arguments as addTree, but first checks to see +# whether the file or directory already exists in the zip file. +# +# If the fourth argument $mirror is true, then delete all my members +# if corresponding files were not found. + +sub updateTree { + my $self = shift; + + my ($root, $dest, $pred, $mirror, $compressionLevel); + if (ref($_[0]) eq 'HASH') { + $root = $_[0]->{root}; + $dest = $_[0]->{zipName}; + $pred = $_[0]->{select}; + $mirror = $_[0]->{mirror}; + $compressionLevel = $_[0]->{compressionLevel}; + } else { + ($root, $dest, $pred, $mirror, $compressionLevel) = @_; + } + + return _error("root arg missing in call to updateTree()") + unless defined($root); + $dest = '' unless defined($dest); + $pred = sub { -r } + unless defined($pred); + + $dest = _asZipDirName($dest, 1); + my $rootZipName = _asZipDirName($root, 1); # with trailing slash + my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E"; + + my @files; + my $startDir = _untaintDir(cwd()); + + return _error('undef returned by _untaintDir on cwd ', cwd()) + unless $startDir; + + # This avoids chdir'ing in Find, in a way compatible with older + # versions of File::Find. + my $wanted = sub { + local $main::_ = $File::Find::name; + my $dir = _untaintDir($File::Find::dir); + chdir($startDir); + push(@files, $File::Find::name) if (&$pred); + chdir($dir); + }; + + File::Find::find($wanted, $root); + + # Now @files has all the files that I could potentially be adding to + # the zip. Only add the ones that are necessary. + # For each file (updated or not), add its member name to @done. + my %done; + foreach my $fileName (@files) { + my @newStat = stat($fileName); + my $isDir = -d _; + + # normalize, remove leading ./ + my $memberName = _asZipDirName($fileName, $isDir); + if ($memberName eq $rootZipName) { $memberName = $dest } + else { $memberName =~ s{$pattern}{$dest} } + next if $memberName =~ m{^\.?/?$}; # skip current dir + + $done{$memberName} = 1; + my $changedMember = $self->updateMember($memberName, $fileName); + $changedMember->desiredCompressionLevel($compressionLevel); + return _error("updateTree failed to update $fileName") + unless ref($changedMember); + } + + # @done now has the archive names corresponding to all the found files. + # If we're mirroring, delete all those members that aren't in @done. + if ($mirror) { + foreach my $member ($self->members()) { + $self->removeMember($member) + unless $done{$member->fileName()}; + } + } + + return AZ_OK; +} + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/BufferedFileHandle.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/BufferedFileHandle.pm new file mode 100644 index 00000000000..2c770c7fb4f --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/BufferedFileHandle.pm @@ -0,0 +1,131 @@ +package Archive::Zip::BufferedFileHandle; + +# File handle that uses a string internally and can seek +# This is given as a demo for getting a zip file written +# to a string. +# I probably should just use IO::Scalar instead. +# Ned Konz, March 2000 + +use strict; +use IO::File; +use Carp; + +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.48'; + $VERSION = eval $VERSION; +} + +sub new { + my $class = shift || __PACKAGE__; + $class = ref($class) || $class; + my $self = bless( + { + content => '', + position => 0, + size => 0 + }, + $class + ); + return $self; +} + +# Utility method to read entire file +sub readFromFile { + my $self = shift; + my $fileName = shift; + my $fh = IO::File->new($fileName, "r"); + CORE::binmode($fh); + if (!$fh) { + Carp::carp("Can't open $fileName: $!\n"); + return undef; + } + local $/ = undef; + $self->{content} = <$fh>; + $self->{size} = length($self->{content}); + return $self; +} + +sub contents { + my $self = shift; + if (@_) { + $self->{content} = shift; + $self->{size} = length($self->{content}); + } + return $self->{content}; +} + +sub binmode { 1 } + +sub close { 1 } + +sub opened { 1 } + +sub eof { + my $self = shift; + return $self->{position} >= $self->{size}; +} + +sub seek { + my $self = shift; + my $pos = shift; + my $whence = shift; + + # SEEK_SET + if ($whence == 0) { $self->{position} = $pos; } + + # SEEK_CUR + elsif ($whence == 1) { $self->{position} += $pos; } + + # SEEK_END + elsif ($whence == 2) { $self->{position} = $self->{size} + $pos; } + else { return 0; } + + return 1; +} + +sub tell { return shift->{position}; } + +# Copy my data to given buffer +sub read { + my $self = shift; + my $buf = \($_[0]); + shift; + my $len = shift; + my $offset = shift || 0; + + $$buf = '' if not defined($$buf); + my $bytesRead = + ($self->{position} + $len > $self->{size}) + ? ($self->{size} - $self->{position}) + : $len; + substr($$buf, $offset, $bytesRead) = + substr($self->{content}, $self->{position}, $bytesRead); + $self->{position} += $bytesRead; + return $bytesRead; +} + +# Copy given buffer to me +sub write { + my $self = shift; + my $buf = \($_[0]); + shift; + my $len = shift; + my $offset = shift || 0; + + $$buf = '' if not defined($$buf); + my $bufLen = length($$buf); + my $bytesWritten = + ($offset + $len > $bufLen) + ? $bufLen - $offset + : $len; + substr($self->{content}, $self->{position}, $bytesWritten) = + substr($$buf, $offset, $bytesWritten); + $self->{size} = length($self->{content}); + return $bytesWritten; +} + +sub clearerr() { 1 } + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/DirectoryMember.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/DirectoryMember.pm new file mode 100644 index 00000000000..fa686343a53 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/DirectoryMember.pm @@ -0,0 +1,80 @@ +package Archive::Zip::DirectoryMember; + +use strict; +use File::Path; + +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw( Archive::Zip::Member ); +} + +use Archive::Zip qw( + :ERROR_CODES + :UTILITY_METHODS +); + +sub _newNamed { + my $class = shift; + my $fileName = shift; # FS name + my $newName = shift; # Zip name + $newName = _asZipDirName($fileName) unless $newName; + my $self = $class->new(@_); + $self->{'externalFileName'} = $fileName; + $self->fileName($newName); + + if (-e $fileName) { + + # -e does NOT do a full stat, so we need to do one now + if (-d _ ) { + my @stat = stat(_); + $self->unixFileAttributes($stat[2]); + my $mod_t = $stat[9]; + if ($^O eq 'MSWin32' and !$mod_t) { + $mod_t = time(); + } + $self->setLastModFileDateTimeFromUnix($mod_t); + + } else { # hmm.. trying to add a non-directory? + _error($fileName, ' exists but is not a directory'); + return undef; + } + } else { + $self->unixFileAttributes($self->DEFAULT_DIRECTORY_PERMISSIONS); + $self->setLastModFileDateTimeFromUnix(time()); + } + return $self; +} + +sub externalFileName { + shift->{'externalFileName'}; +} + +sub isDirectory { + return 1; +} + +sub extractToFileNamed { + my $self = shift; + my $name = shift; # local FS name + my $attribs = $self->unixFileAttributes() & 07777; + mkpath($name, 0, $attribs); # croaks on error + utime($self->lastModTime(), $self->lastModTime(), $name); + return AZ_OK; +} + +sub fileName { + my $self = shift; + my $newName = shift; + $newName =~ s{/?$}{/} if defined($newName); + return $self->SUPER::fileName($newName); +} + +# So people don't get too confused. This way it looks like the problem +# is in their code... +sub contents { + return wantarray ? (undef, AZ_OK) : undef; +} + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FAQ.pod b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FAQ.pod new file mode 100644 index 00000000000..d03f883c869 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FAQ.pod @@ -0,0 +1,344 @@ +=head1 NAME + +Archive::Zip::FAQ - Answers to a few frequently asked questions about Archive::Zip + +=head1 DESCRIPTION + +It seems that I keep answering the same questions over and over again. I +assume that this is because my documentation is deficient, rather than that +people don't read the documentation. + +So this FAQ is an attempt to cut down on the number of personal answers I have +to give. At least I can now say "You I read the FAQ, right?". + +The questions are not in any particular order. The answers assume the current +version of Archive::Zip; some of the answers depend on newly added/fixed +functionality. + +=head1 Install problems on RedHat 8 or 9 with Perl 5.8.0 + +B Archive::Zip won't install on my RedHat 9 system! It's broke! + +B This has become something of a FAQ. +Basically, RedHat broke some versions of Perl by setting LANG to UTF8. +They apparently have a fixed version out as an update. + +You might try running CPAN or creating your Makefile after exporting the LANG +environment variable as + +C + +L + +=head1 Why is my zip file so big? + +B My zip file is actually bigger than what I stored in it! Why? + +B Some things to make sure of: + +=over 4 + +=item Make sure that you are requesting COMPRESSION_DEFLATED if you are storing strings. + +$member->desiredCompressionMethod( COMPRESSION_DEFLATED ); + +=item Don't make lots of little files if you can help it. + +Since zip computes the compression tables for each member, small +members without much entropy won't compress well. Instead, if you've +got lots of repeated strings in your data, try to combine them into +one big member. + +=item Make sure that you are requesting COMPRESSION_STORED if you are storing things that are already compressed. + +If you're storing a .zip, .jpg, .mp3, or other compressed file in a zip, +then don't compress them again. They'll get bigger. + +=back + +=head1 Sample code? + +B Can you send me code to do (whatever)? + +B Have you looked in the C directory yet? It contains: + +=over 4 + +=item examples/calcSizes.pl -- How to find out how big a Zip file will be before writing it + +=item examples/copy.pl -- Copies one Zip file to another + +=item examples/extract.pl -- extract file(s) from a Zip + +=item examples/mailZip.pl -- make and mail a zip file + +=item examples/mfh.pl -- demo for use of MockFileHandle + +=item examples/readScalar.pl -- shows how to use IO::Scalar as the source of a Zip read + +=item examples/selfex.pl -- a brief example of a self-extracting Zip + +=item examples/unzipAll.pl -- uses Archive::Zip::Tree to unzip an entire Zip + +=item examples/updateZip.pl -- shows how to read/modify/write a Zip + +=item examples/updateTree.pl -- shows how to update a Zip in place + +=item examples/writeScalar.pl -- shows how to use IO::Scalar as the destination of a Zip write + +=item examples/writeScalar2.pl -- shows how to use IO::String as the destination of a Zip write + +=item examples/zip.pl -- Constructs a Zip file + +=item examples/zipcheck.pl -- One way to check a Zip file for validity + +=item examples/zipinfo.pl -- Prints out information about a Zip archive file + +=item examples/zipGrep.pl -- Searches for text in Zip files + +=item examples/ziptest.pl -- Lists a Zip file and checks member CRCs + +=item examples/ziprecent.pl -- Puts recent files into a zipfile + +=item examples/ziptest.pl -- Another way to check a Zip file for validity + +=back + +=head1 Can't Read/modify/write same Zip file + +B Why can't I open a Zip file, add a member, and write it back? I get an +error message when I try. + +B Because Archive::Zip doesn't (and can't, generally) read file contents into memory, +the original Zip file is required to stay around until the writing of the new +file is completed. + +The best way to do this is to write the Zip to a temporary file and then +rename the temporary file to have the old name (possibly after deleting the +old one). + +Archive::Zip v1.02 added the archive methods C and +C to do this simply and carefully. + +See C for an example of this technique. + +=head1 File creation time not set + +B Upon extracting files, I see that their modification (and access) times are +set to the time in the Zip archive. However, their creation time is not set to +the same time. Why? + +B Mostly because Perl doesn't give cross-platform access to I. +Indeed, many systems (like Unix) don't support such a concept. +However, if yours does, you can easily set it. Get the modification time from +the member using C. + +=head1 Can't use Archive::Zip on gzip files + +B Can I use Archive::Zip to extract Unix gzip files? + +B No. + +There is a distinction between Unix gzip files, and Zip archives that +also can use the gzip compression. + +Depending on the format of the gzip file, you can use L, or +L to decompress it (and de-archive it in the case of Tar files). + +You can unzip PKZIP/WinZip/etc/ archives using Archive::Zip (that's what +it's for) as long as any compressed members are compressed using +Deflate compression. + +=head1 Add a directory/tree to a Zip + +B How can I add a directory (or tree) full of files to a Zip? + +B You can use the Archive::Zip::addTree*() methods: + + use Archive::Zip; + my $zip = Archive::Zip->new(); + # add all readable files and directories below . as xyz/* + $zip->addTree( '.', 'xyz' ); + # add all readable plain files below /abc as def/* + $zip->addTree( '/abc', 'def', sub { -f && -r } ); + # add all .c files below /tmp as stuff/* + $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' ); + # add all .o files below /tmp as stuff/* if they aren't writable + $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } ); + # add all .so files below /tmp that are smaller than 200 bytes as stuff/* + $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } ); + # and write them into a file + $zip->writeToFileNamed('xxx.zip'); + +=head1 Extract a directory/tree + +B How can I extract some (or all) files from a Zip into a different +directory? + +B You can use the Archive::Zip::extractTree() method: +??? || + + # now extract the same files into /tmpx + $zip->extractTree( 'stuff', '/tmpx' ); + +=head1 Update a directory/tree + +B How can I update a Zip from a directory tree, adding or replacing only +the newer files? + +B You can use the Archive::Zip::updateTree() method that was added in version 1.09. + +=head1 Zip times might be off by 1 second + +B It bothers me greatly that my file times are wrong by one second about half +the time. Why don't you do something about it? + +B Get over it. This is a result of the Zip format storing times in DOS +format, which has a resolution of only two seconds. + +=head1 Zip times don't include time zone information + +B My file times don't respect time zones. What gives? + +B If this is important to you, please submit patches to read the various +Extra Fields that encode times with time zones. I'm just using the DOS +Date/Time, which doesn't have a time zone. + +=head1 How do I make a self-extracting Zip + +B I want to make a self-extracting Zip file. Can I do this? + +B Yes. You can write a self-extracting archive stub (that is, a version of +unzip) to the output filehandle that you pass to writeToFileHandle(). See +examples/selfex.pl for how to write a self-extracting archive. + +However, you should understand that this will only work on one kind of +platform (the one for which the stub was compiled). + +=head1 How can I deal with Zips with prepended garbage (i.e. from Sircam) + +B How can I tell if a Zip has been damaged by adding garbage to the +beginning or inside the file? + +B I added code for this for the Amavis virus scanner. You can query archives +for their 'eocdOffset' property, which should be 0: + + if ($zip->eocdOffset > 0) + { warn($zip->eocdOffset . " bytes of garbage at beginning or within Zip") } + +When members are extracted, this offset will be used to adjust the start of +the member if necessary. + +=head1 Can't extract Shrunk files + +B I'm trying to extract a file out of a Zip produced by PKZIP, and keep +getting this error message: + + error: Unsupported compression combination: read 6, write 0 + +B You can't uncompress this archive member. Archive::Zip only supports uncompressed +members, and compressed members that are compressed using the compression +supported by Compress::Raw::Zlib. That means only Deflated and Stored members. + +Your file is compressed using the Shrink format, which is not supported by +Compress::Raw::Zlib. + +You could, perhaps, use a command-line UnZip program (like the Info-Zip +one) to extract this. + +=head1 Can't do decryption + +B How do I decrypt encrypted Zip members? + +B With some other program or library. Archive::Zip doesn't support decryption, +and probably never will (unless I write it). + +=head1 How to test file integrity? + +B How can Archive::Zip can test the validity of a Zip file? + +B If you try to decompress the file, the gzip streams will report errors +if you have garbage. Most of the time. + +If you try to open the file and a central directory structure can't be +found, an error will be reported. + +When a file is being read, if we can't find a proper PK.. signature in +the right places we report a format error. + +If there is added garbage at the beginning of a Zip file (as inserted +by some viruses), you can find out about it, but Archive::Zip will ignore it, +and you can still use the archive. When it gets written back out the +added stuff will be gone. + +There are two ready-to-use utilities in the examples directory that can +be used to test file integrity, or that you can use as examples +for your own code: + +=over 4 + +=item examples/zipcheck.pl shows how to use an attempted extraction to test a file. + +=item examples/ziptest.pl shows how to test CRCs in a file. + +=back + +=head1 Duplicate files in Zip? + +B Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this? + +B As far as I can tell, this is not disallowed by the Zip spec. If you +think it's a bad idea, check for it yourself: + + $zip->addFile($someFile, $someName) unless $zip->memberNamed($someName); + +I can even imagine cases where this might be useful (for instance, multiple +versions of files). + +=head1 File ownership/permissions/ACLS/etc + +B Why doesn't Archive::Zip deal with file ownership, ACLs, etc.? + +B There is no standard way to represent these in the Zip file format. If +you want to send me code to properly handle the various extra fields that +have been used to represent these through the years, I'll look at it. + +=head1 I can't compile but ActiveState only has an old version of Archive::Zip + +B I've only installed modules using ActiveState's PPM program and +repository. But they have a much older version of Archive::Zip than is in CPAN. Will +you send me a newer PPM? + +B Probably not, unless I get lots of extra time. But there's no reason you +can't install the version from CPAN. Archive::Zip is pure Perl, so all you need is +NMAKE, which you can get for free from Microsoft (see the FAQ in the +ActiveState documentation for details on how to install CPAN modules). + +=head1 My JPEGs (or MP3's) don't compress when I put them into Zips! + +B How come my JPEGs and MP3's don't compress much when I put them into Zips? + +B Because they're already compressed. + +=head1 Under Windows, things lock up/get damaged + +B I'm using Windows. When I try to use Archive::Zip, my machine locks up/makes +funny sounds/displays a BSOD/corrupts data. How can I fix this? + +B First, try the newest version of Compress::Raw::Zlib. I know of +Windows-related problems prior to v1.14 of that library. + +=head1 Zip contents in a scalar + +B I want to read a Zip file from (or write one to) a scalar variable instead +of a file. How can I do this? + +B Use C and the C and +C methods. +See C and C. + +=head1 Reading from streams + +B How do I read from a stream (like for the Info-Zip C program)? + +B This is not currently supported, though writing to a stream is. diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FileMember.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FileMember.pm new file mode 100644 index 00000000000..64e7c9ae06f --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/FileMember.pm @@ -0,0 +1,64 @@ +package Archive::Zip::FileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw ( Archive::Zip::Member ); +} + +use Archive::Zip qw( + :UTILITY_METHODS +); + +sub externalFileName { + shift->{'externalFileName'}; +} + +# Return true if I depend on the named file +sub _usesFileNamed { + my $self = shift; + my $fileName = shift; + my $xfn = $self->externalFileName(); + return undef if ref($xfn); + return $xfn eq $fileName; +} + +sub fh { + my $self = shift; + $self->_openFile() + if !defined($self->{'fh'}) || !$self->{'fh'}->opened(); + return $self->{'fh'}; +} + +# opens my file handle from my file name +sub _openFile { + my $self = shift; + my ($status, $fh) = _newFileHandle($self->externalFileName(), 'r'); + if (!$status) { + _ioError("Can't open", $self->externalFileName()); + return undef; + } + $self->{'fh'} = $fh; + _binmode($fh); + return $fh; +} + +# Make sure I close my file handle +sub endRead { + my $self = shift; + undef $self->{'fh'}; # _closeFile(); + return $self->SUPER::endRead(@_); +} + +sub _become { + my $self = shift; + my $newClass = shift; + return $self if ref($self) eq $newClass; + delete($self->{'externalFileName'}); + delete($self->{'fh'}); + return $self->SUPER::_become($newClass); +} + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Member.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Member.pm new file mode 100644 index 00000000000..94f9d38a8bd --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Member.pm @@ -0,0 +1,1247 @@ +package Archive::Zip::Member; + +# A generic member of an archive + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw( Archive::Zip ); + + if ($^O eq 'MSWin32') { + require Win32; + require Encode; + Encode->import(qw{ decode_utf8 }); + } +} + +use Archive::Zip qw( + :CONSTANTS + :MISC_CONSTANTS + :ERROR_CODES + :PKZIP_CONSTANTS + :UTILITY_METHODS +); + +use Time::Local (); +use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS ); +use File::Path; +use File::Basename; + +# Unix perms for default creation of files/dirs. +use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755; +use constant DEFAULT_FILE_PERMISSIONS => 0100666; +use constant DIRECTORY_ATTRIB => 040000; +use constant FILE_ATTRIB => 0100000; + +# Returns self if successful, else undef +# Assumes that fh is positioned at beginning of central directory file header. +# Leaves fh positioned immediately after file header or EOCD signature. +sub _newFromZipFile { + my $class = shift; + my $self = Archive::Zip::ZipFileMember->_newFromZipFile(@_); + return $self; +} + +sub newFromString { + my $class = shift; + + my ($stringOrStringRef, $fileName); + if (ref($_[0]) eq 'HASH') { + $stringOrStringRef = $_[0]->{string}; + $fileName = $_[0]->{zipName}; + } else { + ($stringOrStringRef, $fileName) = @_; + } + + my $self = + Archive::Zip::StringMember->_newFromString($stringOrStringRef, $fileName); + return $self; +} + +sub newFromFile { + my $class = shift; + + my ($fileName, $zipName); + if (ref($_[0]) eq 'HASH') { + $fileName = $_[0]->{fileName}; + $zipName = $_[0]->{zipName}; + } else { + ($fileName, $zipName) = @_; + } + + my $self = + Archive::Zip::NewFileMember->_newFromFileNamed($fileName, $zipName); + return $self; +} + +sub newDirectoryNamed { + my $class = shift; + + my ($directoryName, $newName); + if (ref($_[0]) eq 'HASH') { + $directoryName = $_[0]->{directoryName}; + $newName = $_[0]->{zipName}; + } else { + ($directoryName, $newName) = @_; + } + + my $self = + Archive::Zip::DirectoryMember->_newNamed($directoryName, $newName); + return $self; +} + +sub new { + my $class = shift; + my $self = { + 'lastModFileDateTime' => 0, + 'fileAttributeFormat' => FA_UNIX, + 'versionMadeBy' => 20, + 'versionNeededToExtract' => 20, + 'bitFlag' => ($Archive::Zip::UNICODE ? 0x0800 : 0), + 'compressionMethod' => COMPRESSION_STORED, + 'desiredCompressionMethod' => COMPRESSION_STORED, + 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE, + 'internalFileAttributes' => 0, + 'externalFileAttributes' => 0, # set later + 'fileName' => '', + 'cdExtraField' => '', + 'localExtraField' => '', + 'fileComment' => '', + 'crc32' => 0, + 'compressedSize' => 0, + 'uncompressedSize' => 0, + 'isSymbolicLink' => 0, + 'password' => undef, # password for encrypted data + 'crc32c' => -1, # crc for decrypted data + @_ + }; + bless($self, $class); + $self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS); + return $self; +} + +sub _becomeDirectoryIfNecessary { + my $self = shift; + $self->_become('Archive::Zip::DirectoryMember') + if $self->isDirectory(); + return $self; +} + +# Morph into given class (do whatever cleanup I need to do) +sub _become { + return bless($_[0], $_[1]); +} + +sub versionMadeBy { + shift->{'versionMadeBy'}; +} + +sub fileAttributeFormat { + my $self = shift; + + if (@_) { + $self->{fileAttributeFormat} = + (ref($_[0]) eq 'HASH') ? $_[0]->{format} : $_[0]; + } else { + return $self->{fileAttributeFormat}; + } +} + +sub versionNeededToExtract { + shift->{'versionNeededToExtract'}; +} + +sub bitFlag { + my $self = shift; + +# Set General Purpose Bit Flags according to the desiredCompressionLevel setting + if ( $self->desiredCompressionLevel == 1 + || $self->desiredCompressionLevel == 2) { + $self->{'bitFlag'} = DEFLATING_COMPRESSION_FAST; + } elsif ($self->desiredCompressionLevel == 3 + || $self->desiredCompressionLevel == 4 + || $self->desiredCompressionLevel == 5 + || $self->desiredCompressionLevel == 6 + || $self->desiredCompressionLevel == 7) { + $self->{'bitFlag'} = DEFLATING_COMPRESSION_NORMAL; + } elsif ($self->desiredCompressionLevel == 8 + || $self->desiredCompressionLevel == 9) { + $self->{'bitFlag'} = DEFLATING_COMPRESSION_MAXIMUM; + } + + if ($Archive::Zip::UNICODE) { + $self->{'bitFlag'} |= 0x0800; + } + $self->{'bitFlag'}; +} + +sub password { + my $self = shift; + $self->{'password'} = shift if @_; + $self->{'password'}; +} + +sub compressionMethod { + shift->{'compressionMethod'}; +} + +sub desiredCompressionMethod { + my $self = shift; + my $newDesiredCompressionMethod = + (ref($_[0]) eq 'HASH') ? shift->{compressionMethod} : shift; + my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'}; + if (defined($newDesiredCompressionMethod)) { + $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod; + if ($newDesiredCompressionMethod == COMPRESSION_STORED) { + $self->{'desiredCompressionLevel'} = 0; + $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK + if $self->uncompressedSize() == 0; + } elsif ($oldDesiredCompressionMethod == COMPRESSION_STORED) { + $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT; + } + } + return $oldDesiredCompressionMethod; +} + +sub desiredCompressionLevel { + my $self = shift; + my $newDesiredCompressionLevel = + (ref($_[0]) eq 'HASH') ? shift->{compressionLevel} : shift; + my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'}; + if (defined($newDesiredCompressionLevel)) { + $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel; + $self->{'desiredCompressionMethod'} = ( + $newDesiredCompressionLevel + ? COMPRESSION_DEFLATED + : COMPRESSION_STORED + ); + } + return $oldDesiredCompressionLevel; +} + +sub fileName { + my $self = shift; + my $newName = shift; + if (defined $newName) { + $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems + $self->{'fileName'} = $newName; + } + return $self->{'fileName'}; +} + +sub lastModFileDateTime { + my $modTime = shift->{'lastModFileDateTime'}; + $modTime =~ m/^(\d+)$/; # untaint + return $1; +} + +sub lastModTime { + my $self = shift; + return _dosToUnixTime($self->lastModFileDateTime()); +} + +sub setLastModFileDateTimeFromUnix { + my $self = shift; + my $time_t = shift; + $self->{'lastModFileDateTime'} = _unixToDosTime($time_t); +} + +sub internalFileAttributes { + shift->{'internalFileAttributes'}; +} + +sub externalFileAttributes { + shift->{'externalFileAttributes'}; +} + +# Convert UNIX permissions into proper value for zip file +# Usable as a function or a method +sub _mapPermissionsFromUnix { + my $self = shift; + my $mode = shift; + my $attribs = $mode << 16; + + # Microsoft Windows Explorer needs this bit set for directories + if ($mode & DIRECTORY_ATTRIB) { + $attribs |= 16; + } + + return $attribs; + + # TODO: map more MS-DOS perms +} + +# Convert ZIP permissions into Unix ones +# +# This was taken from Info-ZIP group's portable UnZip +# zipfile-extraction program, version 5.50. +# http://www.info-zip.org/pub/infozip/ +# +# See the mapattr() function in unix/unix.c +# See the attribute format constants in unzpriv.h +# +# XXX Note that there's one situation that is not implemented +# yet that depends on the "extra field." +sub _mapPermissionsToUnix { + my $self = shift; + + my $format = $self->{'fileAttributeFormat'}; + my $attribs = $self->{'externalFileAttributes'}; + + my $mode = 0; + + if ($format == FA_AMIGA) { + $attribs = $attribs >> 17 & 7; # Amiga RWE bits + $mode = $attribs << 6 | $attribs << 3 | $attribs; + return $mode; + } + + if ($format == FA_THEOS) { + $attribs &= 0xF1FFFFFF; + if (($attribs & 0xF0000000) != 0x40000000) { + $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits + } else { + $attribs &= 0x41FFFFFF; # leave directory bit as set + } + } + + if ( $format == FA_UNIX + || $format == FA_VAX_VMS + || $format == FA_ACORN + || $format == FA_ATARI_ST + || $format == FA_BEOS + || $format == FA_QDOS + || $format == FA_TANDEM) { + $mode = $attribs >> 16; + return $mode if $mode != 0 or not $self->localExtraField; + + # warn("local extra field is: ", $self->localExtraField, "\n"); + + # XXX This condition is not implemented + # I'm just including the comments from the info-zip section for now. + + # Some (non-Info-ZIP) implementations of Zip for Unix and + # VMS (and probably others ??) leave 0 in the upper 16-bit + # part of the external_file_attributes field. Instead, they + # store file permission attributes in some extra field. + # As a work-around, we search for the presence of one of + # these extra fields and fall back to the MSDOS compatible + # part of external_file_attributes if one of the known + # e.f. types has been detected. + # Later, we might implement extraction of the permission + # bits from the VMS extra field. But for now, the work-around + # should be sufficient to provide "readable" extracted files. + # (For ASI Unix e.f., an experimental remap from the e.f. + # mode value IS already provided!) + } + + # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the + # Unix attributes in the upper 16 bits of the external attributes + # field, just like Info-ZIP's Zip for Unix. We try to use that + # value, after a check for consistency with the MSDOS attribute + # bits (see below). + if ($format == FA_MSDOS) { + $mode = $attribs >> 16; + } + + # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20 + $attribs = !($attribs & 1) << 1 | ($attribs & 0x10) >> 4; + + # keep previous $mode setting when its "owner" + # part appears to be consistent with DOS attribute flags! + return $mode if ($mode & 0700) == (0400 | $attribs << 6); + $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs; + return $mode; +} + +sub unixFileAttributes { + my $self = shift; + my $oldPerms = $self->_mapPermissionsToUnix; + + my $perms; + if (@_) { + $perms = (ref($_[0]) eq 'HASH') ? $_[0]->{attributes} : $_[0]; + + if ($self->isDirectory) { + $perms &= ~FILE_ATTRIB; + $perms |= DIRECTORY_ATTRIB; + } else { + $perms &= ~DIRECTORY_ATTRIB; + $perms |= FILE_ATTRIB; + } + $self->{externalFileAttributes} = + $self->_mapPermissionsFromUnix($perms); + } + + return $oldPerms; +} + +sub localExtraField { + my $self = shift; + + if (@_) { + $self->{localExtraField} = + (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0]; + } else { + return $self->{localExtraField}; + } +} + +sub cdExtraField { + my $self = shift; + + if (@_) { + $self->{cdExtraField} = (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0]; + } else { + return $self->{cdExtraField}; + } +} + +sub extraFields { + my $self = shift; + return $self->localExtraField() . $self->cdExtraField(); +} + +sub fileComment { + my $self = shift; + + if (@_) { + $self->{fileComment} = + (ref($_[0]) eq 'HASH') + ? pack('C0a*', $_[0]->{comment}) + : pack('C0a*', $_[0]); + } else { + return $self->{fileComment}; + } +} + +sub hasDataDescriptor { + my $self = shift; + if (@_) { + my $shouldHave = shift; + if ($shouldHave) { + $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK; + } else { + $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK; + } + } + return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK; +} + +sub crc32 { + shift->{'crc32'}; +} + +sub crc32String { + sprintf("%08x", shift->{'crc32'}); +} + +sub compressedSize { + shift->{'compressedSize'}; +} + +sub uncompressedSize { + shift->{'uncompressedSize'}; +} + +sub isEncrypted { + shift->{'bitFlag'} & GPBF_ENCRYPTED_MASK; +} + +sub isTextFile { + my $self = shift; + my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; + if (@_) { + my $flag = (ref($_[0]) eq 'HASH') ? shift->{flag} : shift; + $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; + $self->{'internalFileAttributes'} |= + ($flag ? IFA_TEXT_FILE : IFA_BINARY_FILE); + } + return $bit == IFA_TEXT_FILE; +} + +sub isBinaryFile { + my $self = shift; + my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; + if (@_) { + my $flag = shift; + $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; + $self->{'internalFileAttributes'} |= + ($flag ? IFA_BINARY_FILE : IFA_TEXT_FILE); + } + return $bit == IFA_BINARY_FILE; +} + +sub extractToFileNamed { + my $self = shift; + + # local FS name + my $name = (ref($_[0]) eq 'HASH') ? $_[0]->{name} : $_[0]; + $self->{'isSymbolicLink'} = 0; + + # Check if the file / directory is a symbolic link or not + if ($self->{'externalFileAttributes'} == 0xA1FF0000) { + $self->{'isSymbolicLink'} = 1; + $self->{'newName'} = $name; + my ($status, $fh) = _newFileHandle($name, 'r'); + my $retval = $self->extractToFileHandle($fh); + $fh->close(); + } else { + + #return _writeSymbolicLink($self, $name) if $self->isSymbolicLink(); + + my ($status, $fh); + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = decode_utf8(Win32::GetFullPathName($name)); + mkpath_win32($name); + Win32::CreateFile($name); + ($status, $fh) = _newFileHandle(Win32::GetANSIPathName($name), 'w'); + } else { + mkpath(dirname($name)); # croaks on error + ($status, $fh) = _newFileHandle($name, 'w'); + } + return _ioError("Can't open file $name for write") unless $status; + my $retval = $self->extractToFileHandle($fh); + $fh->close(); + chmod($self->unixFileAttributes(), $name) + or return _error("Can't chmod() ${name}: $!"); + utime($self->lastModTime(), $self->lastModTime(), $name); + return $retval; + } +} + +sub mkpath_win32 { + my $path = shift; + use File::Spec; + + my ($volume, @path) = File::Spec->splitdir($path); + $path = File::Spec->catfile($volume, shift @path); + pop @path; + while (@path) { + $path = File::Spec->catfile($path, shift @path); + Win32::CreateDirectory($path); + } +} + +sub _writeSymbolicLink { + my $self = shift; + my $name = shift; + my $chunkSize = $Archive::Zip::ChunkSize; + + #my ( $outRef, undef ) = $self->readChunk($chunkSize); + my $fh; + my $retval = $self->extractToFileHandle($fh); + my ($outRef, undef) = $self->readChunk(100); +} + +sub isSymbolicLink { + my $self = shift; + if ($self->{'externalFileAttributes'} == 0xA1FF0000) { + $self->{'isSymbolicLink'} = 1; + } else { + return 0; + } + 1; +} + +sub isDirectory { + return 0; +} + +sub externalFileName { + return undef; +} + +# The following are used when copying data +sub _writeOffset { + shift->{'writeOffset'}; +} + +sub _readOffset { + shift->{'readOffset'}; +} + +sub writeLocalHeaderRelativeOffset { + shift->{'writeLocalHeaderRelativeOffset'}; +} + +sub wasWritten { shift->{'wasWritten'} } + +sub _dataEnded { + shift->{'dataEnded'}; +} + +sub _readDataRemaining { + shift->{'readDataRemaining'}; +} + +sub _inflater { + shift->{'inflater'}; +} + +sub _deflater { + shift->{'deflater'}; +} + +# Return the total size of my local header +sub _localHeaderSize { + my $self = shift; + { + use bytes; + return SIGNATURE_LENGTH + + LOCAL_FILE_HEADER_LENGTH + + length($self->fileName()) + + length($self->localExtraField()); + } +} + +# Return the total size of my CD header +sub _centralDirectoryHeaderSize { + my $self = shift; + { + use bytes; + return SIGNATURE_LENGTH + + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH + + length($self->fileName()) + + length($self->cdExtraField()) + + length($self->fileComment()); + } +} + +# DOS date/time format +# 0-4 (5) Second divided by 2 +# 5-10 (6) Minute (0-59) +# 11-15 (5) Hour (0-23 on a 24-hour clock) +# 16-20 (5) Day of the month (1-31) +# 21-24 (4) Month (1 = January, 2 = February, etc.) +# 25-31 (7) Year offset from 1980 (add 1980 to get actual year) + +# Convert DOS date/time format to unix time_t format +# NOT AN OBJECT METHOD! +sub _dosToUnixTime { + my $dt = shift; + return time() unless defined($dt); + + my $year = (($dt >> 25) & 0x7f) + 80; + my $mon = (($dt >> 21) & 0x0f) - 1; + my $mday = (($dt >> 16) & 0x1f); + + my $hour = (($dt >> 11) & 0x1f); + my $min = (($dt >> 5) & 0x3f); + my $sec = (($dt << 1) & 0x3e); + + # catch errors + my $time_t = + eval { Time::Local::timelocal($sec, $min, $hour, $mday, $mon, $year); }; + return time() if ($@); + return $time_t; +} + +# Note, this is not exactly UTC 1980, it's 1980 + 12 hours and 1 +# minute so that nothing timezoney can muck us up. +my $safe_epoch = 315576060; + +# convert a unix time to DOS date/time +# NOT AN OBJECT METHOD! +sub _unixToDosTime { + my $time_t = shift; + unless ($time_t) { + _error("Tried to add member with zero or undef value for time"); + $time_t = $safe_epoch; + } + if ($time_t < $safe_epoch) { + _ioError("Unsupported date before 1980 encountered, moving to 1980"); + $time_t = $safe_epoch; + } + my ($sec, $min, $hour, $mday, $mon, $year) = localtime($time_t); + my $dt = 0; + $dt += ($sec >> 1); + $dt += ($min << 5); + $dt += ($hour << 11); + $dt += ($mday << 16); + $dt += (($mon + 1) << 21); + $dt += (($year - 80) << 25); + return $dt; +} + +sub head { + my ($self, $mode) = (@_, 0); + + use bytes; + return pack LOCAL_FILE_HEADER_FORMAT, + $self->versionNeededToExtract(), + $self->{'bitFlag'}, + $self->desiredCompressionMethod(), + $self->lastModFileDateTime(), + $self->hasDataDescriptor() + ? (0,0,0) # crc, compr & uncompr all zero if data descriptor present + : ( + $self->crc32(), + $mode + ? $self->_writeOffset() # compressed size + : $self->compressedSize(), # may need to be re-written later + $self->uncompressedSize(), + ), + length($self->fileName()), + length($self->localExtraField()); +} + +# Write my local header to a file handle. +# Stores the offset to the start of the header in my +# writeLocalHeaderRelativeOffset member. +# Returns AZ_OK on success. +sub _writeLocalFileHeader { + my $self = shift; + my $fh = shift; + + my $signatureData = pack(SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE); + $self->_print($fh, $signatureData) + or return _ioError("writing local header signature"); + + my $header = $self->head(1); + + $self->_print($fh, $header) or return _ioError("writing local header"); + + # Check for a valid filename or a filename equal to a literal `0' + if ($self->fileName() || $self->fileName eq '0') { + $self->_print($fh, $self->fileName()) + or return _ioError("writing local header filename"); + } + if ($self->localExtraField()) { + $self->_print($fh, $self->localExtraField()) + or return _ioError("writing local extra field"); + } + + return AZ_OK; +} + +sub _writeCentralDirectoryFileHeader { + my $self = shift; + my $fh = shift; + + my $sigData = + pack(SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE); + $self->_print($fh, $sigData) + or return _ioError("writing central directory header signature"); + + my ($fileNameLength, $extraFieldLength, $fileCommentLength); + { + use bytes; + $fileNameLength = length($self->fileName()); + $extraFieldLength = length($self->cdExtraField()); + $fileCommentLength = length($self->fileComment()); + } + + my $header = pack( + CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, + $self->versionMadeBy(), + $self->fileAttributeFormat(), + $self->versionNeededToExtract(), + $self->bitFlag(), + $self->desiredCompressionMethod(), + $self->lastModFileDateTime(), + $self->crc32(), # these three fields should have been updated + $self->_writeOffset(), # by writing the data stream out + $self->uncompressedSize(), # + $fileNameLength, + $extraFieldLength, + $fileCommentLength, + 0, # {'diskNumberStart'}, + $self->internalFileAttributes(), + $self->externalFileAttributes(), + $self->writeLocalHeaderRelativeOffset()); + + $self->_print($fh, $header) + or return _ioError("writing central directory header"); + if ($fileNameLength) { + $self->_print($fh, $self->fileName()) + or return _ioError("writing central directory header signature"); + } + if ($extraFieldLength) { + $self->_print($fh, $self->cdExtraField()) + or return _ioError("writing central directory extra field"); + } + if ($fileCommentLength) { + $self->_print($fh, $self->fileComment()) + or return _ioError("writing central directory file comment"); + } + + return AZ_OK; +} + +# This writes a data descriptor to the given file handle. +# Assumes that crc32, writeOffset, and uncompressedSize are +# set correctly (they should be after a write). +# Further, the local file header should have the +# GPBF_HAS_DATA_DESCRIPTOR_MASK bit set. +sub _writeDataDescriptor { + my $self = shift; + my $fh = shift; + my $header = pack( + SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT, + DATA_DESCRIPTOR_SIGNATURE, + $self->crc32(), + $self->_writeOffset(), # compressed size + $self->uncompressedSize()); + + $self->_print($fh, $header) + or return _ioError("writing data descriptor"); + return AZ_OK; +} + +# Re-writes the local file header with new crc32 and compressedSize fields. +# To be called after writing the data stream. +# Assumes that filename and extraField sizes didn't change since last written. +sub _refreshLocalFileHeader { + my $self = shift; + my $fh = shift; + + my $here = $fh->tell(); + $fh->seek($self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH, + IO::Seekable::SEEK_SET) + or return _ioError("seeking to rewrite local header"); + + my $header = $self->head(1); + + $self->_print($fh, $header) + or return _ioError("re-writing local header"); + $fh->seek($here, IO::Seekable::SEEK_SET) + or return _ioError("seeking after rewrite of local header"); + + return AZ_OK; +} + +sub readChunk { + my $self = shift; + my $chunkSize = (ref($_[0]) eq 'HASH') ? $_[0]->{chunkSize} : $_[0]; + + if ($self->readIsDone()) { + $self->endRead(); + my $dummy = ''; + return (\$dummy, AZ_STREAM_END); + } + + $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize); + $chunkSize = $self->_readDataRemaining() + if $chunkSize > $self->_readDataRemaining(); + + my $buffer = ''; + my $outputRef; + my ($bytesRead, $status) = $self->_readRawChunk(\$buffer, $chunkSize); + return (\$buffer, $status) unless $status == AZ_OK; + + $buffer && $self->isEncrypted and $buffer = $self->_decode($buffer); + $self->{'readDataRemaining'} -= $bytesRead; + $self->{'readOffset'} += $bytesRead; + + if ($self->compressionMethod() == COMPRESSION_STORED) { + $self->{'crc32'} = $self->computeCRC32($buffer, $self->{'crc32'}); + } + + ($outputRef, $status) = &{$self->{'chunkHandler'}}($self, \$buffer); + $self->{'writeOffset'} += length($$outputRef); + + $self->endRead() + if $self->readIsDone(); + + return ($outputRef, $status); +} + +# Read the next raw chunk of my data. Subclasses MUST implement. +# my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize ); +sub _readRawChunk { + my $self = shift; + return $self->_subclassResponsibility(); +} + +# A place holder to catch rewindData errors if someone ignores +# the error code. +sub _noChunk { + my $self = shift; + return (\undef, _error("trying to copy chunk when init failed")); +} + +# Basically a no-op so that I can have a consistent interface. +# ( $outputRef, $status) = $self->_copyChunk( \$buffer ); +sub _copyChunk { + my ($self, $dataRef) = @_; + return ($dataRef, AZ_OK); +} + +# ( $outputRef, $status) = $self->_deflateChunk( \$buffer ); +sub _deflateChunk { + my ($self, $buffer) = @_; + my ($status) = $self->_deflater()->deflate($buffer, my $out); + + if ($self->_readDataRemaining() == 0) { + my $extraOutput; + ($status) = $self->_deflater()->flush($extraOutput); + $out .= $extraOutput; + $self->endRead(); + return (\$out, AZ_STREAM_END); + } elsif ($status == Z_OK) { + return (\$out, AZ_OK); + } else { + $self->endRead(); + my $retval = _error('deflate error', $status); + my $dummy = ''; + return (\$dummy, $retval); + } +} + +# ( $outputRef, $status) = $self->_inflateChunk( \$buffer ); +sub _inflateChunk { + my ($self, $buffer) = @_; + my ($status) = $self->_inflater()->inflate($buffer, my $out); + my $retval; + $self->endRead() unless $status == Z_OK; + if ($status == Z_OK || $status == Z_STREAM_END) { + $retval = ($status == Z_STREAM_END) ? AZ_STREAM_END : AZ_OK; + return (\$out, $retval); + } else { + $retval = _error('inflate error', $status); + my $dummy = ''; + return (\$dummy, $retval); + } +} + +sub rewindData { + my $self = shift; + my $status; + + # set to trap init errors + $self->{'chunkHandler'} = $self->can('_noChunk'); + + # Work around WinZip bug with 0-length DEFLATED files + $self->desiredCompressionMethod(COMPRESSION_STORED) + if $self->uncompressedSize() == 0; + + # assume that we're going to read the whole file, and compute the CRC anew. + $self->{'crc32'} = 0 + if ($self->compressionMethod() == COMPRESSION_STORED); + + # These are the only combinations of methods we deal with right now. + if ( $self->compressionMethod() == COMPRESSION_STORED + and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED) { + ($self->{'deflater'}, $status) = Compress::Raw::Zlib::Deflate->new( + '-Level' => $self->desiredCompressionLevel(), + '-WindowBits' => -MAX_WBITS(), # necessary magic + '-Bufsize' => $Archive::Zip::ChunkSize, + @_ + ); # pass additional options + return _error('deflateInit error:', $status) + unless $status == Z_OK; + $self->{'chunkHandler'} = $self->can('_deflateChunk'); + } elsif ($self->compressionMethod() == COMPRESSION_DEFLATED + and $self->desiredCompressionMethod() == COMPRESSION_STORED) { + ($self->{'inflater'}, $status) = Compress::Raw::Zlib::Inflate->new( + '-WindowBits' => -MAX_WBITS(), # necessary magic + '-Bufsize' => $Archive::Zip::ChunkSize, + @_ + ); # pass additional options + return _error('inflateInit error:', $status) + unless $status == Z_OK; + $self->{'chunkHandler'} = $self->can('_inflateChunk'); + } elsif ($self->compressionMethod() == $self->desiredCompressionMethod()) { + $self->{'chunkHandler'} = $self->can('_copyChunk'); + } else { + return _error( + sprintf( + "Unsupported compression combination: read %d, write %d", + $self->compressionMethod(), + $self->desiredCompressionMethod())); + } + + $self->{'readDataRemaining'} = + ($self->compressionMethod() == COMPRESSION_STORED) + ? $self->uncompressedSize() + : $self->compressedSize(); + $self->{'dataEnded'} = 0; + $self->{'readOffset'} = 0; + + return AZ_OK; +} + +sub endRead { + my $self = shift; + delete $self->{'inflater'}; + delete $self->{'deflater'}; + $self->{'dataEnded'} = 1; + $self->{'readDataRemaining'} = 0; + return AZ_OK; +} + +sub readIsDone { + my $self = shift; + return ($self->_dataEnded() or !$self->_readDataRemaining()); +} + +sub contents { + my $self = shift; + my $newContents = shift; + + if (defined($newContents)) { + + # change our type and call the subclass contents method. + $self->_become('Archive::Zip::StringMember'); + return $self->contents(pack('C0a*', $newContents)); # in case of Unicode + } else { + my $oldCompression = + $self->desiredCompressionMethod(COMPRESSION_STORED); + my $status = $self->rewindData(@_); + if ($status != AZ_OK) { + $self->endRead(); + return $status; + } + my $retval = ''; + while ($status == AZ_OK) { + my $ref; + ($ref, $status) = $self->readChunk($self->_readDataRemaining()); + + # did we get it in one chunk? + if (length($$ref) == $self->uncompressedSize()) { + $retval = $$ref; + } else { + $retval .= $$ref + } + } + $self->desiredCompressionMethod($oldCompression); + $self->endRead(); + $status = AZ_OK if $status == AZ_STREAM_END; + $retval = undef unless $status == AZ_OK; + return wantarray ? ($retval, $status) : $retval; + } +} + +sub extractToFileHandle { + my $self = shift; + my $fh = (ref($_[0]) eq 'HASH') ? shift->{fileHandle} : shift; + _binmode($fh); + my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED); + my $status = $self->rewindData(@_); + $status = $self->_writeData($fh) if $status == AZ_OK; + $self->desiredCompressionMethod($oldCompression); + $self->endRead(); + return $status; +} + +# write local header and data stream to file handle +sub _writeToFileHandle { + my $self = shift; + my $fh = shift; + my $fhIsSeekable = shift; + my $offset = shift; + + return _error("no member name given for $self") + if $self->fileName() eq ''; + + $self->{'writeLocalHeaderRelativeOffset'} = $offset; + $self->{'wasWritten'} = 0; + + # Determine if I need to write a data descriptor + # I need to do this if I can't refresh the header + # and I don't know compressed size or crc32 fields. + my $headerFieldsUnknown = ( + ($self->uncompressedSize() > 0) + and ($self->compressionMethod() == COMPRESSION_STORED + or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED)); + + my $shouldWriteDataDescriptor = + ($headerFieldsUnknown and not $fhIsSeekable); + + $self->hasDataDescriptor(1) + if ($shouldWriteDataDescriptor); + + $self->{'writeOffset'} = 0; + + my $status = $self->rewindData(); + ($status = $self->_writeLocalFileHeader($fh)) + if $status == AZ_OK; + ($status = $self->_writeData($fh)) + if $status == AZ_OK; + if ($status == AZ_OK) { + $self->{'wasWritten'} = 1; + if ($self->hasDataDescriptor()) { + $status = $self->_writeDataDescriptor($fh); + } elsif ($headerFieldsUnknown) { + $status = $self->_refreshLocalFileHeader($fh); + } + } + + return $status; +} + +# Copy my (possibly compressed) data to given file handle. +# Returns C on success +sub _writeData { + my $self = shift; + my $writeFh = shift; + +# If symbolic link, just create one if the operating system is Linux, Unix, BSD or VMS +# TODO: Add checks for other operating systems + if ($self->{'isSymbolicLink'} == 1 && $^O eq 'linux') { + my $chunkSize = $Archive::Zip::ChunkSize; + my ($outRef, $status) = $self->readChunk($chunkSize); + symlink $$outRef, $self->{'newName'}; + } else { + return AZ_OK if ($self->uncompressedSize() == 0); + my $status; + my $chunkSize = $Archive::Zip::ChunkSize; + while ($self->_readDataRemaining() > 0) { + my $outRef; + ($outRef, $status) = $self->readChunk($chunkSize); + return $status if ($status != AZ_OK and $status != AZ_STREAM_END); + + if (length($$outRef) > 0) { + $self->_print($writeFh, $$outRef) + or return _ioError("write error during copy"); + } + + last if $status == AZ_STREAM_END; + } + } + return AZ_OK; +} + +# Return true if I depend on the named file +sub _usesFileNamed { + return 0; +} + +# ############################################################################## +# +# Decrypt section +# +# H.Merijn Brand (Tux) 2011-06-28 +# +# ############################################################################## + +# This code is derived from the crypt source of unzip-6.0 dated 05 Jan 2007 +# Its license states: +# +# --8<--- +# Copyright (c) 1990-2007 Info-ZIP. All rights reserved. + +# See the accompanying file LICENSE, version 2005-Feb-10 or later +# (the contents of which are also included in (un)zip.h) for terms of use. +# If, for some reason, all these files are missing, the Info-ZIP license +# also may be found at: ftp://ftp.info-zip.org/pub/infozip/license.html +# +# crypt.c (full version) by Info-ZIP. Last revised: [see crypt.h] + +# The main encryption/decryption source code for Info-Zip software was +# originally written in Europe. To the best of our knowledge, it can +# be freely distributed in both source and object forms from any country, +# including the USA under License Exception TSU of the U.S. Export +# Administration Regulations (section 740.13(e)) of 6 June 2002. + +# NOTE on copyright history: +# Previous versions of this source package (up to version 2.8) were +# not copyrighted and put in the public domain. If you cannot comply +# with the Info-Zip LICENSE, you may want to look for one of those +# public domain versions. +# +# This encryption code is a direct transcription of the algorithm from +# Roger Schlafly, described by Phil Katz in the file appnote.txt. This +# file (appnote.txt) is distributed with the PKZIP program (even in the +# version without encryption capabilities). +# -->8--- + +# As of January 2000, US export regulations were amended to allow export +# of free encryption source code from the US. As of June 2002, these +# regulations were further relaxed to allow export of encryption binaries +# associated with free encryption source code. The Zip 2.31, UnZip 5.52 +# and Wiz 5.02 archives now include full crypto source code. As of the +# Zip 2.31 release, all official binaries include encryption support; the +# former "zcr" archives ceased to exist. +# (Note that restrictions may still exist in other countries, of course.) + +# For now, we just support the decrypt stuff +# All below methods are supposed to be private + +# use Data::Peek; + +my @keys; +my @crct = do { + my $xor = 0xedb88320; + my @crc = (0) x 1024; + + # generate a crc for every 8-bit value + foreach my $n (0 .. 255) { + my $c = $n; + $c = $c & 1 ? $xor ^ ($c >> 1) : $c >> 1 for 1 .. 8; + $crc[$n] = _revbe($c); + } + + # generate crc for each value followed by one, two, and three zeros */ + foreach my $n (0 .. 255) { + my $c = ($crc[($crc[$n] >> 24) ^ 0] ^ ($crc[$n] << 8)) & 0xffffffff; + $crc[$_ * 256 + $n] = $c for 1 .. 3; + } + map { _revbe($crc[$_]) } 0 .. 1023; +}; + +sub _crc32 { + my ($c, $b) = @_; + return ($crct[($c ^ $b) & 0xff] ^ ($c >> 8)); +} # _crc32 + +sub _revbe { + my $w = shift; + return (($w >> 24) + + (($w >> 8) & 0xff00) + + (($w & 0xff00) << 8) + + (($w & 0xff) << 24)); +} # _revbe + +sub _update_keys { + use integer; + my $c = shift; # signed int + $keys[0] = _crc32($keys[0], $c); + $keys[1] = (($keys[1] + ($keys[0] & 0xff)) * 0x08088405 + 1) & 0xffffffff; + my $keyshift = $keys[1] >> 24; + $keys[2] = _crc32($keys[2], $keyshift); +} # _update_keys + +sub _zdecode ($) { + my $c = shift; + my $t = ($keys[2] & 0xffff) | 2; + _update_keys($c ^= ((($t * ($t ^ 1)) >> 8) & 0xff)); + return $c; +} # _zdecode + +sub _decode { + my $self = shift; + my $buff = shift; + + $self->isEncrypted or return $buff; + + my $pass = $self->password; + defined $pass or return ""; + + @keys = (0x12345678, 0x23456789, 0x34567890); + _update_keys($_) for unpack "C*", $pass; + + # DDumper { uk => [ @keys ] }; + + my $head = substr $buff, 0, 12, ""; + my @head = map { _zdecode($_) } unpack "C*", $head; + my $x = + $self->{externalFileAttributes} + ? ($self->{lastModFileDateTime} >> 8) & 0xff + : $self->{crc32} >> 24; + $head[-1] == $x or return ""; # Password fail + + # Worth checking ... + $self->{crc32c} = (unpack LOCAL_FILE_HEADER_FORMAT, pack "C*", @head)[3]; + + # DHexDump ($buff); + $buff = pack "C*" => map { _zdecode($_) } unpack "C*" => $buff; + + # DHexDump ($buff); + return $buff; +} # _decode + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MemberRead.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MemberRead.pm new file mode 100644 index 00000000000..acb91ebb16a --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MemberRead.pm @@ -0,0 +1,348 @@ +package Archive::Zip::MemberRead; + +=head1 NAME + +Archive::Zip::MemberRead - A wrapper that lets you read Zip archive members as if they were files. + +=cut + +=head1 SYNOPSIS + + use Archive::Zip; + use Archive::Zip::MemberRead; + $zip = Archive::Zip->new("file.zip"); + $fh = Archive::Zip::MemberRead->new($zip, "subdir/abc.txt"); + while (defined($line = $fh->getline())) + { + print $fh->input_line_number . "#: $line\n"; + } + + $read = $fh->read($buffer, 32*1024); + print "Read $read bytes as :$buffer:\n"; + +=head1 DESCRIPTION + +The Archive::Zip::MemberRead module lets you read Zip archive member data +just like you read data from files. + +=head1 METHODS + +=over 4 + +=cut + +use strict; + +use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); + +use vars qw{$VERSION}; + +my $nl; + +BEGIN { + $VERSION = '1.48'; + $VERSION = eval $VERSION; + +# Requirement for newline conversion. Should check for e.g., DOS and OS/2 as well, but am too lazy. + $nl = $^O eq 'MSWin32' ? "\r\n" : "\n"; +} + +=item Archive::Zip::Member::readFileHandle() + +You can get a C from an archive member by +calling C: + + my $member = $zip->memberNamed('abc/def.c'); + my $fh = $member->readFileHandle(); + while (defined($line = $fh->getline())) + { + # ... + } + $fh->close(); + +=cut + +sub Archive::Zip::Member::readFileHandle { + return Archive::Zip::MemberRead->new(shift()); +} + +=item Archive::Zip::MemberRead->new($zip, $fileName) + +=item Archive::Zip::MemberRead->new($zip, $member) + +=item Archive::Zip::MemberRead->new($member) + +Construct a new Archive::Zip::MemberRead on the specified member. + + my $fh = Archive::Zip::MemberRead->new($zip, 'fred.c') + +=cut + +sub new { + my ($class, $zip, $file) = @_; + my ($self, $member); + + if ($zip && $file) # zip and filename, or zip and member + { + $member = ref($file) ? $file : $zip->memberNamed($file); + } elsif ($zip && !$file && ref($zip)) # just member + { + $member = $zip; + } else { + die( + 'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member' + ); + } + + $self = {}; + bless($self, $class); + $self->set_member($member); + return $self; +} + +sub set_member { + my ($self, $member) = @_; + + $self->{member} = $member; + $self->set_compression(COMPRESSION_STORED); + $self->rewind(); +} + +sub set_compression { + my ($self, $compression) = @_; + $self->{member}->desiredCompressionMethod($compression) if $self->{member}; +} + +=item setLineEnd(expr) + +Set the line end character to use. This is set to \n by default +except on Windows systems where it is set to \r\n. You will +only need to set this on systems which are not Windows or Unix +based and require a line end different from \n. +This is a class method so call as C->C + +=cut + +sub setLineEnd { + shift; + $nl = shift; +} + +=item rewind() + +Rewinds an C so that you can read from it again +starting at the beginning. + +=cut + +sub rewind { + my $self = shift; + + $self->_reset_vars(); + $self->{member}->rewindData() if $self->{member}; +} + +sub _reset_vars { + my $self = shift; + + $self->{line_no} = 0; + $self->{at_end} = 0; + + delete $self->{buffer}; +} + +=item input_record_separator(expr) + +If the argument is given, input_record_separator for this +instance is set to it. The current setting (which may be +the global $/) is always returned. + +=cut + +sub input_record_separator { + my $self = shift; + if (@_) { + $self->{sep} = shift; + $self->{sep_re} = + _sep_as_re($self->{sep}); # Cache the RE as an optimization + } + return exists $self->{sep} ? $self->{sep} : $/; +} + +# Return the input_record_separator in use as an RE fragment +# Note that if we have a per-instance input_record_separator +# we can just return the already converted value. Otherwise, +# the conversion must be done on $/ every time since we cannot +# know whether it has changed or not. +sub _sep_re { + my $self = shift; + + # Important to phrase this way: sep's value may be undef. + return exists $self->{sep} ? $self->{sep_re} : _sep_as_re($/); +} + +# Convert the input record separator into an RE and return it. +sub _sep_as_re { + my $sep = shift; + if (defined $sep) { + if ($sep eq '') { + return "(?:$nl){2,}"; + } else { + $sep =~ s/\n/$nl/og; + return quotemeta $sep; + } + } else { + return undef; + } +} + +=item input_line_number() + +Returns the current line number, but only if you're using C. +Using C will not update the line number. + +=cut + +sub input_line_number { + my $self = shift; + return $self->{line_no}; +} + +=item close() + +Closes the given file handle. + +=cut + +sub close { + my $self = shift; + + $self->_reset_vars(); + $self->{member}->endRead(); +} + +=item buffer_size([ $size ]) + +Gets or sets the buffer size used for reads. +Default is the chunk size used by Archive::Zip. + +=cut + +sub buffer_size { + my ($self, $size) = @_; + + if (!$size) { + return $self->{chunkSize} || Archive::Zip::chunkSize(); + } else { + $self->{chunkSize} = $size; + } +} + +=item getline() + +Returns the next line from the currently open member. +Makes sense only for text files. +A read error is considered fatal enough to die. +Returns undef on eof. All subsequent calls would return undef, +unless a rewind() is called. +Note: The line returned has the input_record_separator (default: newline) removed. + +=item getline( { preserve_line_ending => 1 } ) + +Returns the next line including the line ending. + +=cut + +sub getline { + my ($self, $argref) = @_; + + my $size = $self->buffer_size(); + my $sep = $self->_sep_re(); + + my $preserve_line_ending; + if (ref $argref eq 'HASH') { + $preserve_line_ending = $argref->{'preserve_line_ending'}; + $sep =~ s/\\([^A-Za-z_0-9])+/$1/g; + } + + for (; ;) { + if ( $sep + && defined($self->{buffer}) + && $self->{buffer} =~ s/^(.*?)$sep//s) { + my $line = $1; + $self->{line_no}++; + if ($preserve_line_ending) { + return $line . $sep; + } else { + return $line; + } + } elsif ($self->{at_end}) { + $self->{line_no}++ if $self->{buffer}; + return delete $self->{buffer}; + } + my ($temp, $status) = $self->{member}->readChunk($size); + if ($status != AZ_OK && $status != AZ_STREAM_END) { + die "ERROR: Error reading chunk from archive - $status"; + } + $self->{at_end} = $status == AZ_STREAM_END; + $self->{buffer} .= $$temp; + } +} + +=item read($buffer, $num_bytes_to_read) + +Simulates a normal C system call. +Returns the no. of bytes read. C on error, 0 on eof, I: + + $fh = Archive::Zip::MemberRead->new($zip, "sreeji/secrets.bin"); + while (1) + { + $read = $fh->read($buffer, 1024); + die "FATAL ERROR reading my secrets !\n" if (!defined($read)); + last if (!$read); + # Do processing. + .... + } + +=cut + +# +# All these $_ are required to emulate read(). +# +sub read { + my $self = $_[0]; + my $size = $_[2]; + my ($temp, $status, $ret); + + ($temp, $status) = $self->{member}->readChunk($size); + if ($status != AZ_OK && $status != AZ_STREAM_END) { + $_[1] = undef; + $ret = undef; + } else { + $_[1] = $$temp; + $ret = length($$temp); + } + return $ret; +} + +1; + +=back + +=head1 AUTHOR + +Sreeji K. Das Esreeji_k@yahoo.comE + +See L by Ned Konz without which this module does not make +any sense! + +Minor mods by Ned Konz. + +=head1 COPYRIGHT + +Copyright 2002 Sreeji K. Das. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MockFileHandle.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MockFileHandle.pm new file mode 100644 index 00000000000..7d1d65ce682 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/MockFileHandle.pm @@ -0,0 +1,69 @@ +package Archive::Zip::MockFileHandle; + +# Output file handle that calls a custom write routine +# Ned Konz, March 2000 +# This is provided to help with writing zip files +# when you have to process them a chunk at a time. + +use strict; + +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.48'; + $VERSION = eval $VERSION; +} + +sub new { + my $class = shift || __PACKAGE__; + $class = ref($class) || $class; + my $self = bless( + { + 'position' => 0, + 'size' => 0 + }, + $class + ); + return $self; +} + +sub eof { + my $self = shift; + return $self->{'position'} >= $self->{'size'}; +} + +# Copy given buffer to me +sub print { + my $self = shift; + my $bytes = join('', @_); + my $bytesWritten = $self->writeHook($bytes); + if ($self->{'position'} + $bytesWritten > $self->{'size'}) { + $self->{'size'} = $self->{'position'} + $bytesWritten; + } + $self->{'position'} += $bytesWritten; + return $bytesWritten; +} + +# Called on each write. +# Override in subclasses. +# Return number of bytes written (0 on error). +sub writeHook { + my $self = shift; + my $bytes = shift; + return length($bytes); +} + +sub binmode { 1 } + +sub close { 1 } + +sub clearerr { 1 } + +# I'm write-only! +sub read { 0 } + +sub tell { return shift->{'position'} } + +sub opened { 1 } + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/NewFileMember.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/NewFileMember.pm new file mode 100644 index 00000000000..a7c69b6e1b4 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/NewFileMember.pm @@ -0,0 +1,77 @@ +package Archive::Zip::NewFileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw ( Archive::Zip::FileMember ); +} + +use Archive::Zip qw( + :CONSTANTS + :ERROR_CODES + :UTILITY_METHODS +); + +# Given a file name, set up for eventual writing. +sub _newFromFileNamed { + my $class = shift; + my $fileName = shift; # local FS format + my $newName = shift; + $newName = _asZipDirName($fileName) unless defined($newName); + return undef unless (stat($fileName) && -r _ && !-d _ ); + my $self = $class->new(@_); + $self->{'fileName'} = $newName; + $self->{'externalFileName'} = $fileName; + $self->{'compressionMethod'} = COMPRESSION_STORED; + my @stat = stat(_); + $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7]; + $self->desiredCompressionMethod( + ($self->compressedSize() > 0) + ? COMPRESSION_DEFLATED + : COMPRESSION_STORED + ); + $self->unixFileAttributes($stat[2]); + $self->setLastModFileDateTimeFromUnix($stat[9]); + $self->isTextFile(-T _ ); + return $self; +} + +sub rewindData { + my $self = shift; + + my $status = $self->SUPER::rewindData(@_); + return $status unless $status == AZ_OK; + + return AZ_IO_ERROR unless $self->fh(); + $self->fh()->clearerr(); + $self->fh()->seek(0, IO::Seekable::SEEK_SET) + or return _ioError("rewinding", $self->externalFileName()); + return AZ_OK; +} + +# Return bytes read. Note that first parameter is a ref to a buffer. +# my $data; +# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); +sub _readRawChunk { + my ($self, $dataRef, $chunkSize) = @_; + return (0, AZ_OK) unless $chunkSize; + my $bytesRead = $self->fh()->read($$dataRef, $chunkSize) + or return (0, _ioError("reading data")); + return ($bytesRead, AZ_OK); +} + +# If I already exist, extraction is a no-op. +sub extractToFileNamed { + my $self = shift; + my $name = shift; # local FS name + if (File::Spec->rel2abs($name) eq + File::Spec->rel2abs($self->externalFileName()) and -r $name) { + return AZ_OK; + } else { + return $self->SUPER::extractToFileNamed($name, @_); + } +} + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/StringMember.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/StringMember.pm new file mode 100644 index 00000000000..74a0e8347db --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/StringMember.pm @@ -0,0 +1,64 @@ +package Archive::Zip::StringMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw( Archive::Zip::Member ); +} + +use Archive::Zip qw( + :CONSTANTS + :ERROR_CODES +); + +# Create a new string member. Default is COMPRESSION_STORED. +# Can take a ref to a string as well. +sub _newFromString { + my $class = shift; + my $string = shift; + my $name = shift; + my $self = $class->new(@_); + $self->contents($string); + $self->fileName($name) if defined($name); + + # Set the file date to now + $self->setLastModFileDateTimeFromUnix(time()); + $self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS); + return $self; +} + +sub _become { + my $self = shift; + my $newClass = shift; + return $self if ref($self) eq $newClass; + delete($self->{'contents'}); + return $self->SUPER::_become($newClass); +} + +# Get or set my contents. Note that we do not call the superclass +# version of this, because it calls us. +sub contents { + my $self = shift; + my $string = shift; + if (defined($string)) { + $self->{'contents'} = + pack('C0a*', (ref($string) eq 'SCALAR') ? $$string : $string); + $self->{'uncompressedSize'} = $self->{'compressedSize'} = + length($self->{'contents'}); + $self->{'compressionMethod'} = COMPRESSION_STORED; + } + return $self->{'contents'}; +} + +# Return bytes read. Note that first parameter is a ref to a buffer. +# my $data; +# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); +sub _readRawChunk { + my ($self, $dataRef, $chunkSize) = @_; + $$dataRef = substr($self->contents(), $self->_readOffset(), $chunkSize); + return (length($$dataRef), AZ_OK); +} + +1; diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Tree.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Tree.pm new file mode 100644 index 00000000000..6e84011998c --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/Tree.pm @@ -0,0 +1,48 @@ +package Archive::Zip::Tree; + +use strict; +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.48'; +} + +use Archive::Zip; + +warn( + "Archive::Zip::Tree is deprecated; its methods have been moved into Archive::Zip." +) if $^W; + +1; + +__END__ + +=head1 NAME + +Archive::Zip::Tree - (DEPRECATED) methods for adding/extracting trees using Archive::Zip + +=head1 DESCRIPTION + +This module is deprecated, because all its methods were moved into the main +Archive::Zip module. + +It is included in the distribution merely to avoid breaking old code. + +See L. + +=head1 AUTHOR + +Ned Konz, perl@bike-nomad.com + +=head1 COPYRIGHT + +Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=head1 SEE ALSO + +L + +=cut + diff --git a/dev-tools/src/main/resources/license-check/lib/Archive/Zip/ZipFileMember.pm b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/ZipFileMember.pm new file mode 100644 index 00000000000..1716aa12420 --- /dev/null +++ b/dev-tools/src/main/resources/license-check/lib/Archive/Zip/ZipFileMember.pm @@ -0,0 +1,416 @@ +package Archive::Zip::ZipFileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.48'; + @ISA = qw ( Archive::Zip::FileMember ); +} + +use Archive::Zip qw( + :CONSTANTS + :ERROR_CODES + :PKZIP_CONSTANTS + :UTILITY_METHODS +); + +# Create a new Archive::Zip::ZipFileMember +# given a filename and optional open file handle +# +sub _newFromZipFile { + my $class = shift; + my $fh = shift; + my $externalFileName = shift; + my $possibleEocdOffset = shift; # normally 0 + + my $self = $class->new( + 'crc32' => 0, + 'diskNumberStart' => 0, + 'localHeaderRelativeOffset' => 0, + 'dataOffset' => 0, # localHeaderRelativeOffset + header length + @_ + ); + $self->{'externalFileName'} = $externalFileName; + $self->{'fh'} = $fh; + $self->{'possibleEocdOffset'} = $possibleEocdOffset; + return $self; +} + +sub isDirectory { + my $self = shift; + return (substr($self->fileName, -1, 1) eq '/' + and $self->uncompressedSize == 0); +} + +# Seek to the beginning of the local header, just past the signature. +# Verify that the local header signature is in fact correct. +# Update the localHeaderRelativeOffset if necessary by adding the possibleEocdOffset. +# Returns status. + +sub _seekToLocalHeader { + my $self = shift; + my $where = shift; # optional + my $previousWhere = shift; # optional + + $where = $self->localHeaderRelativeOffset() unless defined($where); + + # avoid loop on certain corrupt files (from Julian Field) + return _formatError("corrupt zip file") + if defined($previousWhere) && $where == $previousWhere; + + my $status; + my $signature; + + $status = $self->fh()->seek($where, IO::Seekable::SEEK_SET); + return _ioError("seeking to local header") unless $status; + + ($status, $signature) = + _readSignature($self->fh(), $self->externalFileName(), + LOCAL_FILE_HEADER_SIGNATURE); + return $status if $status == AZ_IO_ERROR; + + # retry with EOCD offset if any was given. + if ($status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'}) { + $status = $self->_seekToLocalHeader( + $self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'}, + $where + ); + if ($status == AZ_OK) { + $self->{'localHeaderRelativeOffset'} += + $self->{'possibleEocdOffset'}; + $self->{'possibleEocdOffset'} = 0; + } + } + + return $status; +} + +# Because I'm going to delete the file handle, read the local file +# header if the file handle is seekable. If it is not, I assume that +# I've already read the local header. +# Return ( $status, $self ) + +sub _become { + my $self = shift; + my $newClass = shift; + return $self if ref($self) eq $newClass; + + my $status = AZ_OK; + + if (_isSeekable($self->fh())) { + my $here = $self->fh()->tell(); + $status = $self->_seekToLocalHeader(); + $status = $self->_readLocalFileHeader() if $status == AZ_OK; + $self->fh()->seek($here, IO::Seekable::SEEK_SET); + return $status unless $status == AZ_OK; + } + + delete($self->{'eocdCrc32'}); + delete($self->{'diskNumberStart'}); + delete($self->{'localHeaderRelativeOffset'}); + delete($self->{'dataOffset'}); + + return $self->SUPER::_become($newClass); +} + +sub diskNumberStart { + shift->{'diskNumberStart'}; +} + +sub localHeaderRelativeOffset { + shift->{'localHeaderRelativeOffset'}; +} + +sub dataOffset { + shift->{'dataOffset'}; +} + +# Skip local file header, updating only extra field stuff. +# Assumes that fh is positioned before signature. +sub _skipLocalFileHeader { + my $self = shift; + my $header; + my $bytesRead = $self->fh()->read($header, LOCAL_FILE_HEADER_LENGTH); + if ($bytesRead != LOCAL_FILE_HEADER_LENGTH) { + return _ioError("reading local file header"); + } + my $fileNameLength; + my $extraFieldLength; + my $bitFlag; + ( + undef, # $self->{'versionNeededToExtract'}, + $bitFlag, + undef, # $self->{'compressionMethod'}, + undef, # $self->{'lastModFileDateTime'}, + undef, # $crc32, + undef, # $compressedSize, + undef, # $uncompressedSize, + $fileNameLength, + $extraFieldLength + ) = unpack(LOCAL_FILE_HEADER_FORMAT, $header); + + if ($fileNameLength) { + $self->fh()->seek($fileNameLength, IO::Seekable::SEEK_CUR) + or return _ioError("skipping local file name"); + } + + if ($extraFieldLength) { + $bytesRead = + $self->fh()->read($self->{'localExtraField'}, $extraFieldLength); + if ($bytesRead != $extraFieldLength) { + return _ioError("reading local extra field"); + } + } + + $self->{'dataOffset'} = $self->fh()->tell(); + + if ($bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK) { + + # Read the crc32, compressedSize, and uncompressedSize from the + # extended data descriptor, which directly follows the compressed data. + # + # Skip over the compressed file data (assumes that EOCD compressedSize + # was correct) + $self->fh()->seek($self->{'compressedSize'}, IO::Seekable::SEEK_CUR) + or return _ioError("seeking to extended local header"); + + # these values should be set correctly from before. + my $oldCrc32 = $self->{'eocdCrc32'}; + my $oldCompressedSize = $self->{'compressedSize'}; + my $oldUncompressedSize = $self->{'uncompressedSize'}; + + my $status = $self->_readDataDescriptor(); + return $status unless $status == AZ_OK; + + # The buffer withe encrypted data is prefixed with a new + # encrypted 12 byte header. The size only changes when + # the buffer is also compressed + $self->isEncrypted && $oldUncompressedSize > $self->{uncompressedSize} + and $oldUncompressedSize -= DATA_DESCRIPTOR_LENGTH; + + return _formatError( + "CRC or size mismatch while skipping data descriptor") + if ( $oldCrc32 != $self->{'crc32'} + || $oldUncompressedSize != $self->{'uncompressedSize'}); + + $self->{'crc32'} = 0 + if $self->compressionMethod() == COMPRESSION_STORED ; + } + + return AZ_OK; +} + +# Read from a local file header into myself. Returns AZ_OK if successful. +# Assumes that fh is positioned after signature. +# Note that crc32, compressedSize, and uncompressedSize will be 0 if +# GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag. + +sub _readLocalFileHeader { + my $self = shift; + my $header; + my $bytesRead = $self->fh()->read($header, LOCAL_FILE_HEADER_LENGTH); + if ($bytesRead != LOCAL_FILE_HEADER_LENGTH) { + return _ioError("reading local file header"); + } + my $fileNameLength; + my $crc32; + my $compressedSize; + my $uncompressedSize; + my $extraFieldLength; + ( + $self->{'versionNeededToExtract'}, $self->{'bitFlag'}, + $self->{'compressionMethod'}, $self->{'lastModFileDateTime'}, + $crc32, $compressedSize, + $uncompressedSize, $fileNameLength, + $extraFieldLength + ) = unpack(LOCAL_FILE_HEADER_FORMAT, $header); + + if ($fileNameLength) { + my $fileName; + $bytesRead = $self->fh()->read($fileName, $fileNameLength); + if ($bytesRead != $fileNameLength) { + return _ioError("reading local file name"); + } + $self->fileName($fileName); + } + + if ($extraFieldLength) { + $bytesRead = + $self->fh()->read($self->{'localExtraField'}, $extraFieldLength); + if ($bytesRead != $extraFieldLength) { + return _ioError("reading local extra field"); + } + } + + $self->{'dataOffset'} = $self->fh()->tell(); + + if ($self->hasDataDescriptor()) { + + # Read the crc32, compressedSize, and uncompressedSize from the + # extended data descriptor. + # Skip over the compressed file data (assumes that EOCD compressedSize + # was correct) + $self->fh()->seek($self->{'compressedSize'}, IO::Seekable::SEEK_CUR) + or return _ioError("seeking to extended local header"); + + my $status = $self->_readDataDescriptor(); + return $status unless $status == AZ_OK; + } else { + return _formatError( + "CRC or size mismatch after reading data descriptor") + if ( $self->{'crc32'} != $crc32 + || $self->{'uncompressedSize'} != $uncompressedSize); + } + + return AZ_OK; +} + +# This will read the data descriptor, which is after the end of compressed file +# data in members that have GPBF_HAS_DATA_DESCRIPTOR_MASK set in their bitFlag. +# The only reliable way to find these is to rely on the EOCD compressedSize. +# Assumes that file is positioned immediately after the compressed data. +# Returns status; sets crc32, compressedSize, and uncompressedSize. +sub _readDataDescriptor { + my $self = shift; + my $signatureData; + my $header; + my $crc32; + my $compressedSize; + my $uncompressedSize; + + my $bytesRead = $self->fh()->read($signatureData, SIGNATURE_LENGTH); + return _ioError("reading header signature") + if $bytesRead != SIGNATURE_LENGTH; + my $signature = unpack(SIGNATURE_FORMAT, $signatureData); + + # unfortunately, the signature appears to be optional. + if ($signature == DATA_DESCRIPTOR_SIGNATURE + && ($signature != $self->{'crc32'})) { + $bytesRead = $self->fh()->read($header, DATA_DESCRIPTOR_LENGTH); + return _ioError("reading data descriptor") + if $bytesRead != DATA_DESCRIPTOR_LENGTH; + + ($crc32, $compressedSize, $uncompressedSize) = + unpack(DATA_DESCRIPTOR_FORMAT, $header); + } else { + $bytesRead = $self->fh()->read($header, DATA_DESCRIPTOR_LENGTH_NO_SIG); + return _ioError("reading data descriptor") + if $bytesRead != DATA_DESCRIPTOR_LENGTH_NO_SIG; + + $crc32 = $signature; + ($compressedSize, $uncompressedSize) = + unpack(DATA_DESCRIPTOR_FORMAT_NO_SIG, $header); + } + + $self->{'eocdCrc32'} = $self->{'crc32'} + unless defined($self->{'eocdCrc32'}); + $self->{'crc32'} = $crc32; + $self->{'compressedSize'} = $compressedSize; + $self->{'uncompressedSize'} = $uncompressedSize; + + return AZ_OK; +} + +# Read a Central Directory header. Return AZ_OK on success. +# Assumes that fh is positioned right after the signature. + +sub _readCentralDirectoryFileHeader { + my $self = shift; + my $fh = $self->fh(); + my $header = ''; + my $bytesRead = $fh->read($header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH); + if ($bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH) { + return _ioError("reading central dir header"); + } + my ($fileNameLength, $extraFieldLength, $fileCommentLength); + ( + $self->{'versionMadeBy'}, + $self->{'fileAttributeFormat'}, + $self->{'versionNeededToExtract'}, + $self->{'bitFlag'}, + $self->{'compressionMethod'}, + $self->{'lastModFileDateTime'}, + $self->{'crc32'}, + $self->{'compressedSize'}, + $self->{'uncompressedSize'}, + $fileNameLength, + $extraFieldLength, + $fileCommentLength, + $self->{'diskNumberStart'}, + $self->{'internalFileAttributes'}, + $self->{'externalFileAttributes'}, + $self->{'localHeaderRelativeOffset'} + ) = unpack(CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header); + + $self->{'eocdCrc32'} = $self->{'crc32'}; + + if ($fileNameLength) { + $bytesRead = $fh->read($self->{'fileName'}, $fileNameLength); + if ($bytesRead != $fileNameLength) { + _ioError("reading central dir filename"); + } + } + if ($extraFieldLength) { + $bytesRead = $fh->read($self->{'cdExtraField'}, $extraFieldLength); + if ($bytesRead != $extraFieldLength) { + return _ioError("reading central dir extra field"); + } + } + if ($fileCommentLength) { + $bytesRead = $fh->read($self->{'fileComment'}, $fileCommentLength); + if ($bytesRead != $fileCommentLength) { + return _ioError("reading central dir file comment"); + } + } + + # NK 10/21/04: added to avoid problems with manipulated headers + if ( $self->{'uncompressedSize'} != $self->{'compressedSize'} + and $self->{'compressionMethod'} == COMPRESSION_STORED) { + $self->{'uncompressedSize'} = $self->{'compressedSize'}; + } + + $self->desiredCompressionMethod($self->compressionMethod()); + + return AZ_OK; +} + +sub rewindData { + my $self = shift; + + my $status = $self->SUPER::rewindData(@_); + return $status unless $status == AZ_OK; + + return AZ_IO_ERROR unless $self->fh(); + + $self->fh()->clearerr(); + + # Seek to local file header. + # The only reason that I'm doing this this way is that the extraField + # length seems to be different between the CD header and the LF header. + $status = $self->_seekToLocalHeader(); + return $status unless $status == AZ_OK; + + # skip local file header + $status = $self->_skipLocalFileHeader(); + return $status unless $status == AZ_OK; + + # Seek to beginning of file data + $self->fh()->seek($self->dataOffset(), IO::Seekable::SEEK_SET) + or return _ioError("seeking to beginning of file data"); + + return AZ_OK; +} + +# Return bytes read. Note that first parameter is a ref to a buffer. +# my $data; +# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); +sub _readRawChunk { + my ($self, $dataRef, $chunkSize) = @_; + return (0, AZ_OK) unless $chunkSize; + my $bytesRead = $self->fh()->read($$dataRef, $chunkSize) + or return (0, _ioError("reading data")); + return ($bytesRead, AZ_OK); +} + +1; diff --git a/pom.xml b/pom.xml index eaa6e5872f2..44bce833776 100644 --- a/pom.xml +++ b/pom.xml @@ -716,8 +716,8 @@ false ${skip.integ.tests} - @@ -1130,7 +1130,8 @@ org.eclipse.jdt.ui.text.custom_code_templates= - + +