KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

257
database/perl/lib/Archive/Any/Lite.pm Normal file
View File

@@ -0,0 +1,257 @@
package Archive::Any::Lite;
use strict;
use warnings;
use File::Spec;
our $VERSION = '0.11';
our $IGNORE_SYMLINK;
sub new {
my ($class, $file, $opts) = @_;
$file = File::Spec->rel2abs($file);
unless (-f $file) {
warn "$file not found\n";
return;
}
# just for undocumented backward compat
my $type = !ref $opts ? $opts : '';
# XXX: trust file extensions until I manage to make File::MMagic
# more reliable while fork()ing or I happen to find a decent
# and portable alternative to File::MMagic.
my $handler =
($type && lc $type eq 'tar') || $file =~ /\.(?:tar|tar\.(?:gz|bz2)|gtar|tgz)$/ ? 'Archive::Any::Lite::Tar' :
($type && lc $type eq 'zip') || $file =~ /\.(?:zip)$/ ? 'Archive::Any::Lite::Zip' : undef;
unless ($handler) {
warn "No handler available for $file\n";
return;
}
bless {
file => $file,
handler => $handler,
opts => ref $opts ? $opts : undef,
}, $class;
}
sub extract {
my ($self, $dir, $opts) = @_;
$self->{handler}->extract($self->{file}, $dir, $opts || $self->{opts});
}
sub files {
my $self = shift;
$self->{handler}->files($self->{file});
}
sub is_impolite {
my $self = shift;
my @files = $self->files;
my $first_file = $files[0];
my ($first_dir) = File::Spec->splitdir($first_file);
return grep( !/^\Q$first_dir\E/, @files ) ? 1 : 0;
}
sub is_naughty {
my ($self) = shift;
return ( grep { m{^(?:/|(?:\./)*\.\./)} } $self->files ) ? 1 : 0;
}
sub type {
my $self = shift;
my ($type) = lc $self->{handler} =~ /::(\w+)$/;
return $type;
}
package Archive::Any::Lite::Tar;
use Archive::Tar;
sub files {
my ($self, $file) = @_;
Archive::Tar->list_archive($file);
}
sub extract {
my ($self, $file, $dir, $opts) = @_;
$dir = '.' unless defined $dir;
$dir = File::Spec->rel2abs($dir);
my $tar = Archive::Tar->new;
my $fh;
if ($file =~ /\.(tgz|tar\.gz)$/) {
require IO::Zlib;
$fh = IO::Zlib->new($file, "rb") or do { warn "$file: $!"; return };
}
elsif ($file =~ /\.tar.bz2$/) {
require IO::Uncompress::Bunzip2;
$fh = IO::Uncompress::Bunzip2->new($file) or do { warn "$file: $!"; return };
}
else {
open $fh, '<', $file or do { warn "$file: $!"; return };
binmode $fh;
}
# Archive::Tar is too noisy when an archive has minor glitches.
# Note also that $file can't hold the last error.
local $Archive::Tar::WARN;
my %errors;
my $has_extracted;
my %read_opts = (limit => 1);
if ($opts) {
for (qw/limit md5 filter filter_cb extract/) {
if (exists $opts->{"tar_$_"}) {
$read_opts{$_} = $opts->{"tar_$_"};
}
elsif (exists $opts->{$_}) {
$read_opts{$_} = $opts->{$_};
}
}
}
until (eof $fh) {
my @files = $tar->read($fh, undef, \%read_opts);
if (my $error = $tar->error) {
warn $error unless $errors{$error}++;
}
if (!@files && !$has_extracted) {
warn "No data could be read from $file";
return;
}
for my $file (@files) {
next if $IGNORE_SYMLINK && ($file->is_symlink or $file->is_hardlink);
my $path = File::Spec->catfile($dir, $file->prefix, $file->name);
$tar->extract_file($file, File::Spec->canonpath($path)) or do {
if (my $error = $tar->error) {
warn $error unless $errors{$error}++;
}
};
}
$has_extracted += @files;
}
return if %errors;
return 1;
}
sub type { 'tar' }
package Archive::Any::Lite::Zip;
use Archive::Zip qw/:ERROR_CODES/;
sub files {
my ($self, $file) = @_;
my $zip = Archive::Zip->new($file) or return;
$zip->memberNames;
}
sub extract {
my ($self, $file, $dir, $opts) = @_;
my $zip = Archive::Zip->new($file) or return;
$dir = '.' unless defined $dir;
my $error = 0;
for my $member ($zip->members) {
next if $IGNORE_SYMLINK && $member->isSymbolicLink;
my $path = File::Spec->catfile($dir, $member->fileName);
my $ret = $member->extractToFileNamed(File::Spec->canonpath($path));
$error++ if $ret != AZ_OK;
}
return if $error;
return 1;
}
sub type { 'zip' }
1;
__END__
=head1 NAME
Archive::Any::Lite - simple CPAN package extractor
=head1 SYNOPSIS
use strict;
use warnings;
use Archive::Any::Lite;
local $Archive::Any::Lite::IGNORE_SYMLINK = 1; # for safety
my $tarball = 'foo.tar.gz';
my $archive = Archive::Any::Lite->new($tarball);
$archive->extract('into/some/directory/');
=head1 DESCRIPTION
This is a fork of L<Archive::Any> by Michael Schwern and Clint Moore. The main difference is this works properly even when you fork(), and may require less memory to extract a tarball. On the other hand, this isn't pluggable (this only supports file formats used in the CPAN toolchains), and this doesn't check mime types (at least as of this writing).
=head1 METHODS
=head2 new
my $archive = Archive::Any::Lite->new($archive_file);
my $archive = Archive::Any::Lite->new($archive_file, {tar_filter => qr/foo/});
Creates an object.
You can pass an optional hash reference for finer control.
=head2 extract
$archive->extract;
$archive->extract($directory);
$archive->extract($directory, {tar_filter => qr/foo/});
Extracts the files in the archive to the given $directory. If no $directory is given, it will go into the current working directory.
You can pass an optional hash reference for finer control. If passed, options passed in C<new> will be ignored.
=head2 files
my @file = $archive->files;
A list of files in the archive.
=head2 is_impolite
my $is_impolite = $archive->is_impolite;
Checks to see if this archive is going to unpack into the current directory rather than create its own.
=head2 is_naughty
my $is_naughty = $archive->is_naughty;
Checks to see if this archive is going to unpack outside the current directory.
=head2 type
Deprecated. For backward compatibility only.
=head1 GLOBAL VARIABLE
=head2 $IGNORE_SYMLINK
If set to true, symlinks (and hardlinks for tarball) will be ignored.
=head1 SEE ALSO
L<Archive::Any>, L<Archive::Tar::Streamed>
=head1 AUTHOR
L<Archive::Any> is written by Michael G Schwern and Clint Moore.
Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2012 by Kenichi Ishigaki.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

2437
database/perl/lib/Archive/Tar.pm Normal file
View File

File diff suppressed because it is too large Load Diff

124
database/perl/lib/Archive/Tar/Constant.pm Normal file
View File

@@ -0,0 +1,124 @@
package Archive::Tar::Constant;
use strict;
use warnings;
use vars qw[$VERSION @ISA @EXPORT];
BEGIN {
require Exporter;
$VERSION = '2.38';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
}
@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
use constant FILE => 0;
use constant HARDLINK => 1;
use constant SYMLINK => 2;
use constant CHARDEV => 3;
use constant BLOCKDEV => 4;
use constant DIR => 5;
use constant FIFO => 6;
use constant SOCKET => 8;
use constant UNKNOWN => 9;
use constant LONGLINK => 'L';
use constant LABEL => 'V';
use constant BUFFER => 4096;
use constant HEAD => 512;
use constant BLOCK => 512;
use constant COMPRESS_GZIP => 9;
use constant COMPRESS_BZIP => 'bzip2';
use constant COMPRESS_XZ => 'xz';
use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
use constant TAR_END => "\0" x BLOCK;
use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
# Pointless assignment to make -w shut up
my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
use constant UID => $>;
use constant GID => (split ' ', $) )[0];
use constant MODE => do { 0666 & (0777 & ~umask) };
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
use constant PREFIX_LENGTH => 155;
use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,1970) : 0;
use constant MAGIC => "ustar";
use constant TAR_VERSION => "00";
use constant LONGLINK_NAME => '././@LongLink';
use constant PAX_HEADER => 'pax_global_header';
### allow ZLIB to be turned off using ENV: DEBUG only
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
eval { require IO::Zlib };
$ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
};
### allow BZIP to be turned off using ENV: DEBUG only
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
eval { require IO::Uncompress::Bunzip2;
require IO::Compress::Bzip2; };
$ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
};
### allow XZ to be turned off using ENV: DEBUG only
use constant XZ => do { !$ENV{'PERL5_AT_NO_XZ'} and
eval { require IO::Compress::Xz;
require IO::Uncompress::UnXz; };
$ENV{'PERL5_AT_NO_XZ'} || $@ ? 0 : 1
};
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
use constant XZ_MAGIC_NUM => qr/^\xFD\x37\x7A\x58\x5A\x00/;
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
use constant ON_VMS => $^O eq 'VMS';
sub _list_consts {
my $class = shift;
my $pkg = shift;
return unless defined $pkg; # some joker might use '0' as a pkg...
my @rv;
{ no strict 'refs';
my $stash = $pkg . '::';
for my $name (sort keys %$stash ) {
### is it a subentry?
my $sub = $pkg->can( $name );
next unless defined $sub;
next unless defined prototype($sub) and
not length prototype($sub);
push @rv, $name;
}
}
return sort @rv;
}
1;

716
database/perl/lib/Archive/Tar/File.pm Normal file
View File

@@ -0,0 +1,716 @@
package Archive::Tar::File;
use strict;
use Carp ();
use IO::File;
use File::Spec::Unix ();
use File::Spec ();
use File::Basename ();
use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
$VERSION = '2.38';
### set value to 1 to oct() it during the unpack ###
my $tmpl = [
name => 0, # string A100
mode => 1, # octal A8
uid => 1, # octal A8
gid => 1, # octal A8
size => 0, # octal # cdrake - not *always* octal.. A12
mtime => 1, # octal A12
chksum => 1, # octal A8
type => 0, # character A1
linkname => 0, # string A100
magic => 0, # string A6
version => 0, # 2 bytes A2
uname => 0, # string A32
gname => 0, # string A32
devmajor => 1, # octal A8
devminor => 1, # octal A8
prefix => 0, # A155 x 12
### end UNPACK items ###
raw => 0, # the raw data chunk
data => 0, # the data associated with the file --
# This might be very memory intensive
];
### install get/set accessors for this object.
for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
my $key = $tmpl->[$i];
no strict 'refs';
*{__PACKAGE__."::$key"} = sub {
my $self = shift;
$self->{$key} = $_[0] if @_;
### just in case the key is not there or undef or something ###
{ local $^W = 0;
return $self->{$key};
}
}
}
=head1 NAME
Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
=head1 SYNOPSIS
my @items = $tar->get_files;
print $_->name, ' ', $_->size, "\n" for @items;
print $object->get_content;
$object->replace_content('new content');
$object->rename( 'new/full/path/to/file.c' );
=head1 DESCRIPTION
Archive::Tar::Files provides a neat little object layer for in-memory
extracted files. It's mostly used internally in Archive::Tar to tidy
up the code, but there's no reason users shouldn't use this API as
well.
=head2 Accessors
A lot of the methods in this package are accessors to the various
fields in the tar header:
=over 4
=item name
The file's name
=item mode
The file's mode
=item uid
The user id owning the file
=item gid
The group id owning the file
=item size
File size in bytes
=item mtime
Modification time. Adjusted to mac-time on MacOS if required
=item chksum
Checksum field for the tar header
=item type
File type -- numeric, but comparable to exported constants -- see
Archive::Tar's documentation
=item linkname
If the file is a symlink, the file it's pointing to
=item magic
Tar magic string -- not useful for most users
=item version
Tar version string -- not useful for most users
=item uname
The user name that owns the file
=item gname
The group name that owns the file
=item devmajor
Device major number in case of a special file
=item devminor
Device minor number in case of a special file
=item prefix
Any directory to prefix to the extraction path, if any
=item raw
Raw tar header -- not useful for most users
=back
=head1 Methods
=head2 Archive::Tar::File->new( file => $path )
Returns a new Archive::Tar::File object from an existing file.
Returns undef on failure.
=head2 Archive::Tar::File->new( data => $path, $data, $opt )
Returns a new Archive::Tar::File object from data.
C<$path> defines the file name (which need not exist), C<$data> the
file contents, and C<$opt> is a reference to a hash of attributes
which may be used to override the default attributes (fields in the
tar header), which are described above in the Accessors section.
Returns undef on failure.
=head2 Archive::Tar::File->new( chunk => $chunk )
Returns a new Archive::Tar::File object from a raw 512-byte tar
archive chunk.
Returns undef on failure.
=cut
sub new {
my $class = shift;
my $what = shift;
my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
undef;
return $obj;
}
### copies the data, creates a clone ###
sub clone {
my $self = shift;
return bless { %$self }, ref $self;
}
sub _new_from_chunk {
my $class = shift;
my $chunk = shift or return; # 512 bytes of tar header
my %hash = @_;
### filter any arguments on defined-ness of values.
### this allows overriding from what the tar-header is saying
### about this tar-entry. Particularly useful for @LongLink files
my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
### makes it start at 0 actually... :) ###
my $i = -1;
my %entry = map {
my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
$s=> $v ? oct $_ : $_ # cdrake
# $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
} unpack( UNPACK, $chunk ); # cdrake
# } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
} else { # cdrake
($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
} # cdrake
my $obj = bless { %entry, %args }, $class;
### magic is a filetype string.. it should have something like 'ustar' or
### something similar... if the chunk is garbage, skip it
return unless $obj->magic !~ /\W/;
### store the original chunk ###
$obj->raw( $chunk );
$obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
$obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
return $obj;
}
sub _new_from_file {
my $class = shift;
my $path = shift;
### path has to at least exist
return unless defined $path;
my $type = __PACKAGE__->_filetype($path);
my $data = '';
READ: {
unless ($type == DIR ) {
my $fh = IO::File->new;
unless( $fh->open($path) ) {
### dangling symlinks are fine, stop reading but continue
### creating the object
last READ if $type == SYMLINK;
### otherwise, return from this function --
### anything that's *not* a symlink should be
### resolvable
return;
}
### binmode needed to read files properly on win32 ###
binmode $fh;
$data = do { local $/; <$fh> };
close $fh;
}
}
my @items = qw[mode uid gid size mtime];
my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
if (ON_VMS) {
### VMS has two UID modes, traditional and POSIX. Normally POSIX is
### not used. We currently do not have an easy way to see if we are in
### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
### The VMS UIC has the upper 16 bits is the GID, which in many cases
### the VMS UIC will be larger than 209715, the largest that TAR can
### handle. So for now, assume it is traditional if the UID is larger
### than 0x10000.
if ($hash{uid} > 0x10000) {
$hash{uid} = $hash{uid} & 0xFFFF;
}
### The file length from stat() is the physical length of the file
### However the amount of data read in may be more for some file types.
### Fixed length files are read past the logical EOF to end of the block
### containing. Other file types get expanded on read because record
### delimiters are added.
my $data_len = length $data;
$hash{size} = $data_len if $hash{size} < $data_len;
}
### you *must* set size == 0 on symlinks, or the next entry will be
### though of as the contents of the symlink, which is wrong.
### this fixes bug #7937
$hash{size} = 0 if ($type == DIR or $type == SYMLINK);
$hash{mtime} -= TIME_OFFSET;
### strip the high bits off the mode, which we don't need to store
$hash{mode} = STRIP_MODE->( $hash{mode} );
### probably requires some file path munging here ... ###
### name and prefix are set later
my $obj = {
%hash,
name => '',
chksum => CHECK_SUM,
type => $type,
linkname => ($type == SYMLINK and CAN_READLINK)
? readlink $path
: '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( $hash{uid} ),
gname => GNAME->( $hash{gid} ),
devmajor => 0, # not handled
devminor => 0, # not handled
prefix => '',
data => $data,
};
bless $obj, $class;
### fix up the prefix and file from the path
my($prefix,$file) = $obj->_prefix_and_file( $path );
$obj->prefix( $prefix );
$obj->name( $file );
return $obj;
}
sub _new_from_data {
my $class = shift;
my $path = shift; return unless defined $path;
my $data = shift; return unless defined $data;
my $opt = shift;
my $obj = {
data => $data,
name => '',
mode => MODE,
uid => UID,
gid => GID,
size => length $data,
mtime => time - TIME_OFFSET,
chksum => CHECK_SUM,
type => FILE,
linkname => '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( UID ),
gname => GNAME->( GID ),
devminor => 0,
devmajor => 0,
prefix => '',
};
### overwrite with user options, if provided ###
if( $opt and ref $opt eq 'HASH' ) {
for my $key ( keys %$opt ) {
### don't write bogus options ###
next unless exists $obj->{$key};
$obj->{$key} = $opt->{$key};
}
}
bless $obj, $class;
### fix up the prefix and file from the path
my($prefix,$file) = $obj->_prefix_and_file( $path );
$obj->prefix( $prefix );
$obj->name( $file );
return $obj;
}
sub _prefix_and_file {
my $self = shift;
my $path = shift;
my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
### if it's a directory, then $file might be empty
$file = pop @dirs if $self->is_dir and not length $file;
### splitting ../ gives you the relative path in native syntax
### Remove the root (000000) directory
### The volume from splitpath will also be in native syntax
if (ON_VMS) {
map { $_ = '..' if $_ eq '-'; $_ = '' if $_ eq '000000' } @dirs;
if (length($vol)) {
$vol = VMS::Filespec::unixify($vol);
unshift @dirs, $vol;
}
}
my $prefix = File::Spec::Unix->catdir(@dirs);
return( $prefix, $file );
}
sub _filetype {
my $self = shift;
my $file = shift;
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
return FILE if (-f _); # Plain file
return DIR if (-d _); # Directory
return FIFO if (-p _); # Named pipe
return SOCKET if (-S _); # Socket
return BLOCKDEV if (-b _); # Block special
return CHARDEV if (-c _); # Character special
### shouldn't happen, this is when making archives, not reading ###
return LONGLINK if ( $file eq LONGLINK_NAME );
return UNKNOWN; # Something else (like what?)
}
### this method 'downgrades' a file to plain file -- this is used for
### symlinks when FOLLOW_SYMLINKS is true.
sub _downgrade_to_plainfile {
my $entry = shift;
$entry->type( FILE );
$entry->mode( MODE );
$entry->linkname('');
return 1;
}
=head2 $bool = $file->extract( [ $alternative_name ] )
Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
Returns true on success and false on failure.
=cut
sub extract {
my $self = shift;
local $Carp::CarpLevel += 1;
### avoid circular use, so only require;
require Archive::Tar;
return Archive::Tar->_extract_file( $self, @_ );
}
=head2 $path = $file->full_path
Returns the full path from the tar header; this is basically a
concatenation of the C<prefix> and C<name> fields.
=cut
sub full_path {
my $self = shift;
### if prefix field is empty
return $self->name unless defined $self->prefix and length $self->prefix;
### or otherwise, catfile'd
return File::Spec::Unix->catfile( $self->prefix, $self->name );
}
=head2 $bool = $file->validate
Done by Archive::Tar internally when reading the tar file:
validate the header against the checksum to ensure integer tar file.
Returns true on success, false on failure
=cut
sub validate {
my $self = shift;
my $raw = $self->raw;
### don't know why this one is different from the one we /write/ ###
substr ($raw, 148, 8) = " ";
### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
### like GNU tar does. See here for details:
### http://www.gnu.org/software/tar/manual/tar.html#SEC139
### so we do both a signed AND unsigned validate. if one succeeds, that's
### good enough
return ( (unpack ("%16C*", $raw) == $self->chksum)
or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
}
=head2 $bool = $file->has_content
Returns a boolean to indicate whether the current object has content.
Some special files like directories and so on never will have any
content. This method is mainly to make sure you don't get warnings
for using uninitialized values when looking at an object's content.
=cut
sub has_content {
my $self = shift;
return defined $self->data() && length $self->data() ? 1 : 0;
}
=head2 $content = $file->get_content
Returns the current content for the in-memory file
=cut
sub get_content {
my $self = shift;
$self->data( );
}
=head2 $cref = $file->get_content_by_ref
Returns the current content for the in-memory file as a scalar
reference. Normal users won't need this, but it will save memory if
you are dealing with very large data files in your tar archive, since
it will pass the contents by reference, rather than make a copy of it
first.
=cut
sub get_content_by_ref {
my $self = shift;
return \$self->{data};
}
=head2 $bool = $file->replace_content( $content )
Replace the current content of the file with the new content. This
only affects the in-memory archive, not the on-disk version until
you write it.
Returns true on success, false on failure.
=cut
sub replace_content {
my $self = shift;
my $data = shift || '';
$self->data( $data );
$self->size( length $data );
return 1;
}
=head2 $bool = $file->rename( $new_name )
Rename the current file to $new_name.
Note that you must specify a Unix path for $new_name, since per tar
standard, all files in the archive must be Unix paths.
Returns true on success and false on failure.
=cut
sub rename {
my $self = shift;
my $path = shift;
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
$self->name( $file );
$self->prefix( $prefix );
return 1;
}
=head2 $bool = $file->chmod $mode)
Change mode of $file to $mode. The mode can be a string or a number
which is interpreted as octal whether or not a leading 0 is given.
Returns true on success and false on failure.
=cut
sub chmod {
my $self = shift;
my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
$self->{mode} = oct($mode);
return 1;
}
=head2 $bool = $file->chown( $user [, $group])
Change owner of $file to $user. If a $group is given that is changed
as well. You can also pass a single parameter with a colon separating the
use and group as in 'root:wheel'.
Returns true on success and false on failure.
=cut
sub chown {
my $self = shift;
my $uname = shift;
return unless defined $uname;
my $gname;
if (-1 != index($uname, ':')) {
($uname, $gname) = split(/:/, $uname);
} else {
$gname = shift if @_ > 0;
}
$self->uname( $uname );
$self->gname( $gname ) if $gname;
return 1;
}
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can
use the following methods:
=over 4
=item $file->is_file
Returns true if the file is of type C<file>
=item $file->is_dir
Returns true if the file is of type C<dir>
=item $file->is_hardlink
Returns true if the file is of type C<hardlink>
=item $file->is_symlink
Returns true if the file is of type C<symlink>
=item $file->is_chardev
Returns true if the file is of type C<chardev>
=item $file->is_blockdev
Returns true if the file is of type C<blockdev>
=item $file->is_fifo
Returns true if the file is of type C<fifo>
=item $file->is_socket
Returns true if the file is of type C<socket>
=item $file->is_longlink
Returns true if the file is of type C<LongLink>.
Should not happen after a successful C<read>.
=item $file->is_label
Returns true if the file is of type C<Label>.
Should not happen after a successful C<read>.
=item $file->is_unknown
Returns true if the file type is C<unknown>
=back
=cut
#stupid perl5.5.3 needs to warn if it's not numeric
sub is_file { local $^W; FILE == $_[0]->type }
sub is_dir { local $^W; DIR == $_[0]->type }
sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
sub is_symlink { local $^W; SYMLINK == $_[0]->type }
sub is_chardev { local $^W; CHARDEV == $_[0]->type }
sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
sub is_fifo { local $^W; FIFO == $_[0]->type }
sub is_socket { local $^W; SOCKET == $_[0]->type }
sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
sub is_label { local $^W; LABEL eq $_[0]->type }
1;

2322
database/perl/lib/Archive/Zip.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1392
database/perl/lib/Archive/Zip/Archive.pm Normal file
View File

File diff suppressed because it is too large Load Diff

131
database/perl/lib/Archive/Zip/BufferedFileHandle.pm Normal file
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.68';
$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;

80
database/perl/lib/Archive/Zip/DirectoryMember.pm Normal file
View File

@@ -0,0 +1,80 @@
package Archive::Zip::DirectoryMember;
use strict;
use File::Path;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@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;

344
database/perl/lib/Archive/Zip/FAQ.pod Normal file
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.

64
database/perl/lib/Archive/Zip/FileMember.pm Normal file
View File

@@ -0,0 +1,64 @@
package Archive::Zip::FileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@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;

1564
database/perl/lib/Archive/Zip/Member.pm Normal file
View File

File diff suppressed because it is too large Load Diff

348
database/perl/lib/Archive/Zip/MemberRead.pm Normal file
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.68';
$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

69
database/perl/lib/Archive/Zip/MockFileHandle.pm Normal file
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.68';
$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;

77
database/perl/lib/Archive/Zip/NewFileMember.pm Normal file
View File

@@ -0,0 +1,77 @@
package Archive::Zip::NewFileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@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;

64
database/perl/lib/Archive/Zip/StringMember.pm Normal file
View File

@@ -0,0 +1,64 @@
package Archive::Zip::StringMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@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 wantarray ? ($self->{'contents'}, AZ_OK) : $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;

48
database/perl/lib/Archive/Zip/Tree.pm Normal file
View File

@@ -0,0 +1,48 @@
package Archive::Zip::Tree;
use strict;
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.68';
}
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

475
database/perl/lib/Archive/Zip/ZipFileMember.pm Normal file
View File

@@ -0,0 +1,475 @@
package Archive::Zip::ZipFileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@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 $archiveZip64 = @_ ? shift : 0;
my $possibleEocdOffset = @_ ? shift : 0; # normally 0
my $self = $class->new(
'eocdCrc32' => 0,
'diskNumberStart' => 0,
'localHeaderRelativeOffset' => 0,
'dataOffset' => 0, # localHeaderRelativeOffset + header length
@_
);
$self->{'externalFileName'} = $externalFileName;
$self->{'fh'} = $fh;
$self->{'archiveZip64'} = $archiveZip64;
$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, 1);
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'});
delete($self->{'archiveZip64'});
delete($self->{'possibleEocdOffset'});
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");
}
my $zip64 = 0;
if ($extraFieldLength) {
$bytesRead =
$self->fh()->read($self->{'localExtraField'}, $extraFieldLength);
if ($bytesRead != $extraFieldLength) {
return _ioError("reading local extra field");
}
if ($self->{'archiveZip64'}) {
my $status;
($status, $zip64) =
$self->_extractZip64ExtraField($self->{'localExtraField'}, undef, undef);
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
$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($zip64);
return $status unless $status == AZ_OK;
# The buffer with 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 (in
# scalar context) or a pair (AZ_OK, $headerSize) (in list
# context) 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);
}
my $zip64 = 0;
if ($extraFieldLength) {
$bytesRead =
$self->fh()->read($self->{'localExtraField'}, $extraFieldLength);
if ($bytesRead != $extraFieldLength) {
return _ioError("reading local extra field");
}
if ($self->{'archiveZip64'}) {
my $status;
($status, $zip64) =
$self->_extractZip64ExtraField($self->{'localExtraField'},
$uncompressedSize,
$compressedSize);
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
$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($zip64);
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
wantarray
? (AZ_OK,
SIGNATURE_LENGTH,
LOCAL_FILE_HEADER_LENGTH +
$fileNameLength +
$extraFieldLength)
: 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 $zip64 = 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);
my $dataDescriptorLength;
my $dataDescriptorFormat;
my $dataDescriptorLengthNoSig;
my $dataDescriptorFormatNoSig;
if (! $zip64) {
$dataDescriptorLength = DATA_DESCRIPTOR_LENGTH;
$dataDescriptorFormat = DATA_DESCRIPTOR_FORMAT;
$dataDescriptorLengthNoSig = DATA_DESCRIPTOR_LENGTH_NO_SIG;
$dataDescriptorFormatNoSig = DATA_DESCRIPTOR_FORMAT_NO_SIG
}
else {
$dataDescriptorLength = DATA_DESCRIPTOR_ZIP64_LENGTH;
$dataDescriptorFormat = DATA_DESCRIPTOR_ZIP64_FORMAT;
$dataDescriptorLengthNoSig = DATA_DESCRIPTOR_ZIP64_LENGTH_NO_SIG;
$dataDescriptorFormatNoSig = DATA_DESCRIPTOR_ZIP64_FORMAT_NO_SIG
}
# unfortunately, the signature appears to be optional.
if ($signature == DATA_DESCRIPTOR_SIGNATURE
&& ($signature != $self->{'crc32'})) {
$bytesRead = $self->fh()->read($header, $dataDescriptorLength);
return _ioError("reading data descriptor")
if $bytesRead != $dataDescriptorLength;
($crc32, $compressedSize, $uncompressedSize) =
unpack($dataDescriptorFormat, $header);
} else {
$bytesRead = $self->fh()->read($header, $dataDescriptorLengthNoSig);
return _ioError("reading data descriptor")
if $bytesRead != $dataDescriptorLengthNoSig;
$crc32 = $signature;
($compressedSize, $uncompressedSize) =
unpack($dataDescriptorFormatNoSig, $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 ($self->{'archiveZip64'}) {
my ($status, $zip64) =
$self->_extractZip64ExtraField($self->{'cdExtraField'},
$self->{'uncompressedSize'},
$self->{'compressedSize'},
$self->{'localHeaderRelativeOffset'},
$self->{'diskNumberStart'});
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
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;