Merge pull request #12377 from clintongormley/license_check_all_packages

Refactored check_license_and_sha.pl to accept a license dir and package path
This commit is contained in:
Clinton Gormley 2015-07-21 19:54:21 +02:00
commit aeb0ca0aef
17 changed files with 8661 additions and 68 deletions

View File

@ -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 <dir> 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
}

View File

@ -0,0 +1,806 @@
###########################################################
# Archive::Ar - Pure perl module to handle ar achives
#
# Copyright 2003 - Jay Bonci <jaybonci@cpan.org>
# Copyright 2014 - John Bazik <jbazik@cpan.org>
# 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 => "!<arch>\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<stat()>.
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 E<lt>jbazik@cpan.orgE<gt>.
Copyright 2003 Jay Bonci E<lt>jaybonci@cpan.orgE<gt>.
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

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -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;

View File

@ -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;

View File

@ -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<did> 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<Q:> Archive::Zip won't install on my RedHat 9 system! It's broke!
B<A:> 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<LANG=C>
L<https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
=head1 Why is my zip file so big?
B<Q:> My zip file is actually bigger than what I stored in it! Why?
B<A:> 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<Q:> Can you send me code to do (whatever)?
B<A:> Have you looked in the C<examples/> 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<Q:> Why can't I open a Zip file, add a member, and write it back? I get an
error message when I try.
B<A:> 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<overwrite()> and
C<overwriteAs()> to do this simply and carefully.
See C<examples/updateZip.pl> for an example of this technique.
=head1 File creation time not set
B<Q:> 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<A:> Mostly because Perl doesn't give cross-platform access to I<creation time>.
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<lastModTime()>.
=head1 Can't use Archive::Zip on gzip files
B<Q:> Can I use Archive::Zip to extract Unix gzip files?
B<A:> 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<Compress::Raw::Zlib>, or
L<Archive::Tar> 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<Q:> How can I add a directory (or tree) full of files to a Zip?
B<A:> 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<Q:> How can I extract some (or all) files from a Zip into a different
directory?
B<A:> 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<Q:> How can I update a Zip from a directory tree, adding or replacing only
the newer files?
B<A:> 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<Q:> 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<A:> 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<Q:> My file times don't respect time zones. What gives?
B<A:> 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<Q:> I want to make a self-extracting Zip file. Can I do this?
B<A:> 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<Q:> How can I tell if a Zip has been damaged by adding garbage to the
beginning or inside the file?
B<A:> 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<Q:> 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<A:> 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<Q:> How do I decrypt encrypted Zip members?
B<A:> With some other program or library. Archive::Zip doesn't support decryption,
and probably never will (unless I<you> write it).
=head1 How to test file integrity?
B<Q:> How can Archive::Zip can test the validity of a Zip file?
B<A:> 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<Q:> Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this?
B<A:> 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<Q:> Why doesn't Archive::Zip deal with file ownership, ACLs, etc.?
B<A:> 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<Q:> 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<A:> 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<Q:> How come my JPEGs and MP3's don't compress much when I put them into Zips?
B<A:> Because they're already compressed.
=head1 Under Windows, things lock up/get damaged
B<Q:> 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<A:> 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<Q:> 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<A:> Use C<IO::String> and the C<readFromFileHandle()> and
C<writeToFileHandle()> methods.
See C<examples/readScalar.pl> and C<examples/writeScalar.pl>.
=head1 Reading from streams
B<Q:> How do I read from a stream (like for the Info-Zip C<funzip> program)?
B<A:> This is not currently supported, though writing to a stream is.

View File

@ -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;

File diff suppressed because it is too large Load Diff

View File

@ -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<Archive::Zip::MemberRead> from an archive member by
calling C<readFileHandle()>:
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<Archive::Zip::MemberRead>->C<setLineEnd($nl)>
=cut
sub setLineEnd {
shift;
$nl = shift;
}
=item rewind()
Rewinds an C<Archive::Zip::MemberRead> 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<getline()>.
Using C<read()> 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<read()> system call.
Returns the no. of bytes read. C<undef> on error, 0 on eof, I<e.g.>:
$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 E<lt>sreeji_k@yahoo.comE<gt>
See L<Archive::Zip> 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

View File

@ -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;

View File

@ -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;

View File

@ -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;

View File

@ -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<Archive::Zip>.
=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<Archive::Zip>
=cut

View File

@ -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;

View File

@ -716,8 +716,8 @@
<haltOnFailure>false</haltOnFailure>
<skipTests>${skip.integ.tests}</skipTests>
<listeners>
<report-ant-xml
mavenExtensions="true"
<report-ant-xml
mavenExtensions="true"
summaryFile="${project.build.directory}/failsafe-reports/failsafe-summary.xml"
dir="${project.build.directory}/failsafe-reports"/>
</listeners>
@ -1130,7 +1130,8 @@ org.eclipse.jdt.ui.text.custom_code_templates=<?xml version\="1.0" encoding\="UT
<exec failonerror="${licenses.exists}" executable="perl" dir="${elasticsearch.tools.directory}/license-check" osfamily="unix" >
<arg value="check_license_and_sha.pl"/>
<arg value="--check"/>
<arg value="${basedir}"/>
<arg value="${basedir}/licenses"/>
<arg value="${basedir}/target/releases/${project.build.finalName}.zip"/>
</exec>
</target>
</configuration>