diff options
| author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
|---|---|---|
| committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
| commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
| tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/Archive | |
| parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) | |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Archive')
17 files changed, 0 insertions, 10275 deletions
diff --git a/Master/tlpkg/tlperl/lib/Archive/Extract.pm b/Master/tlpkg/tlperl/lib/Archive/Extract.pm deleted file mode 100755 index 08676fb1e08..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Extract.pm +++ /dev/null @@ -1,1511 +0,0 @@ -package Archive::Extract; - -use strict; - -use Cwd qw[cwd chdir]; -use Carp qw[carp]; -use IPC::Cmd qw[run can_run]; -use FileHandle; -use File::Path qw[mkpath]; -use File::Spec; -use File::Basename qw[dirname basename]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load check_install]; -use Locale::Maketext::Simple Style => 'gettext'; - -### solaris has silly /bin/tar output ### -use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0; -use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 }; - -### VMS may require quoting upper case command options -use constant ON_VMS => $^O eq 'VMS' ? 1 : 0; - -### Windows needs special treatment of Tar options -use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0; - -### we can't use this extraction method, because of missing -### modules/binaries: -use constant METHOD_NA => []; - -### If these are changed, update @TYPES and the new() POD -use constant TGZ => 'tgz'; -use constant TAR => 'tar'; -use constant GZ => 'gz'; -use constant ZIP => 'zip'; -use constant BZ2 => 'bz2'; -use constant TBZ => 'tbz'; -use constant Z => 'Z'; -use constant LZMA => 'lzma'; - -use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG - $_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER - ]; - -$VERSION = '0.38'; -$PREFER_BIN = 0; -$WARN = 1; -$DEBUG = 0; -$_ALLOW_PURE_PERL = 1; # allow pure perl extractors -$_ALLOW_BIN = 1; # allow binary extractors -$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available - -# same as all constants -my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA ); - -local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -Archive::Extract - A generic archive extracting mechanism - -=head1 SYNOPSIS - - use Archive::Extract; - - ### build an Archive::Extract object ### - my $ae = Archive::Extract->new( archive => 'foo.tgz' ); - - ### extract to cwd() ### - my $ok = $ae->extract; - - ### extract to /tmp ### - my $ok = $ae->extract( to => '/tmp' ); - - ### what if something went wrong? - my $ok = $ae->extract or die $ae->error; - - ### files from the archive ### - my $files = $ae->files; - - ### dir that was extracted to ### - my $outdir = $ae->extract_path; - - - ### quick check methods ### - $ae->is_tar # is it a .tar file? - $ae->is_tgz # is it a .tar.gz or .tgz file? - $ae->is_gz; # is it a .gz file? - $ae->is_zip; # is it a .zip file? - $ae->is_bz2; # is it a .bz2 file? - $ae->is_tbz; # is it a .tar.bz2 or .tbz file? - $ae->is_lzma; # is it a .lzma file? - - ### absolute path to the archive you provided ### - $ae->archive; - - ### commandline tools, if found ### - $ae->bin_tar # path to /bin/tar, if found - $ae->bin_gzip # path to /bin/gzip, if found - $ae->bin_unzip # path to /bin/unzip, if found - $ae->bin_bunzip2 # path to /bin/bunzip2 if found - $ae->bin_unlzma # path to /bin/unlzma if found - -=head1 DESCRIPTION - -Archive::Extract is a generic archive extraction mechanism. - -It allows you to extract any archive file of the type .tar, .tar.gz, -.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it -does so, or use different interfaces for each type by using either -perl modules, or commandline tools on your system. - -See the C<HOW IT WORKS> section further down for details. - -=cut - - -### see what /bin/programs are available ### -$PROGRAMS = {}; -for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) { - $PROGRAMS->{$pgm} = can_run($pgm); -} - -### mapping from types to extractor methods ### -my $Mapping = { # binary program # pure perl module - is_tgz => { bin => '_untar_bin', pp => '_untar_at' }, - is_tar => { bin => '_untar_bin', pp => '_untar_at' }, - is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' }, - is_zip => { bin => '_unzip_bin', pp => '_unzip_az' }, - is_tbz => { bin => '_untar_bin', pp => '_untar_at' }, - is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'}, - is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' }, - is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' }, -}; - -{ ### use subs so we re-generate array refs etc for the no-overide flags - ### if we don't, then we reuse the same arrayref, meaning objects store - ### previous errors - my $tmpl = { - archive => sub { { required => 1, allow => FILE_EXISTS } }, - type => sub { { default => '', allow => [ @Types ] } }, - _error_msg => sub { { no_override => 1, default => [] } }, - _error_msg_long => sub { { no_override => 1, default => [] } }, - }; - - ### build accesssors ### - for my $method( keys %$tmpl, - qw[_extractor _gunzip_to files extract_path], - ) { - no strict 'refs'; - *$method = sub { - my $self = shift; - $self->{$method} = $_[0] if @_; - return $self->{$method}; - } - } - -=head1 METHODS - -=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE]) - -Creates a new C<Archive::Extract> object based on the archive file you -passed it. Automatically determines the type of archive based on the -extension, but you can override that by explicitly providing the -C<type> argument. - -Valid values for C<type> are: - -=over 4 - -=item tar - -Standard tar files, as produced by, for example, C</bin/tar>. -Corresponds to a C<.tar> suffix. - -=item tgz - -Gzip compressed tar files, as produced by, for example C</bin/tar -z>. -Corresponds to a C<.tgz> or C<.tar.gz> suffix. - -=item gz - -Gzip compressed file, as produced by, for example C</bin/gzip>. -Corresponds to a C<.gz> suffix. - -=item Z - -Lempel-Ziv compressed file, as produced by, for example C</bin/compress>. -Corresponds to a C<.Z> suffix. - -=item zip - -Zip compressed file, as produced by, for example C</bin/zip>. -Corresponds to a C<.zip>, C<.jar> or C<.par> suffix. - -=item bz2 - -Bzip2 compressed file, as produced by, for example, C</bin/bzip2>. -Corresponds to a C<.bz2> suffix. - -=item tbz - -Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>. -Corresponds to a C<.tbz> or C<.tar.bz2> suffix. - -=item lzma - -Lzma compressed file, as produced by C</bin/lzma>. -Corresponds to a C<.lzma> suffix. - -=back - -Returns a C<Archive::Extract> object on success, or false on failure. - -=cut - - ### constructor ### - sub new { - my $class = shift; - my %hash = @_; - - ### see above why we use subs here and generate the template; - ### it's basically to not re-use arrayrefs - my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl; - - my $parsed = check( \%utmpl, \%hash ) or return; - - ### make sure we have an absolute path ### - my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} ); - - ### figure out the type, if it wasn't already specified ### - unless ( $parsed->{type} ) { - $parsed->{type} = - $ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ : - $ar =~ /.+?\.gz$/i ? GZ : - $ar =~ /.+?\.tar$/i ? TAR : - $ar =~ /.+?\.(zip|jar|par)$/i ? ZIP : - $ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ : - $ar =~ /.+?\.bz2$/i ? BZ2 : - $ar =~ /.+?\.Z$/ ? Z : - $ar =~ /.+?\.lzma$/ ? LZMA : - ''; - - } - - bless $parsed, $class; - - ### don't know what type of file it is - ### XXX this *has* to be an object call, not a package call - return $parsed->_error(loc("Cannot determine file type for '%1'", - $parsed->{archive} )) unless $parsed->{type}; - return $parsed; - } -} - -=head2 $ae->extract( [to => '/output/path'] ) - -Extracts the archive represented by the C<Archive::Extract> object to -the path of your choice as specified by the C<to> argument. Defaults to -C<cwd()>. - -Since C<.gz> files never hold a directory, but only a single file; if -the C<to> argument is an existing directory, the file is extracted -there, with its C<.gz> suffix stripped. -If the C<to> argument is not an existing directory, the C<to> argument -is understood to be a filename, if the archive type is C<gz>. -In the case that you did not specify a C<to> argument, the output -file will be the name of the archive file, stripped from its C<.gz> -suffix, in the current working directory. - -C<extract> will try a pure perl solution first, and then fall back to -commandline tools if they are available. See the C<GLOBAL VARIABLES> -section below on how to alter this behaviour. - -It will return true on success, and false on failure. - -On success, it will also set the follow attributes in the object: - -=over 4 - -=item $ae->extract_path - -This is the directory that the files where extracted to. - -=item $ae->files - -This is an array ref with the paths of all the files in the archive, -relative to the C<to> argument you specified. -To get the full path to an extracted file, you would use: - - File::Spec->catfile( $to, $ae->files->[0] ); - -Note that all files from a tar archive will be in unix format, as per -the tar specification. - -=back - -=cut - -sub extract { - my $self = shift; - my %hash = @_; - - ### reset error messages - $self->_error_msg( [] ); - $self->_error_msg_long( [] ); - - my $to; - my $tmpl = { - to => { default => '.', store => \$to } - }; - - check( $tmpl, \%hash ) or return; - - ### so 'to' could be a file or a dir, depending on whether it's a .gz - ### file, or basically anything else. - ### so, check that, then act accordingly. - ### set an accessor specifically so _gunzip can know what file to extract - ### to. - my $dir; - { ### a foo.gz file - if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) { - - my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i; - - ### to is a dir? - if ( -d $to ) { - $dir = $to; - $self->_gunzip_to( basename($cp) ); - - ### then it's a filename - } else { - $dir = dirname($to); - $self->_gunzip_to( basename($to) ); - } - - ### not a foo.gz file - } else { - $dir = $to; - } - } - - ### make the dir if it doesn't exist ### - unless( -d $dir ) { - eval { mkpath( $dir ) }; - - return $self->_error(loc("Could not create path '%1': %2", $dir, $@)) - if $@; - } - - ### get the current dir, to restore later ### - my $cwd = cwd(); - - my $ok = 1; - EXTRACT: { - - ### chdir to the target dir ### - unless( chdir $dir ) { - $self->_error(loc("Could not chdir to '%1': %2", $dir, $!)); - $ok = 0; last EXTRACT; - } - - ### set files to an empty array ref, so there's always an array - ### ref IN the accessor, to avoid errors like: - ### Can't use an undefined value as an ARRAY reference at - ### ../lib/Archive/Extract.pm line 742. (rt #19815) - $self->files( [] ); - - ### find out the dispatch methods needed for this type of - ### archive. Do a $self->is_XXX to figure out the type, then - ### get the hashref with bin + pure perl dispatchers. - my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping; - - ### add pure perl extractor if allowed & add bin extractor if allowed - my @methods; - push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL; - push @methods, $map->{'bin'} if $_ALLOW_BIN; - - ### reverse it if we prefer bin extractors - @methods = reverse @methods if $PREFER_BIN; - - my($na, $fail); - for my $method (@methods) { - print "# Extracting with ->$method\n" if $DEBUG; - - my $rv = $self->$method; - - ### a positive extraction - if( $rv and $rv ne METHOD_NA ) { - print "# Extraction succeeded\n" if $DEBUG; - $self->_extractor($method); - last; - - ### method is not available - } elsif ( $rv and $rv eq METHOD_NA ) { - print "# Extraction method not available\n" if $DEBUG; - $na++; - } else { - print "# Extraction method failed\n" if $DEBUG; - $fail++; - } - } - - ### warn something went wrong if we didn't get an extractor - unless( $self->_extractor ) { - my $diag = $fail ? loc("Extract failed due to errors") : - $na ? loc("Extract failed; no extractors available") : - ''; - - $self->_error($diag); - $ok = 0; - } - } - - ### and chdir back ### - unless( chdir $cwd ) { - $self->_error(loc("Could not chdir back to start dir '%1': %2'", - $cwd, $!)); - } - - return $ok; -} - -=pod - -=head1 ACCESSORS - -=head2 $ae->error([BOOL]) - -Returns the last encountered error as string. -Pass it a true value to get the C<Carp::longmess()> output instead. - -=head2 $ae->extract_path - -This is the directory the archive got extracted to. -See C<extract()> for details. - -=head2 $ae->files - -This is an array ref holding all the paths from the archive. -See C<extract()> for details. - -=head2 $ae->archive - -This is the full path to the archive file represented by this -C<Archive::Extract> object. - -=head2 $ae->type - -This is the type of archive represented by this C<Archive::Extract> -object. See accessors below for an easier way to use this. -See the C<new()> method for details. - -=head2 $ae->types - -Returns a list of all known C<types> for C<Archive::Extract>'s -C<new> method. - -=cut - -sub types { return @Types } - -=head2 $ae->is_tgz - -Returns true if the file is of type C<.tar.gz>. -See the C<new()> method for details. - -=head2 $ae->is_tar - -Returns true if the file is of type C<.tar>. -See the C<new()> method for details. - -=head2 $ae->is_gz - -Returns true if the file is of type C<.gz>. -See the C<new()> method for details. - -=head2 $ae->is_Z - -Returns true if the file is of type C<.Z>. -See the C<new()> method for details. - -=head2 $ae->is_zip - -Returns true if the file is of type C<.zip>. -See the C<new()> method for details. - -=head2 $ae->is_lzma - -Returns true if the file is of type C<.lzma>. -See the C<new()> method for details. - -=cut - -### quick check methods ### -sub is_tgz { return $_[0]->type eq TGZ } -sub is_tar { return $_[0]->type eq TAR } -sub is_gz { return $_[0]->type eq GZ } -sub is_zip { return $_[0]->type eq ZIP } -sub is_tbz { return $_[0]->type eq TBZ } -sub is_bz2 { return $_[0]->type eq BZ2 } -sub is_Z { return $_[0]->type eq Z } -sub is_lzma { return $_[0]->type eq LZMA } - -=pod - -=head2 $ae->bin_tar - -Returns the full path to your tar binary, if found. - -=head2 $ae->bin_gzip - -Returns the full path to your gzip binary, if found - -=head2 $ae->bin_unzip - -Returns the full path to your unzip binary, if found - -=head2 $ae->bin_unlzma - -Returns the full path to your unlzma binary, if found - -=cut - -### paths to commandline tools ### -sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} } -sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} } -sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} } -sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} } -sub bin_uncompress { return $PROGRAMS->{'uncompress'} - if $PROGRAMS->{'uncompress'} } -sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} } - -=head2 $bool = $ae->have_old_bunzip2 - -Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release, -require all archive names to end in C<.bz2> or it will not extract -them. This method checks if you have a recent version of C<bunzip2> -that allows any extension, or an older one that doesn't. - -=cut - -sub have_old_bunzip2 { - my $self = shift; - - ### no bunzip2? no old bunzip2 either :) - return unless $self->bin_bunzip2; - - ### if we can't run this, we can't be sure if it's too old or not - ### XXX stupid stupid stupid bunzip2 doesn't understand --version - ### is not a request to extract data: - ### $ bunzip2 --version - ### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001. - ### [...] - ### bunzip2: I won't read compressed data from a terminal. - ### bunzip2: For help, type: `bunzip2 --help'. - ### $ echo $? - ### 1 - ### HATEFUL! - - ### double hateful: bunzip2 --version also hangs if input is a pipe - ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH] - ### So, we have to provide *another* argument which is a fake filename, - ### just so it wont try to read from stdin to print its version.. - ### *sigh* - ### Even if the file exists, it won't clobber or change it. - my $buffer; - scalar run( - command => [$self->bin_bunzip2, '--version', 'NoSuchFile'], - verbose => 0, - buffer => \$buffer - ); - - ### no output - return unless $buffer; - - my ($version) = $buffer =~ /version \s+ (\d+)/ix; - - return 1 if $version < 1; - return; -} - -################################# -# -# Untar code -# -################################# - -### annoying issue with (gnu) tar on win32, as illustrated by this -### bug: https://rt.cpan.org/Ticket/Display.html?id=40138 -### which shows that (gnu) tar will interpret a file name with a : -### in it as a remote file name, so C:\tmp\foo.txt is interpreted -### as a remote shell, and the extract fails. -{ my @ExtraTarFlags; - if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) { - - ### if this is gnu tar we are running, we need to use --force-local - push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i; - } - - - ### use /bin/tar to extract ### - sub _untar_bin { - my $self = shift; - - ### check for /bin/tar ### - ### check for /bin/gzip if we need it ### - ### if any of the binaries are not available, return NA - { my $diag = not $self->bin_tar ? - loc("No '%1' program found", '/bin/tar') : - $self->is_tgz && !$self->bin_gzip ? - loc("No '%1' program found", '/bin/gzip') : - $self->is_tbz && !$self->bin_bunzip2 ? - loc("No '%1' program found", '/bin/bunzip2') : - ''; - - if( $diag ) { - $self->_error( $diag ); - return METHOD_NA; - } - } - - ### XXX figure out how to make IPC::Run do this in one call -- - ### currently i don't know how to get output of a command after a pipe - ### trapped in a scalar. Mailed barries about this 5th of june 2004. - - ### see what command we should run, based on whether - ### it's a .tgz or .tar - - ### XXX solaris tar and bsdtar are having different outputs - ### depending whether you run with -x or -t - ### compensate for this insanity by running -t first, then -x - { my $cmd = - $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|', - $self->bin_tar, '-tf', '-'] : - $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', - $self->bin_tar, '-tf', '-'] : - [$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive]; - - ### run the command - ### newer versions of 'tar' (1.21 and up) now print record size - ### to STDERR as well if v OR t is given (used to be both). This - ### is a 'feature' according to the changelog, so we must now only - ### inspect STDOUT, otherwise, failures like these occur: - ### nntp.perl.org/group/perl.cpan.testers/2009/02/msg3230366.html - my $buffer = ''; - my @out = run( command => $cmd, - buffer => \$buffer, - verbose => $DEBUG ); - - ### command was unsuccessful - unless( $out[0] ) { - return $self->_error(loc( - "Error listing contents of archive '%1': %2", - $self->archive, $buffer )); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_files( $self->archive ) ); - - } else { - ### if we're on solaris we /might/ be using /bin/tar, which has - ### a weird output format... we might also be using - ### /usr/local/bin/tar, which is gnu tar, which is perfectly - ### fine... so we have to do some guessing here =/ - my @files = map { chomp; - !ON_SOLARIS ? $_ - : (m|^ x \s+ # 'xtract' -- sigh - (.+?), # the actual file name - \s+ [\d,.]+ \s bytes, - \s+ [\d,.]+ \s tape \s blocks - |x ? $1 : $_); - - ### only STDOUT, see above. Sometims, extra whitespace - ### is present, so make sure we only pick lines with - ### a length - } grep { length } map { split $/, $_ } @{$out[3]}; - - ### store the files that are in the archive ### - $self->files(\@files); - } - } - - ### now actually extract it ### - { my $cmd = - $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|', - $self->bin_tar, '-xf', '-'] : - $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|', - $self->bin_tar, '-xf', '-'] : - [$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive]; - - my $buffer = ''; - unless( scalar run( command => $cmd, - buffer => \$buffer, - verbose => $DEBUG ) - ) { - return $self->_error(loc("Error extracting archive '%1': %2", - $self->archive, $buffer )); - } - - ### we might not have them, due to lack of buffers - if( $self->files ) { - ### now that we've extracted, figure out where we extracted to - my $dir = $self->__get_extract_dir( $self->files ); - - ### store the extraction dir ### - $self->extract_path( $dir ); - } - } - - ### we got here, no error happened - return 1; - } -} - - -### use archive::tar to extract ### -sub _untar_at { - my $self = shift; - - ### Loading Archive::Tar is going to set it to 1, so make it local - ### within this block, starting with its initial value. Whatever - ### Achive::Tar does will be undone when we return. - ### - ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN - ### so users don't have to even think about this variable. If they - ### do, they still get their set value outside of this call. - local $Archive::Tar::WARN = $Archive::Tar::WARN; - - ### we definitely need Archive::Tar, so load that first - { my $use_list = { 'Archive::Tar' => '0.0' }; - - unless( can_load( modules => $use_list ) ) { - - $self->_error(loc("You do not have '%1' installed - " . - "Please install it as soon as possible.", - 'Archive::Tar')); - - return METHOD_NA; - } - } - - ### we might pass it a filehandle if it's a .tbz file.. - my $fh_to_read = $self->archive; - - ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib - ### if A::T's version is 0.99 or higher - if( $self->is_tgz ) { - my $use_list = { 'Compress::Zlib' => '0.0' }; - $use_list->{ 'IO::Zlib' } = '0.0' - if $Archive::Tar::VERSION >= '0.99'; - - unless( can_load( modules => $use_list ) ) { - my $which = join '/', sort keys %$use_list; - - $self->_error(loc( - "You do not have '%1' installed - Please ". - "install it as soon as possible.", $which) - ); - - return METHOD_NA; - } - - } elsif ( $self->is_tbz ) { - my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc( - "You do not have '%1' installed - Please " . - "install it as soon as possible.", - 'IO::Uncompress::Bunzip2') - ); - - return METHOD_NA; - } - - my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or - return $self->_error(loc("Unable to open '%1': %2", - $self->archive, - $IO::Uncompress::Bunzip2::Bunzip2Error)); - - $fh_to_read = $bz; - } - - my @files; - { - ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've - ### localized $Archive::Tar::WARN already. - $Archive::Tar::WARN = $Archive::Extract::WARN; - - ### only tell it it's compressed if it's a .tgz, as we give it a file - ### handle if it's a .tbz - my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ); - - ### for version of Archive::Tar > 1.04 - local $Archive::Tar::CHOWN = 0; - - ### use the iterator if we can. it's a feature of A::T 1.40 and up - if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) { - - my $next; - unless ( $next = Archive::Tar->iter( @read ) ) { - return $self->_error(loc( - "Unable to read '%1': %2", $self->archive, - $Archive::Tar::error)); - } - - while ( my $file = $next->() ) { - push @files, $file->full_path; - - $file->extract or return $self->_error(loc( - "Unable to read '%1': %2", - $self->archive, - $Archive::Tar::error)); - } - - ### older version, read the archive into memory - } else { - - my $tar = Archive::Tar->new(); - - unless( $tar->read( @read ) ) { - return $self->_error(loc("Unable to read '%1': %2", - $self->archive, $Archive::Tar::error)); - } - - ### workaround to prevent Archive::Tar from setting uid, which - ### is a potential security hole. -autrijus - ### have to do it here, since A::T needs to be /loaded/ first ### - { no strict 'refs'; local $^W; - - ### older versions of archive::tar <= 0.23 - *Archive::Tar::chown = sub {}; - } - - { local $^W; # quell 'splice() offset past end of array' warnings - # on older versions of A::T - - ### older archive::tar always returns $self, return value - ### slightly fux0r3d because of it. - $tar->extract or return $self->_error(loc( - "Unable to extract '%1': %2", - $self->archive, $Archive::Tar::error )); - } - - @files = $tar->list_files; - } - } - - my $dir = $self->__get_extract_dir( \@files ); - - ### store the files that are in the archive ### - $self->files(\@files); - - ### store the extraction dir ### - $self->extract_path( $dir ); - - ### check if the dir actually appeared ### - return 1 if -d $self->extract_path; - - ### no dir, we failed ### - return $self->_error(loc("Unable to extract '%1': %2", - $self->archive, $Archive::Tar::error )); -} - -################################# -# -# Gunzip code -# -################################# - -sub _gunzip_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - unless( $self->bin_gzip ) { - $self->_error(loc("No '%1' program found", '/bin/gzip')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to gunzip '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_content( $self->archive ) ); - } - - $self->_print($fh, $buffer) if defined $buffer; - - close $fh; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -sub _gunzip_cz { - my $self = shift; - - my $use_list = { 'Compress::Zlib' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Compress::Zlib')); - return METHOD_NA; - } - - my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or - return $self->_error(loc("Unable to open '%1': %2", - $self->archive, $Compress::Zlib::gzerrno)); - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $buffer; - $self->_print($fh, $buffer) while $gz->gzread($buffer) > 0; - $fh->close; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -################################# -# -# Uncompress code -# -################################# - -sub _uncompress_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - unless( $self->bin_uncompress ) { - $self->_error(loc("No '%1' program found", '/bin/uncompress')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_uncompress, '-c', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to uncompress '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_content( $self->archive ) ); - } - - $self->_print($fh, $buffer) if defined $buffer; - - close $fh; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - - -################################# -# -# Unzip code -# -################################# - - -sub _unzip_bin { - my $self = shift; - - ### check for /bin/gzip if we need it ### - unless( $self->bin_unzip ) { - $self->_error(loc("No '%1' program found", '/bin/unzip')); - return METHOD_NA; - } - - ### first, get the files.. it must be 2 different commands with 'unzip' :( - { ### on VMS, capital letter options have to be quoted. This is - ### peported by John Malmberg on P5P Tue 21 Aug 2007 05:05:11 - ### Subject: [patch@31735]Archive Extract fix on VMS. - my $opt = ON_VMS ? '"-Z"' : '-Z'; - my $cmd = [ $self->bin_unzip, $opt, '-1', $self->archive ]; - - my $buffer = ''; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unzip '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_files( $self->archive ) ); - - } else { - $self->files( [split $/, $buffer] ); - } - } - - ### now, extract the archive ### - { my $cmd = [ $self->bin_unzip, '-qq', '-o', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unzip '%1': %2", - $self->archive, $buffer)); - } - - if( scalar @{$self->files} ) { - my $files = $self->files; - my $dir = $self->__get_extract_dir( $files ); - - $self->extract_path( $dir ); - } - } - - return 1; -} - -sub _unzip_az { - my $self = shift; - - my $use_list = { 'Archive::Zip' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Archive::Zip')); - return METHOD_NA; - } - - my $zip = Archive::Zip->new(); - - unless( $zip->read( $self->archive ) == &Archive::Zip::AZ_OK ) { - return $self->_error(loc("Unable to read '%1'", $self->archive)); - } - - my @files; - - - ### Address: #43278: Explicitly tell Archive::Zip where to put the files: - ### "In my BackPAN indexing, Archive::Zip was extracting things - ### in my script's directory instead of the current working directory. - ### I traced this back through Archive::Zip::_asLocalName which - ### eventually calls File::Spec::Win32::rel2abs which on Windows might - ### call Cwd::getdcwd. getdcwd returns the wrong directory in my - ### case, even though I think I'm on the same drive. - ### - ### To fix this, I pass the optional second argument to - ### extractMember using the cwd from Archive::Extract." --bdfoy - - ## store cwd() before looping; calls to cwd() can be expensive, and - ### it won't change during the loop - my $extract_dir = cwd(); - - ### have to extract every member individually ### - for my $member ($zip->members) { - push @files, $member->{fileName}; - - ### file to extact to, to avoid the above problem - my $to = File::Spec->catfile( $extract_dir, $member->{fileName} ); - - unless( $zip->extractMember($member, $to) == &Archive::Zip::AZ_OK ) { - return $self->_error(loc("Extraction of '%1' from '%2' failed", - $member->{fileName}, $self->archive )); - } - } - - my $dir = $self->__get_extract_dir( \@files ); - - ### set what files where extract, and where they went ### - $self->files( \@files ); - $self->extract_path( File::Spec->rel2abs($dir) ); - - return 1; -} - -sub __get_extract_dir { - my $self = shift; - my $files = shift || []; - - return unless scalar @$files; - - my($dir1, $dir2); - for my $aref ( [ \$dir1, 0 ], [ \$dir2, -1 ] ) { - my($dir,$pos) = @$aref; - - ### add a catdir(), so that any trailing slashes get - ### take care of (removed) - ### also, a catdir() normalises './dir/foo' to 'dir/foo'; - ### which was the problem in bug #23999 - my $res = -d $files->[$pos] - ? File::Spec->catdir( $files->[$pos], '' ) - : File::Spec->catdir( dirname( $files->[$pos] ) ); - - $$dir = $res; - } - - ### if the first and last dir don't match, make sure the - ### dirname is not set wrongly - my $dir; - - ### dirs are the same, so we know for sure what the extract dir is - if( $dir1 eq $dir2 ) { - $dir = $dir1; - - ### dirs are different.. do they share the base dir? - ### if so, use that, if not, fall back to '.' - } else { - my $base1 = [ File::Spec->splitdir( $dir1 ) ]->[0]; - my $base2 = [ File::Spec->splitdir( $dir2 ) ]->[0]; - - $dir = File::Spec->rel2abs( $base1 eq $base2 ? $base1 : '.' ); - } - - return File::Spec->rel2abs( $dir ); -} - -################################# -# -# Bunzip2 code -# -################################# - -sub _bunzip2_bin { - my $self = shift; - - ### check for /bin/gzip -- we need it ### - unless( $self->bin_bunzip2 ) { - $self->_error(loc("No '%1' program found", '/bin/bunzip2')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - ### guard against broken bunzip2. See ->have_old_bunzip2() - ### for details - if( $self->have_old_bunzip2 and $self->archive !~ /\.bz2$/i ) { - return $self->_error(loc("Your bunzip2 version is too old and ". - "can only extract files ending in '%1'", - '.bz2')); - } - - my $cmd = [ $self->bin_bunzip2, '-cd', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to bunzip2 '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_content( $self->archive ) ); - } - - $self->_print($fh, $buffer) if defined $buffer; - - close $fh; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -### using cz2, the compact versions... this we use mainly in archive::tar -### extractor.. -# sub _bunzip2_cz1 { -# my $self = shift; -# -# my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; -# unless( can_load( modules => $use_list ) ) { -# return $self->_error(loc("You do not have '%1' installed - Please " . -# "install it as soon as possible.", -# 'IO::Uncompress::Bunzip2')); -# } -# -# my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or -# return $self->_error(loc("Unable to open '%1': %2", -# $self->archive, -# $IO::Uncompress::Bunzip2::Bunzip2Error)); -# -# my $fh = FileHandle->new('>'. $self->_gunzip_to) or -# return $self->_error(loc("Could not open '%1' for writing: %2", -# $self->_gunzip_to, $! )); -# -# my $buffer; -# $fh->print($buffer) while $bz->read($buffer) > 0; -# $fh->close; -# -# ### set what files where extract, and where they went ### -# $self->files( [$self->_gunzip_to] ); -# $self->extract_path( File::Spec->rel2abs(cwd()) ); -# -# return 1; -# } - -sub _bunzip2_bz2 { - my $self = shift; - - my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", - 'IO::Uncompress::Bunzip2')); - return METHOD_NA; - } - - IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to) - or return $self->_error(loc("Unable to uncompress '%1': %2", - $self->archive, - $IO::Uncompress::Bunzip2::Bunzip2Error)); - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - - -################################# -# -# unlzma code -# -################################# - -sub _unlzma_bin { - my $self = shift; - - ### check for /bin/unlzma -- we need it ### - unless( $self->bin_unlzma ) { - $self->_error(loc("No '%1' program found", '/bin/unlzma')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $cmd = [ $self->bin_unlzma, '-c', $self->archive ]; - - my $buffer; - unless( scalar run( command => $cmd, - verbose => $DEBUG, - buffer => \$buffer ) - ) { - return $self->_error(loc("Unable to unlzma '%1': %2", - $self->archive, $buffer)); - } - - ### no buffers available? - if( !IPC::Cmd->can_capture_buffer and !$buffer ) { - $self->_error( $self->_no_buffer_content( $self->archive ) ); - } - - $self->_print($fh, $buffer) if defined $buffer; - - close $fh; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -sub _unlzma_cz { - my $self = shift; - - my $use_list = { 'Compress::unLZMA' => '0.0' }; - unless( can_load( modules => $use_list ) ) { - $self->_error(loc("You do not have '%1' installed - Please " . - "install it as soon as possible.", 'Compress::unLZMA')); - return METHOD_NA; - } - - my $fh = FileHandle->new('>'. $self->_gunzip_to) or - return $self->_error(loc("Could not open '%1' for writing: %2", - $self->_gunzip_to, $! )); - - my $buffer; - $buffer = Compress::unLZMA::uncompressfile( $self->archive ); - unless ( defined $buffer ) { - return $self->_error(loc("Could not unlzma '%1': %2", - $self->archive, $@)); - } - - $self->_print($fh, $buffer) if defined $buffer; - - close $fh; - - ### set what files where extract, and where they went ### - $self->files( [$self->_gunzip_to] ); - $self->extract_path( File::Spec->rel2abs(cwd()) ); - - return 1; -} - -################################# -# -# Error code -# -################################# - -# For printing binaries that avoids interfering globals -sub _print { - my $self = shift; - my $fh = shift; - - local( $\, $", $, ) = ( undef, ' ', '' ); - return print $fh @_; -} - -sub _error { - my $self = shift; - my $error = shift; - my $lerror = Carp::longmess($error); - - push @{$self->_error_msg}, $error; - push @{$self->_error_msg_long}, $lerror; - - ### set $Archive::Extract::WARN to 0 to disable printing - ### of errors - if( $WARN ) { - carp $DEBUG ? $lerror : $error; - } - - return; -} - -sub error { - my $self = shift; - - ### make sure we have a fallback aref - my $aref = do { - shift() - ? $self->_error_msg_long - : $self->_error_msg - } || []; - - return join $/, @$aref; -} - -sub _no_buffer_files { - my $self = shift; - my $file = shift or return; - return loc("No buffer captured, unable to tell ". - "extracted files or extraction dir for '%1'", $file); -} - -sub _no_buffer_content { - my $self = shift; - my $file = shift or return; - return loc("No buffer captured, unable to get content for '%1'", $file); -} -1; - -=pod - -=head1 HOW IT WORKS - -C<Archive::Extract> tries first to determine what type of archive you -are passing it, by inspecting its suffix. It does not do this by using -Mime magic, or something related. See C<CAVEATS> below. - -Once it has determined the file type, it knows which extraction methods -it can use on the archive. It will try a perl solution first, then fall -back to a commandline tool if that fails. If that also fails, it will -return false, indicating it was unable to extract the archive. -See the section on C<GLOBAL VARIABLES> to see how to alter this order. - -=head1 CAVEATS - -=head2 File Extensions - -C<Archive::Extract> trusts on the extension of the archive to determine -what type it is, and what extractor methods therefore can be used. If -your archives do not have any of the extensions as described in the -C<new()> method, you will have to specify the type explicitly, or -C<Archive::Extract> will not be able to extract the archive for you. - -=head2 Supporting Very Large Files - -C<Archive::Extract> can use either pure perl modules or command line -programs under the hood. Some of the pure perl modules (like -C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory, -which may not be feasible on your system. Consider setting the global -variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer -the use of command line programs and won't consume so much memory. - -See the C<GLOBAL VARIABLES> section below for details. - -=head2 Bunzip2 support of arbitrary extensions. - -Older versions of C</bin/bunzip2> do not support arbitrary file -extensions and insist on a C<.bz2> suffix. Although we do our best -to guard against this, if you experience a bunzip2 error, it may -be related to this. For details, please see the C<have_old_bunzip2> -method. - -=head1 GLOBAL VARIABLES - -=head2 $Archive::Extract::DEBUG - -Set this variable to C<true> to have all calls to command line tools -be printed out, including all their output. -This also enables C<Carp::longmess> errors, instead of the regular -C<carp> errors. - -Good for tracking down why things don't work with your particular -setup. - -Defaults to C<false>. - -=head2 $Archive::Extract::WARN - -This variable controls whether errors encountered internally by -C<Archive::Extract> should be C<carp>'d or not. - -Set to false to silence warnings. Inspect the output of the C<error()> -method manually to see what went wrong. - -Defaults to C<true>. - -=head2 $Archive::Extract::PREFER_BIN - -This variables controls whether C<Archive::Extract> should prefer the -use of perl modules, or commandline tools to extract archives. - -Set to C<true> to have C<Archive::Extract> prefer commandline tools. - -Defaults to C<false>. - -=head1 TODO / CAVEATS - -=over 4 - -=item Mime magic support - -Maybe this module should use something like C<File::Type> to determine -the type, rather than blindly trust the suffix. - -=item Thread safety - -Currently, C<Archive::Extract> does a C<chdir> to the extraction dir before -extraction, and a C<chdir> back again after. This is not necessarily -thread safe. See C<rt.cpan.org> bug C<#45671> for details. - -=back - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar.pm b/Master/tlpkg/tlperl/lib/Archive/Tar.pm deleted file mode 100755 index 006edbd5c3e..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Tar.pm +++ /dev/null @@ -1,2146 +0,0 @@ -### the gnu tar specification: -### http://www.gnu.org/software/tar/manual/tar.html -### -### and the pax format spec, which tar derives from: -### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html - -package Archive::Tar; -require 5.005_03; - -use Cwd; -use IO::Zlib; -use IO::File; -use Carp qw(carp croak); -use File::Spec (); -use File::Spec::Unix (); -use File::Path (); - -use Archive::Tar::File; -use Archive::Tar::Constant; - -require Exporter; - -use strict; -use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD - $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS - $INSECURE_EXTRACT_MODE @ISA @EXPORT - ]; - -@ISA = qw[Exporter]; -@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ]; -$DEBUG = 0; -$WARN = 1; -$FOLLOW_SYMLINK = 0; -$VERSION = "1.54"; -$CHOWN = 1; -$CHMOD = 1; -$SAME_PERMISSIONS = $> == 0 ? 1 : 0; -$DO_NOT_USE_PREFIX = 0; -$INSECURE_EXTRACT_MODE = 0; - -BEGIN { - use Config; - $HAS_PERLIO = $Config::Config{useperlio}; - - ### try and load IO::String anyway, so you can dynamically - ### switch between perlio and IO::String - $HAS_IO_STRING = eval { - require IO::String; - import IO::String; - 1; - } || 0; -} - -=head1 NAME - -Archive::Tar - module for manipulations of tar archives - -=head1 SYNOPSIS - - use Archive::Tar; - my $tar = Archive::Tar->new; - - $tar->read('origin.tgz'); - $tar->extract(); - - $tar->add_files('file/foo.pl', 'docs/README'); - $tar->add_data('file/baz.txt', 'This is the contents now'); - - $tar->rename('oldname', 'new/file/name'); - - $tar->write('files.tar'); # plain tar - $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed - $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed - -=head1 DESCRIPTION - -Archive::Tar provides an object oriented mechanism for handling tar -files. It provides class methods for quick and easy files handling -while also allowing for the creation of tar file objects for custom -manipulation. If you have the IO::Zlib module installed, -Archive::Tar will also support compressed or gzipped tar files. - -An object of class Archive::Tar represents a .tar(.gz) archive full -of files and things. - -=head1 Object Methods - -=head2 Archive::Tar->new( [$file, $compressed] ) - -Returns a new Tar object. If given any arguments, C<new()> calls the -C<read()> method automatically, passing on the arguments provided to -the C<read()> method. - -If C<new()> is invoked with arguments and the C<read()> method fails -for any reason, C<new()> returns undef. - -=cut - -my $tmpl = { - _data => [ ], - _file => 'Unknown', -}; - -### install get/set accessors for this object. -for my $key ( keys %$tmpl ) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - my $self = shift; - $self->{$key} = $_[0] if @_; - return $self->{$key}; - } -} - -sub new { - my $class = shift; - $class = ref $class if ref $class; - - ### copying $tmpl here since a shallow copy makes it use the - ### same aref, causing for files to remain in memory always. - my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class; - - if (@_) { - unless ( $obj->read( @_ ) ) { - $obj->_error(qq[No data could be read from file]); - return; - } - } - - return $obj; -} - -=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] ) - -Read the given tar file into memory. -The first argument can either be the name of a file or a reference to -an already open filehandle (or an IO::Zlib object if it's compressed) - -The C<read> will I<replace> any previous content in C<$tar>! - -The second argument may be considered optional, but remains for -backwards compatibility. Archive::Tar now looks at the file -magic to determine what class should be used to open the file -and will transparently Do The Right Thing. - -Archive::Tar will warn if you try to pass a bzip2 compressed file and the -IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return. - -Note that you can currently B<not> pass a C<gzip> compressed -filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed -filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string -containing the full archive information (either compressed or -uncompressed). These are worth while features, but not currently -implemented. See the C<TODO> section. - -The third argument can be a hash reference with options. Note that -all options are case-sensitive. - -=over 4 - -=item limit - -Do not read more than C<limit> files. This is useful if you have -very big archives, and are only interested in the first few files. - -=item filter - -Can be set to a regular expression. Only files with names that match -the expression will be read. - -=item extract - -If set to true, immediately extract entries when reading them. This -gives you the same memory break as the C<extract_archive> function. -Note however that entries will not be read into memory, but written -straight to disk. This means no C<Archive::Tar::File> objects are -created for you to inspect. - -=back - -All files are stored internally as C<Archive::Tar::File> objects. -Please consult the L<Archive::Tar::File> documentation for details. - -Returns the number of files read in scalar context, and a list of -C<Archive::Tar::File> objects in list context. - -=cut - -sub read { - my $self = shift; - my $file = shift; - my $gzip = shift || 0; - my $opts = shift || {}; - - unless( defined $file ) { - $self->_error( qq[No file to read from!] ); - return; - } else { - $self->_file( $file ); - } - - my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) ) - or return; - - my $data = $self->_read_tar( $handle, $opts ) or return; - - $self->_data( $data ); - - return wantarray ? @$data : scalar @$data; -} - -sub _get_handle { - my $self = shift; - my $file = shift; return unless defined $file; - return $file if ref $file; - my $compress = shift || 0; - my $mode = shift || READ_ONLY->( ZLIB ); # default to read only - - - ### get a FH opened to the right class, so we can use it transparently - ### throughout the program - my $fh; - { ### reading magic only makes sense if we're opening a file for - ### reading. otherwise, just use what the user requested. - my $magic = ''; - if( MODE_READ->($mode) ) { - open my $tmp, $file or do { - $self->_error( qq[Could not open '$file' for reading: $!] ); - return; - }; - - ### read the first 4 bites of the file to figure out which class to - ### use to open the file. - sysread( $tmp, $magic, 4 ); - close $tmp; - } - - ### is it bzip? - ### if you asked specifically for bzip compression, or if we're in - ### read mode and the magic numbers add up, use bzip - if( BZIP and ( - ($compress eq COMPRESS_BZIP) or - ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM ) - ) - ) { - - ### different reader/writer modules, different error vars... sigh - if( MODE_READ->($mode) ) { - $fh = IO::Uncompress::Bunzip2->new( $file ) or do { - $self->_error( qq[Could not read '$file': ] . - $IO::Uncompress::Bunzip2::Bunzip2Error - ); - return; - }; - - } else { - $fh = IO::Compress::Bzip2->new( $file ) or do { - $self->_error( qq[Could not write to '$file': ] . - $IO::Compress::Bzip2::Bzip2Error - ); - return; - }; - } - - ### is it gzip? - ### if you asked for compression, if you wanted to read or the gzip - ### magic number is present (redundant with read) - } elsif( ZLIB and ( - $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM - ) - ) { - $fh = IO::Zlib->new; - - unless( $fh->open( $file, $mode ) ) { - $self->_error(qq[Could not create filehandle for '$file': $!]); - return; - } - - ### is it plain tar? - } else { - $fh = IO::File->new; - - unless( $fh->open( $file, $mode ) ) { - $self->_error(qq[Could not create filehandle for '$file': $!]); - return; - } - - ### enable bin mode on tar archives - binmode $fh; - } - } - - return $fh; -} - - -sub _read_tar { - my $self = shift; - my $handle = shift or return; - my $opts = shift || {}; - - my $count = $opts->{limit} || 0; - my $filter = $opts->{filter}; - my $extract = $opts->{extract} || 0; - - ### set a cap on the amount of files to extract ### - my $limit = 0; - $limit = 1 if $count > 0; - - my $tarfile = [ ]; - my $chunk; - my $read = 0; - my $real_name; # to set the name of a file when - # we're encountering @longlink - my $data; - - LOOP: - while( $handle->read( $chunk, HEAD ) ) { - ### IO::Zlib doesn't support this yet - my $offset = eval { tell $handle } || 'unknown'; - - unless( $read++ ) { - my $gzip = GZIP_MAGIC_NUM; - if( $chunk =~ /$gzip/ ) { - $self->_error( qq[Cannot read compressed format in tar-mode] ); - return; - } - - ### size is < HEAD, which means a corrupted file, as the minimum - ### length is _at least_ HEAD - if (length $chunk != HEAD) { - $self->_error( qq[Cannot read enough bytes from the tarfile] ); - return; - } - } - - ### if we can't read in all bytes... ### - last if length $chunk != HEAD; - - ### Apparently this should really be two blocks of 512 zeroes, - ### but GNU tar sometimes gets it wrong. See comment in the - ### source code (tar.c) to GNU cpio. - next if $chunk eq TAR_END; - - ### according to the posix spec, the last 12 bytes of the header are - ### null bytes, to pad it to a 512 byte block. That means if these - ### bytes are NOT null bytes, it's a corrrupt header. See: - ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx - ### line 111 - { my $nulls = join '', "\0" x 12; - unless( $nulls eq substr( $chunk, 500, 12 ) ) { - $self->_error( qq[Invalid header block at offset $offset] ); - next LOOP; - } - } - - ### pass the realname, so we can set it 'proper' right away - ### some of the heuristics are done on the name, so important - ### to set it ASAP - my $entry; - { my %extra_args = (); - $extra_args{'name'} = $$real_name if defined $real_name; - - unless( $entry = Archive::Tar::File->new( chunk => $chunk, - %extra_args ) - ) { - $self->_error( qq[Couldn't read chunk at offset $offset] ); - next LOOP; - } - } - - ### ignore labels: - ### http://www.gnu.org/manual/tar/html_node/tar_139.html - next if $entry->is_label; - - if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { - - if ( $entry->is_file && !$entry->validate ) { - ### sometimes the chunk is rather fux0r3d and a whole 512 - ### bytes ends up in the ->name area. - ### clean it up, if need be - my $name = $entry->name; - $name = substr($name, 0, 100) if length $name > 100; - $name =~ s/\n/ /g; - - $self->_error( $name . qq[: checksum error] ); - next LOOP; - } - - my $block = BLOCK_SIZE->( $entry->size ); - - $data = $entry->get_content_by_ref; - - ### just read everything into memory - ### can't do lazy loading since IO::Zlib doesn't support 'seek' - ### this is because Compress::Zlib doesn't support it =/ - ### this reads in the whole data in one read() call. - if( $handle->read( $$data, $block ) < $block ) { - $self->_error( qq[Read error on tarfile (missing data) ']. - $entry->full_path ."' at offset $offset" ); - next LOOP; - } - - ### throw away trailing garbage ### - substr ($$data, $entry->size) = "" if defined $$data; - - ### part II of the @LongLink munging -- need to do /after/ - ### the checksum check. - if( $entry->is_longlink ) { - ### weird thing in tarfiles -- if the file is actually a - ### @LongLink, the data part seems to have a trailing ^@ - ### (unprintable) char. to display, pipe output through less. - ### but that doesn't *always* happen.. so check if the last - ### character is a control character, and if so remove it - ### at any rate, we better remove that character here, or tests - ### like 'eq' and hashlook ups based on names will SO not work - ### remove it by calculating the proper size, and then - ### tossing out everything that's longer than that size. - - ### count number of nulls - my $nulls = $$data =~ tr/\0/\0/; - - ### cut data + size by that many bytes - $entry->size( $entry->size - $nulls ); - substr ($$data, $entry->size) = ""; - } - } - - ### clean up of the entries.. posix tar /apparently/ has some - ### weird 'feature' that allows for filenames > 255 characters - ### they'll put a header in with as name '././@LongLink' and the - ### contents will be the name of the /next/ file in the archive - ### pretty crappy and kludgy if you ask me - - ### set the name for the next entry if this is a @LongLink; - ### this is one ugly hack =/ but needed for direct extraction - if( $entry->is_longlink ) { - $real_name = $data; - next LOOP; - } elsif ( defined $real_name ) { - $entry->name( $$real_name ); - $entry->prefix(''); - undef $real_name; - } - - ### skip this entry if we're filtering - if ($filter && $entry->name !~ $filter) { - next LOOP; - - ### skip this entry if it's a pax header. This is a special file added - ### by, among others, git-generated tarballs. It holds comments and is - ### not meant for extracting. See #38932: pax_global_header extracted - } elsif ( $entry->name eq PAX_HEADER ) { - next LOOP; - } - - $self->_extract_file( $entry ) if $extract - && !$entry->is_longlink - && !$entry->is_unknown - && !$entry->is_label; - - ### Guard against tarfiles with garbage at the end - last LOOP if $entry->name eq ''; - - ### push only the name on the rv if we're extracting - ### -- for extract_archive - push @$tarfile, ($extract ? $entry->name : $entry); - - if( $limit ) { - $count-- unless $entry->is_longlink || $entry->is_dir; - last LOOP unless $count; - } - } continue { - undef $data; - } - - return $tarfile; -} - -=head2 $tar->contains_file( $filename ) - -Check if the archive contains a certain file. -It will return true if the file is in the archive, false otherwise. - -Note however, that this function does an exact match using C<eq> -on the full path. So it cannot compensate for case-insensitive file- -systems or compare 2 paths to see if they would point to the same -underlying file. - -=cut - -sub contains_file { - my $self = shift; - my $full = shift; - - return unless defined $full; - - ### don't warn if the entry isn't there.. that's what this function - ### is for after all. - local $WARN = 0; - return 1 if $self->_find_entry($full); - return; -} - -=head2 $tar->extract( [@filenames] ) - -Write files whose names are equivalent to any of the names in -C<@filenames> to disk, creating subdirectories as necessary. This -might not work too well under VMS. -Under MacPerl, the file's modification time will be converted to the -MacOS zero of time, and appropriate conversions will be done to the -path. However, the length of each element of the path is not -inspected to see whether it's longer than MacOS currently allows (32 -characters). - -If C<extract> is called without a list of file names, the entire -contents of the archive are extracted. - -Returns a list of filenames extracted. - -=cut - -sub extract { - my $self = shift; - my @args = @_; - my @files; - - # use the speed optimization for all extracted files - local($self->{cwd}) = cwd() unless $self->{cwd}; - - ### you requested the extraction of only certian files - if( @args ) { - for my $file ( @args ) { - - ### it's already an object? - if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { - push @files, $file; - next; - - ### go find it then - } else { - - my $found; - for my $entry ( @{$self->_data} ) { - next unless $file eq $entry->full_path; - - ### we found the file you're looking for - push @files, $entry; - $found++; - } - - unless( $found ) { - return $self->_error( - qq[Could not find '$file' in archive] ); - } - } - } - - ### just grab all the file items - } else { - @files = $self->get_files; - } - - ### nothing found? that's an error - unless( scalar @files ) { - $self->_error( qq[No files found for ] . $self->_file ); - return; - } - - ### now extract them - for my $entry ( @files ) { - unless( $self->_extract_file( $entry ) ) { - $self->_error(q[Could not extract ']. $entry->full_path .q['] ); - return; - } - } - - return @files; -} - -=head2 $tar->extract_file( $file, [$extract_path] ) - -Write an entry, whose name is equivalent to the file name provided to -disk. Optionally takes a second parameter, which is the full native -path (including filename) the entry will be written to. - -For example: - - $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' ); - - $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' ); - -Returns true on success, false on failure. - -=cut - -sub extract_file { - my $self = shift; - my $file = shift; return unless defined $file; - my $alt = shift; - - my $entry = $self->_find_entry( $file ) - or $self->_error( qq[Could not find an entry for '$file'] ), return; - - return $self->_extract_file( $entry, $alt ); -} - -sub _extract_file { - my $self = shift; - my $entry = shift or return; - my $alt = shift; - - ### you wanted an alternate extraction location ### - my $name = defined $alt ? $alt : $entry->full_path; - - ### splitpath takes a bool at the end to indicate - ### that it's splitting a dir - my ($vol,$dirs,$file); - if ( defined $alt ) { # It's a local-OS path - ($vol,$dirs,$file) = File::Spec->splitpath( $alt, - $entry->is_dir ); - } else { - ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name, - $entry->is_dir ); - } - - my $dir; - ### is $name an absolute path? ### - if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) { - - ### absolute names are not allowed to be in tarballs under - ### strict mode, so only allow it if a user tells us to do it - if( not defined $alt and not $INSECURE_EXTRACT_MODE ) { - $self->_error( - q[Entry ']. $entry->full_path .q[' is an absolute path. ]. - q[Not extracting absolute paths under SECURE EXTRACT MODE] - ); - return; - } - - ### user asked us to, it's fine. - $dir = File::Spec->catpath( $vol, $dirs, "" ); - - ### it's a relative path ### - } else { - my $cwd = (ref $self and defined $self->{cwd}) - ? $self->{cwd} - : cwd(); - - my @dirs = defined $alt - ? File::Spec->splitdir( $dirs ) # It's a local-OS path - : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely - # straight from the tarball - - if( not defined $alt and - not $INSECURE_EXTRACT_MODE - ) { - - ### paths that leave the current directory are not allowed under - ### strict mode, so only allow it if a user tells us to do this. - if( grep { $_ eq '..' } @dirs ) { - - $self->_error( - q[Entry ']. $entry->full_path .q[' is attempting to leave ]. - q[the current working directory. Not extracting under ]. - q[SECURE EXTRACT MODE] - ); - return; - } - - ### the archive may be asking us to extract into a symlink. This - ### is not sane and a possible security issue, as outlined here: - ### https://rt.cpan.org/Ticket/Display.html?id=30380 - ### https://bugzilla.redhat.com/show_bug.cgi?id=295021 - ### https://issues.rpath.com/browse/RPL-1716 - my $full_path = $cwd; - for my $d ( @dirs ) { - $full_path = File::Spec->catdir( $full_path, $d ); - - ### we've already checked this one, and it's safe. Move on. - next if ref $self and $self->{_link_cache}->{$full_path}; - - if( -l $full_path ) { - my $to = readlink $full_path; - my $diag = "symlinked directory ($full_path => $to)"; - - $self->_error( - q[Entry ']. $entry->full_path .q[' is attempting to ]. - qq[extract to a $diag. This is considered a security ]. - q[vulnerability and not allowed under SECURE EXTRACT ]. - q[MODE] - ); - return; - } - - ### XXX keep a cache if possible, so the stats become cheaper: - $self->{_link_cache}->{$full_path} = 1 if ref $self; - } - } - - ### '.' is the directory delimiter on VMS, which has to be escaped - ### or changed to '_' on vms. vmsify is used, because older versions - ### of vmspath do not handle this properly. - ### Must not add a '/' to an empty directory though. - map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS; - - my ($cwd_vol,$cwd_dir,$cwd_file) - = File::Spec->splitpath( $cwd ); - my @cwd = File::Spec->splitdir( $cwd_dir ); - push @cwd, $cwd_file if length $cwd_file; - - ### We need to pass '' as the last elemant to catpath. Craig Berry - ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>): - ### The root problem is that splitpath on UNIX always returns the - ### final path element as a file even if it is a directory, and of - ### course there is no way it can know the difference without checking - ### against the filesystem, which it is documented as not doing. When - ### you turn around and call catpath, on VMS you have to know which bits - ### are directory bits and which bits are file bits. In this case we - ### know the result should be a directory. I had thought you could omit - ### the file argument to catpath in such a case, but apparently on UNIX - ### you can't. - $dir = File::Spec->catpath( - $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' - ); - - ### catdir() returns undef if the path is longer than 255 chars on - ### older VMS systems. - unless ( defined $dir ) { - $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); - return; - } - - } - - if( -e $dir && !-d _ ) { - $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] ); - return; - } - - unless ( -d _ ) { - eval { File::Path::mkpath( $dir, 0, 0777 ) }; - if( $@ ) { - my $fp = $entry->full_path; - $self->_error(qq[Could not create directory '$dir' for '$fp': $@]); - return; - } - - ### XXX chown here? that might not be the same as in the archive - ### as we're only chown'ing to the owner of the file we're extracting - ### not to the owner of the directory itself, which may or may not - ### be another entry in the archive - ### Answer: no, gnu tar doesn't do it either, it'd be the wrong - ### way to go. - #if( $CHOWN && CAN_CHOWN ) { - # chown $entry->uid, $entry->gid, $dir or - # $self->_error( qq[Could not set uid/gid on '$dir'] ); - #} - } - - ### we're done if we just needed to create a dir ### - return 1 if $entry->is_dir; - - my $full = File::Spec->catfile( $dir, $file ); - - if( $entry->is_unknown ) { - $self->_error( qq[Unknown file type for file '$full'] ); - return; - } - - if( length $entry->type && $entry->is_file ) { - my $fh = IO::File->new; - $fh->open( '>' . $full ) or ( - $self->_error( qq[Could not open file '$full': $!] ), - return - ); - - if( $entry->size ) { - binmode $fh; - syswrite $fh, $entry->data or ( - $self->_error( qq[Could not write data to '$full'] ), - return - ); - } - - close $fh or ( - $self->_error( qq[Could not close file '$full'] ), - return - ); - - } else { - $self->_make_special_file( $entry, $full ) or return; - } - - ### only update the timestamp if it's not a symlink; that will change the - ### timestamp of the original. This addresses bug #33669: Could not update - ### timestamp warning on symlinks - if( not -l $full ) { - utime time, $entry->mtime - TIME_OFFSET, $full or - $self->_error( qq[Could not update timestamp] ); - } - - if( $CHOWN && CAN_CHOWN->() ) { - chown $entry->uid, $entry->gid, $full or - $self->_error( qq[Could not set uid/gid on '$full'] ); - } - - ### only chmod if we're allowed to, but never chmod symlinks, since they'll - ### change the perms on the file they're linking too... - if( $CHMOD and not -l $full ) { - my $mode = $entry->mode; - unless ($SAME_PERMISSIONS) { - $mode &= ~(oct(7000) | umask); - } - chmod $mode, $full or - $self->_error( qq[Could not chown '$full' to ] . $entry->mode ); - } - - return 1; -} - -sub _make_special_file { - my $self = shift; - my $entry = shift or return; - my $file = shift; return unless defined $file; - - my $err; - - if( $entry->is_symlink ) { - my $fail; - if( ON_UNIX ) { - symlink( $entry->linkname, $file ) or $fail++; - - } else { - $self->_extract_special_file_as_plain_file( $entry, $file ) - or $fail++; - } - - $err = qq[Making symbolic link '$file' to '] . - $entry->linkname .q[' failed] if $fail; - - } elsif ( $entry->is_hardlink ) { - my $fail; - if( ON_UNIX ) { - link( $entry->linkname, $file ) or $fail++; - - } else { - $self->_extract_special_file_as_plain_file( $entry, $file ) - or $fail++; - } - - $err = qq[Making hard link from '] . $entry->linkname . - qq[' to '$file' failed] if $fail; - - } elsif ( $entry->is_fifo ) { - ON_UNIX && !system('mknod', $file, 'p') or - $err = qq[Making fifo ']. $entry->name .qq[' failed]; - - } elsif ( $entry->is_blockdev or $entry->is_chardev ) { - my $mode = $entry->is_blockdev ? 'b' : 'c'; - - ON_UNIX && !system('mknod', $file, $mode, - $entry->devmajor, $entry->devminor) or - $err = qq[Making block device ']. $entry->name .qq[' (maj=] . - $entry->devmajor . qq[ min=] . $entry->devminor . - qq[) failed.]; - - } elsif ( $entry->is_socket ) { - ### the original doesn't do anything special for sockets.... ### - 1; - } - - return $err ? $self->_error( $err ) : 1; -} - -### don't know how to make symlinks, let's just extract the file as -### a plain file -sub _extract_special_file_as_plain_file { - my $self = shift; - my $entry = shift or return; - my $file = shift; return unless defined $file; - - my $err; - TRY: { - my $orig = $self->_find_entry( $entry->linkname ); - - unless( $orig ) { - $err = qq[Could not find file '] . $entry->linkname . - qq[' in memory.]; - last TRY; - } - - ### clone the entry, make it appear as a normal file ### - my $clone = $entry->clone; - $clone->_downgrade_to_plainfile; - $self->_extract_file( $clone, $file ) or last TRY; - - return 1; - } - - return $self->_error($err); -} - -=head2 $tar->list_files( [\@properties] ) - -Returns a list of the names of all the files in the archive. - -If C<list_files()> is passed an array reference as its first argument -it returns a list of hash references containing the requested -properties of each file. The following list of properties is -supported: name, size, mtime (last modified date), mode, uid, gid, -linkname, uname, gname, devmajor, devminor, prefix. - -Passing an array reference containing only one element, 'name', is -special cased to return a list of names rather than a list of hash -references, making it equivalent to calling C<list_files> without -arguments. - -=cut - -sub list_files { - my $self = shift; - my $aref = shift || [ ]; - - unless( $self->_data ) { - $self->read() or return; - } - - if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) { - return map { $_->full_path } @{$self->_data}; - } else { - - #my @rv; - #for my $obj ( @{$self->_data} ) { - # push @rv, { map { $_ => $obj->$_() } @$aref }; - #} - #return @rv; - - ### this does the same as the above.. just needs a +{ } - ### to make sure perl doesn't confuse it for a block - return map { my $o=$_; - +{ map { $_ => $o->$_() } @$aref } - } @{$self->_data}; - } -} - -sub _find_entry { - my $self = shift; - my $file = shift; - - unless( defined $file ) { - $self->_error( qq[No file specified] ); - return; - } - - ### it's an object already - return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); - - for my $entry ( @{$self->_data} ) { - my $path = $entry->full_path; - return $entry if $path eq $file; - } - - $self->_error( qq[No such file in archive: '$file'] ); - return; -} - -=head2 $tar->get_files( [@filenames] ) - -Returns the C<Archive::Tar::File> objects matching the filenames -provided. If no filename list was passed, all C<Archive::Tar::File> -objects in the current Tar object are returned. - -Please refer to the C<Archive::Tar::File> documentation on how to -handle these objects. - -=cut - -sub get_files { - my $self = shift; - - return @{ $self->_data } unless @_; - - my @list; - for my $file ( @_ ) { - push @list, grep { defined } $self->_find_entry( $file ); - } - - return @list; -} - -=head2 $tar->get_content( $file ) - -Return the content of the named file. - -=cut - -sub get_content { - my $self = shift; - my $entry = $self->_find_entry( shift ) or return; - - return $entry->data; -} - -=head2 $tar->replace_content( $file, $content ) - -Make the string $content be the content for the file named $file. - -=cut - -sub replace_content { - my $self = shift; - my $entry = $self->_find_entry( shift ) or return; - - return $entry->replace_content( shift ); -} - -=head2 $tar->rename( $file, $new_name ) - -Rename the file of the in-memory archive 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 $file = shift; return unless defined $file; - my $new = shift; return unless defined $new; - - my $entry = $self->_find_entry( $file ) or return; - - return $entry->rename( $new ); -} - -=head2 $tar->remove (@filenamelist) - -Removes any entries with names matching any of the given filenames -from the in-memory archive. Returns a list of C<Archive::Tar::File> -objects that remain. - -=cut - -sub remove { - my $self = shift; - my @list = @_; - - my %seen = map { $_->full_path => $_ } @{$self->_data}; - delete $seen{ $_ } for @list; - - $self->_data( [values %seen] ); - - return values %seen; -} - -=head2 $tar->clear - -C<clear> clears the current in-memory archive. This effectively gives -you a 'blank' object, ready to be filled again. Note that C<clear> -only has effect on the object, not the underlying tarfile. - -=cut - -sub clear { - my $self = shift or return; - - $self->_data( [] ); - $self->_file( '' ); - - return 1; -} - - -=head2 $tar->write ( [$file, $compressed, $prefix] ) - -Write the in-memory archive to disk. The first argument can either -be the name of a file or a reference to an already open filehandle (a -GLOB reference). - -The second argument is used to indicate compression. You can either -compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed -to be the C<gzip> compression level (between 1 and 9), but the use of -constants is prefered: - - # write a gzip compressed file - $tar->write( 'out.tgz', COMPRESS_GZIP ); - - # write a bzip compressed file - $tar->write( 'out.tbz', COMPRESS_BZIP ); - -Note that when you pass in a filehandle, the compression argument -is ignored, as all files are printed verbatim to your filehandle. -If you wish to enable compression with filehandles, use an -C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. - -The third argument is an optional prefix. All files will be tucked -away in the directory you specify as prefix. So if you have files -'a' and 'b' in your archive, and you specify 'foo' as prefix, they -will be written to the archive as 'foo/a' and 'foo/b'. - -If no arguments are given, C<write> returns the entire formatted -archive as a string, which could be useful if you'd like to stuff the -archive into a socket or a pipe to gzip or something. - - -=cut - -sub write { - my $self = shift; - my $file = shift; $file = '' unless defined $file; - my $gzip = shift || 0; - my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; - my $dummy = ''; - - ### only need a handle if we have a file to print to ### - my $handle = length($file) - ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) ) - or return ) - : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h } - : $HAS_IO_STRING ? IO::String->new - : __PACKAGE__->no_string_support(); - - ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a - ### corrupt TAR file. Must clear out $\ to make sure no garbage is - ### printed to the archive - local $\; - - for my $entry ( @{$self->_data} ) { - ### entries to be written to the tarfile ### - my @write_me; - - ### only now will we change the object to reflect the current state - ### of the name and prefix fields -- this needs to be limited to - ### write() only! - my $clone = $entry->clone; - - - ### so, if you don't want use to use the prefix, we'll stuff - ### everything in the name field instead - if( $DO_NOT_USE_PREFIX ) { - - ### you might have an extended prefix, if so, set it in the clone - ### XXX is ::Unix right? - $clone->name( length $ext_prefix - ? File::Spec::Unix->catdir( $ext_prefix, - $clone->full_path) - : $clone->full_path ); - $clone->prefix( '' ); - - ### otherwise, we'll have to set it properly -- prefix part in the - ### prefix and name part in the name field. - } else { - - ### split them here, not before! - my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path ); - - ### you might have an extended prefix, if so, set it in the clone - ### XXX is ::Unix right? - $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix ) - if length $ext_prefix; - - $clone->prefix( $prefix ); - $clone->name( $name ); - } - - ### names are too long, and will get truncated if we don't add a - ### '@LongLink' file... - my $make_longlink = ( length($clone->name) > NAME_LENGTH or - length($clone->prefix) > PREFIX_LENGTH - ) || 0; - - ### perhaps we need to make a longlink file? - if( $make_longlink ) { - my $longlink = Archive::Tar::File->new( - data => LONGLINK_NAME, - $clone->full_path, - { type => LONGLINK } - ); - - unless( $longlink ) { - $self->_error( qq[Could not create 'LongLink' entry for ] . - qq[oversize file '] . $clone->full_path ."'" ); - return; - }; - - push @write_me, $longlink; - } - - push @write_me, $clone; - - ### write the one, optionally 2 a::t::file objects to the handle - for my $clone (@write_me) { - - ### if the file is a symlink, there are 2 options: - ### either we leave the symlink intact, but then we don't write any - ### data OR we follow the symlink, which means we actually make a - ### copy. if we do the latter, we have to change the TYPE of the - ### clone to 'FILE' - my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK; - my $data_ok = !$clone->is_symlink && $clone->has_content; - - ### downgrade to a 'normal' file if it's a symlink we're going to - ### treat as a regular file - $clone->_downgrade_to_plainfile if $link_ok; - - ### get the header for this block - my $header = $self->_format_tar_entry( $clone ); - unless( $header ) { - $self->_error(q[Could not format header for: ] . - $clone->full_path ); - return; - } - - unless( print $handle $header ) { - $self->_error(q[Could not write header for: ] . - $clone->full_path); - return; - } - - if( $link_ok or $data_ok ) { - unless( print $handle $clone->data ) { - $self->_error(q[Could not write data for: ] . - $clone->full_path); - return; - } - - ### pad the end of the clone if required ### - print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK - } - - } ### done writing these entries - } - - ### write the end markers ### - print $handle TAR_END x 2 or - return $self->_error( qq[Could not write tar end markers] ); - - ### did you want it written to a file, or returned as a string? ### - my $rv = length($file) ? 1 - : $HAS_PERLIO ? $dummy - : do { seek $handle, 0, 0; local $/; <$handle> }; - - ### make sure to close the handle; - close $handle; - - return $rv; -} - -sub _format_tar_entry { - my $self = shift; - my $entry = shift or return; - my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; - my $no_prefix = shift || 0; - - my $file = $entry->name; - my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; - - ### remove the prefix from the file name - ### not sure if this is still neeeded --kane - ### no it's not -- Archive::Tar::File->_new_from_file will take care of - ### this for us. Even worse, this would break if we tried to add a file - ### like x/x. - #if( length $prefix ) { - # $file =~ s/^$match//; - #} - - $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix) - if length $ext_prefix; - - ### not sure why this is... ### - my $l = PREFIX_LENGTH; # is ambiguous otherwise... - substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; - - my $f1 = "%06o"; my $f2 = "%11o"; - - ### this might be optimizable with a 'changed' flag in the file objects ### - my $tar = pack ( - PACK, - $file, - - (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]), - (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]), - - "", # checksum field - space padded a bit down - - (map { $entry->$_() } qw[type linkname magic]), - - $entry->version || TAR_VERSION, - - (map { $entry->$_() } qw[uname gname]), - (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]), - - ($no_prefix ? '' : $prefix) - ); - - ### add the checksum ### - substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); - - return $tar; -} - -=head2 $tar->add_files( @filenamelist ) - -Takes a list of filenames and adds them to the in-memory archive. - -The path to the file is automatically converted to a Unix like -equivalent for use in the archive, and, if on MacOS, the file's -modification time is converted from the MacOS epoch to the Unix epoch. -So tar archives created on MacOS with B<Archive::Tar> can be read -both with I<tar> on Unix and applications like I<suntar> or -I<Stuffit Expander> on MacOS. - -Be aware that the file's type/creator and resource fork will be lost, -which is usually what you want in cross-platform archives. - -Instead of a filename, you can also pass it an existing C<Archive::Tar::File> -object from, for example, another archive. The object will be clone, and -effectively be a copy of the original, not an alias. - -Returns a list of C<Archive::Tar::File> objects that were just added. - -=cut - -sub add_files { - my $self = shift; - my @files = @_ or return; - - my @rv; - for my $file ( @files ) { - - ### you passed an Archive::Tar::File object - ### clone it so we don't accidentally have a reference to - ### an object from another archive - if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) { - push @rv, $file->clone; - next; - } - - unless( -e $file || -l $file ) { - $self->_error( qq[No such file: '$file'] ); - next; - } - - my $obj = Archive::Tar::File->new( file => $file ); - unless( $obj ) { - $self->_error( qq[Unable to add file: '$file'] ); - next; - } - - push @rv, $obj; - } - - push @{$self->{_data}}, @rv; - - return @rv; -} - -=head2 $tar->add_data ( $filename, $data, [$opthashref] ) - -Takes a filename, a scalar full of data and optionally a reference to -a hash with specific options. - -Will add a file to the in-memory archive, with name C<$filename> and -content C<$data>. Specific properties can be set using C<$opthashref>. -The following list of properties is supported: name, size, mtime -(last modified date), mode, uid, gid, linkname, uname, gname, -devmajor, devminor, prefix, type. (On MacOS, the file's path and -modification times are converted to Unix equivalents.) - -Valid values for the file type are the following constants defined in -Archive::Tar::Constants: - -=over 4 - -=item FILE - -Regular file. - -=item HARDLINK - -=item SYMLINK - -Hard and symbolic ("soft") links; linkname should specify target. - -=item CHARDEV - -=item BLOCKDEV - -Character and block devices. devmajor and devminor should specify the major -and minor device numbers. - -=item DIR - -Directory. - -=item FIFO - -FIFO (named pipe). - -=item SOCKET - -Socket. - -=back - -Returns the C<Archive::Tar::File> object that was just added, or -C<undef> on failure. - -=cut - -sub add_data { - my $self = shift; - my ($file, $data, $opt) = @_; - - my $obj = Archive::Tar::File->new( data => $file, $data, $opt ); - unless( $obj ) { - $self->_error( qq[Unable to add file: '$file'] ); - return; - } - - push @{$self->{_data}}, $obj; - - return $obj; -} - -=head2 $tar->error( [$BOOL] ) - -Returns the current errorstring (usually, the last error reported). -If a true value was specified, it will give the C<Carp::longmess> -equivalent of the error, in effect giving you a stacktrace. - -For backwards compatibility, this error is also available as -C<$Archive::Tar::error> although it is much recommended you use the -method call instead. - -=cut - -{ - $error = ''; - my $longmess; - - sub _error { - my $self = shift; - my $msg = $error = shift; - $longmess = Carp::longmess($error); - if (ref $self) { - $self->{_error} = $error; - $self->{_longmess} = $longmess; - } - - ### set Archive::Tar::WARN to 0 to disable printing - ### of errors - if( $WARN ) { - carp $DEBUG ? $longmess : $msg; - } - - return; - } - - sub error { - my $self = shift; - if (ref $self) { - return shift() ? $self->{_longmess} : $self->{_error}; - } else { - return shift() ? $longmess : $error; - } - } -} - -=head2 $tar->setcwd( $cwd ); - -C<Archive::Tar> needs to know the current directory, and it will run -C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the -tarfile and saves it in the file system. (As of version 1.30, however, -C<Archive::Tar> will use the speed optimization described below -automatically, so it's only relevant if you're using C<extract_file()>). - -Since C<Archive::Tar> doesn't change the current directory internally -while it is extracting the items in a tarball, all calls to C<Cwd::cwd()> -can be avoided if we can guarantee that the current directory doesn't -get changed externally. - -To use this performance boost, set the current directory via - - use Cwd; - $tar->setcwd( cwd() ); - -once before calling a function like C<extract_file> and -C<Archive::Tar> will use the current directory setting from then on -and won't call C<Cwd::cwd()> internally. - -To switch back to the default behaviour, use - - $tar->setcwd( undef ); - -and C<Archive::Tar> will call C<Cwd::cwd()> internally again. - -If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will -be called for you. - -=cut - -sub setcwd { - my $self = shift; - my $cwd = shift; - - $self->{cwd} = $cwd; -} - -=head1 Class Methods - -=head2 Archive::Tar->create_archive($file, $compressed, @filelist) - -Creates a tar file from the list of files provided. The first -argument can either be the name of the tar file to create or a -reference to an open file handle (e.g. a GLOB reference). - -The second argument is used to indicate compression. You can either -compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed -to be the C<gzip> compression level (between 1 and 9), but the use of -constants is prefered: - - # write a gzip compressed file - Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist ); - - # write a bzip compressed file - Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist ); - -Note that when you pass in a filehandle, the compression argument -is ignored, as all files are printed verbatim to your filehandle. -If you wish to enable compression with filehandles, use an -C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. - -The remaining arguments list the files to be included in the tar file. -These files must all exist. Any files which don't exist or can't be -read are silently ignored. - -If the archive creation fails for any reason, C<create_archive> will -return false. Please use the C<error> method to find the cause of the -failure. - -Note that this method does not write C<on the fly> as it were; it -still reads all the files into memory before writing out the archive. -Consult the FAQ below if this is a problem. - -=cut - -sub create_archive { - my $class = shift; - - my $file = shift; return unless defined $file; - my $gzip = shift || 0; - my @files = @_; - - unless( @files ) { - return $class->_error( qq[Cowardly refusing to create empty archive!] ); - } - - my $tar = $class->new; - $tar->add_files( @files ); - return $tar->write( $file, $gzip ); -} - -=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] ) - -Returns an iterator function that reads the tar file without loading -it all in memory. Each time the function is called it will return the -next file in the tarball. The files are returned as -C<Archive::Tar::File> objects. The iterator function returns the -empty list once it has exhausted the files contained. - -The second argument can be a hash reference with options, which are -identical to the arguments passed to C<read()>. - -Example usage: - - my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} ); - - while( my $f = $next->() ) { - print $f->name, "\n"; - - $f->extract or warn "Extraction failed"; - - # .... - } - -=cut - - -sub iter { - my $class = shift; - my $filename = shift or return; - my $compressed = shift or 0; - my $opts = shift || {}; - - ### get a handle to read from. - my $handle = $class->_get_handle( - $filename, - $compressed, - READ_ONLY->( ZLIB ) - ) or return; - - my @data; - return sub { - return shift(@data) if @data; # more than one file returned? - return unless $handle; # handle exhausted? - - ### read data, should only return file - my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 }); - @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY'; - - ### return one piece of data - return shift(@data) if @data; - - ### data is exhausted, free the filehandle - undef $handle; - return; - }; -} - -=head2 Archive::Tar->list_archive($file, $compressed, [\@properties]) - -Returns a list of the names of all the files in the archive. The -first argument can either be the name of the tar file to list or a -reference to an open file handle (e.g. a GLOB reference). - -If C<list_archive()> is passed an array reference as its third -argument it returns a list of hash references containing the requested -properties of each file. The following list of properties is -supported: full_path, name, size, mtime (last modified date), mode, -uid, gid, linkname, uname, gname, devmajor, devminor, prefix. - -See C<Archive::Tar::File> for details about supported properties. - -Passing an array reference containing only one element, 'name', is -special cased to return a list of names rather than a list of hash -references. - -=cut - -sub list_archive { - my $class = shift; - my $file = shift; return unless defined $file; - my $gzip = shift || 0; - - my $tar = $class->new($file, $gzip); - return unless $tar; - - return $tar->list_files( @_ ); -} - -=head2 Archive::Tar->extract_archive($file, $compressed) - -Extracts the contents of the tar file. The first argument can either -be the name of the tar file to create or a reference to an open file -handle (e.g. a GLOB reference). All relative paths in the tar file will -be created underneath the current working directory. - -C<extract_archive> will return a list of files it extracted. -If the archive extraction fails for any reason, C<extract_archive> -will return false. Please use the C<error> method to find the cause -of the failure. - -=cut - -sub extract_archive { - my $class = shift; - my $file = shift; return unless defined $file; - my $gzip = shift || 0; - - my $tar = $class->new( ) or return; - - return $tar->read( $file, $gzip, { extract => 1 } ); -} - -=head2 $bool = Archive::Tar->has_io_string - -Returns true if we currently have C<IO::String> support loaded. - -Either C<IO::String> or C<perlio> support is needed to support writing -stringified archives. Currently, C<perlio> is the preferred method, if -available. - -See the C<GLOBAL VARIABLES> section to see how to change this preference. - -=cut - -sub has_io_string { return $HAS_IO_STRING; } - -=head2 $bool = Archive::Tar->has_perlio - -Returns true if we currently have C<perlio> support loaded. - -This requires C<perl-5.8> or higher, compiled with C<perlio> - -Either C<IO::String> or C<perlio> support is needed to support writing -stringified archives. Currently, C<perlio> is the preferred method, if -available. - -See the C<GLOBAL VARIABLES> section to see how to change this preference. - -=cut - -sub has_perlio { return $HAS_PERLIO; } - -=head2 $bool = Archive::Tar->has_zlib_support - -Returns true if C<Archive::Tar> can extract C<zlib> compressed archives - -=cut - -sub has_zlib_support { return ZLIB } - -=head2 $bool = Archive::Tar->has_bzip2_support - -Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives - -=cut - -sub has_bzip2_support { return BZIP } - -=head2 Archive::Tar->can_handle_compressed_files - -A simple checking routine, which will return true if C<Archive::Tar> -is able to uncompress compressed archives on the fly with C<IO::Zlib> -and C<IO::Compress::Bzip2> or false if not both are installed. - -You can use this as a shortcut to determine whether C<Archive::Tar> -will do what you think before passing compressed archives to its -C<read> method. - -=cut - -sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 } - -sub no_string_support { - croak("You have to install IO::String to support writing archives to strings"); -} - -1; - -__END__ - -=head1 GLOBAL VARIABLES - -=head2 $Archive::Tar::FOLLOW_SYMLINK - -Set this variable to C<1> to make C<Archive::Tar> effectively make a -copy of the file when extracting. Default is C<0>, which -means the symlink stays intact. Of course, you will have to pack the -file linked to as well. - -This option is checked when you write out the tarfile using C<write> -or C<create_archive>. - -This works just like C</bin/tar>'s C<-h> option. - -=head2 $Archive::Tar::CHOWN - -By default, C<Archive::Tar> will try to C<chown> your files if it is -able to. In some cases, this may not be desired. In that case, set -this variable to C<0> to disable C<chown>-ing, even if it were -possible. - -The default is C<1>. - -=head2 $Archive::Tar::CHMOD - -By default, C<Archive::Tar> will try to C<chmod> your files to -whatever mode was specified for the particular file in the archive. -In some cases, this may not be desired. In that case, set this -variable to C<0> to disable C<chmod>-ing. - -The default is C<1>. - -=head2 $Archive::Tar::SAME_PERMISSIONS - -When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether -the permissions on files from the archive are used without modification -of if they are filtered by removing any setid bits and applying the -current umask. - -The default is C<1> for the root user and C<0> for normal users. - -=head2 $Archive::Tar::DO_NOT_USE_PREFIX - -By default, C<Archive::Tar> will try to put paths that are over -100 characters in the C<prefix> field of your tar header, as -defined per POSIX-standard. However, some (older) tar programs -do not implement this spec. To retain compatibility with these older -or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX> -variable to a true value, and C<Archive::Tar> will use an alternate -way of dealing with paths over 100 characters by using the -C<GNU Extended Header> feature. - -Note that clients who do not support the C<GNU Extended Header> -feature will not be able to read these archives. Such clients include -tars on C<Solaris>, C<Irix> and C<AIX>. - -The default is C<0>. - -=head2 $Archive::Tar::DEBUG - -Set this variable to C<1> to always get the C<Carp::longmess> output -of the warnings, instead of the regular C<carp>. This is the same -message you would get by doing: - - $tar->error(1); - -Defaults to C<0>. - -=head2 $Archive::Tar::WARN - -Set this variable to C<0> if you do not want any warnings printed. -Personally I recommend against doing this, but people asked for the -option. Also, be advised that this is of course not threadsafe. - -Defaults to C<1>. - -=head2 $Archive::Tar::error - -Holds the last reported error. Kept for historical reasons, but its -use is very much discouraged. Use the C<error()> method instead: - - warn $tar->error unless $tar->extract; - -Note that in older versions of this module, the C<error()> method -would return an effectively global value even when called an instance -method as above. This has since been fixed, and multiple instances of -C<Archive::Tar> now have separate error strings. - -=head2 $Archive::Tar::INSECURE_EXTRACT_MODE - -This variable indicates whether C<Archive::Tar> should allow -files to be extracted outside their current working directory. - -Allowing this could have security implications, as a malicious -tar archive could alter or replace any file the extracting user -has permissions to. Therefor, the default is to not allow -insecure extractions. - -If you trust the archive, or have other reasons to allow the -archive to write files outside your current working directory, -set this variable to C<true>. - -Note that this is a backwards incompatible change from version -C<1.36> and before. - -=head2 $Archive::Tar::HAS_PERLIO - -This variable holds a boolean indicating if we currently have -C<perlio> support loaded. This will be enabled for any perl -greater than C<5.8> compiled with C<perlio>. - -If you feel strongly about disabling it, set this variable to -C<false>. Note that you will then need C<IO::String> installed -to support writing stringified archives. - -Don't change this variable unless you B<really> know what you're -doing. - -=head2 $Archive::Tar::HAS_IO_STRING - -This variable holds a boolean indicating if we currently have -C<IO::String> support loaded. This will be enabled for any perl -that has a loadable C<IO::String> module. - -If you feel strongly about disabling it, set this variable to -C<false>. Note that you will then need C<perlio> support from -your perl to be able to write stringified archives. - -Don't change this variable unless you B<really> know what you're -doing. - -=head1 FAQ - -=over 4 - -=item What's the minimum perl version required to run Archive::Tar? - -You will need perl version 5.005_03 or newer. - -=item Isn't Archive::Tar slow? - -Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar> -However, it's very portable. If speed is an issue, consider using -C</bin/tar> instead. - -=item Isn't Archive::Tar heavier on memory than /bin/tar? - -Yes it is, see previous answer. Since C<Compress::Zlib> and therefore -C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little -choice but to read the archive into memory. -This is ok if you want to do in-memory manipulation of the archive. - -If you just want to extract, use the C<extract_archive> class method -instead. It will optimize and write to disk immediately. - -Another option is to use the C<iter> class method to iterate over -the files in the tarball without reading them all in memory at once. - -=item Can you lazy-load data instead? - -In some cases, yes. You can use the C<iter> class method to iterate -over the files in the tarball without reading them all in memory at once. - -=item How much memory will an X kb tar file need? - -Probably more than X kb, since it will all be read into memory. If -this is a problem, and you don't need to do in memory manipulation -of the archive, consider using the C<iter> class method, or C</bin/tar> -instead. - -=item What do you do with unsupported filetypes in an archive? - -C<Unix> has a few filetypes that aren't supported on other platforms, -like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just -try to make a copy of the original file, rather than throwing an error. - -This does require you to read the entire archive in to memory first, -since otherwise we wouldn't know what data to fill the copy with. -(This means that you cannot use the class methods, including C<iter> -on archives that have incompatible filetypes and still expect things -to work). - -For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that -the extraction of this particular item didn't work. - -=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly! - -By default, C<Archive::Tar> is in a completely POSIX-compatible -mode, which uses the POSIX-specification of C<tar> to store files. -For paths greather than 100 characters, this is done using the -C<POSIX header prefix>. Non-POSIX-compatible clients may not support -this part of the specification, and may only support the C<GNU Extended -Header> functionality. To facilitate those clients, you can set the -C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the -C<GLOBAL VARIABLES> section for details on this variable. - -Note that GNU tar earlier than version 1.14 does not cope well with -the C<POSIX header prefix>. If you use such a version, consider setting -the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. - -=item How do I extract only files that have property X from an archive? - -Sometimes, you might not wish to extract a complete archive, just -the files that are relevant to you, based on some criteria. - -You can do this by filtering a list of C<Archive::Tar::File> objects -based on your criteria. For example, to extract only files that have -the string C<foo> in their title, you would use: - - $tar->extract( - grep { $_->full_path =~ /foo/ } $tar->get_files - ); - -This way, you can filter on any attribute of the files in the archive. -Consult the C<Archive::Tar::File> documentation on how to use these -objects. - -=item How do I access .tar.Z files? - -The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via -the C<IO::Zlib> module) to access tar files that have been compressed -with C<gzip>. Unfortunately tar files compressed with the Unix C<compress> -utility cannot be read by C<Compress::Zlib> and so cannot be directly -accesses by C<Archive::Tar>. - -If the C<uncompress> or C<gunzip> programs are available, you can use -one of these workarounds to read C<.tar.Z> files from C<Archive::Tar> - -Firstly with C<uncompress> - - use Archive::Tar; - - open F, "uncompress -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... - -and this with C<gunzip> - - use Archive::Tar; - - open F, "gunzip -c $filename |"; - my $tar = Archive::Tar->new(*F); - ... - -Similarly, if the C<compress> program is available, you can use this to -write a C<.tar.Z> file - - use Archive::Tar; - use IO::File; - - my $fh = new IO::File "| compress -c >$filename"; - my $tar = Archive::Tar->new(); - ... - $tar->write($fh); - $fh->close ; - -=item How do I handle Unicode strings? - -C<Archive::Tar> uses byte semantics for any files it reads from or writes -to disk. This is not a problem if you only deal with files and never -look at their content or work solely with byte strings. But if you use -Unicode strings with character semantics, some additional steps need -to be taken. - -For example, if you add a Unicode string like - - # Problem - $tar->add_data('file.txt', "Euro: \x{20AC}"); - -then there will be a problem later when the tarfile gets written out -to disk via C<$tar->write()>: - - Wide character in print at .../Archive/Tar.pm line 1014. - -The data was added as a Unicode string and when writing it out to disk, -the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl -tried to convert the string to ISO-8859 and failed. The written file -now contains garbage. - -For this reason, Unicode strings need to be converted to UTF-8-encoded -bytestrings before they are handed off to C<add_data()>: - - use Encode; - my $data = "Accented character: \x{20AC}"; - $data = encode('utf8', $data); - - $tar->add_data('file.txt', $data); - -A opposite problem occurs if you extract a UTF8-encoded file from a -tarball. Using C<get_content()> on the C<Archive::Tar::File> object -will return its content as a bytestring, not as a Unicode string. - -If you want it to be a Unicode string (because you want character -semantics with operations like regular expression matching), you need -to decode the UTF8-encoded content and have Perl convert it into -a Unicode string: - - use Encode; - my $data = $tar->get_content(); - - # Make it a Unicode string - $data = decode('utf8', $data); - -There is no easy way to provide this functionality in C<Archive::Tar>, -because a tarball can contain many files, and each of which could be -encoded in a different way. - -=back - -=head1 CAVEATS - -The AIX tar does not fill all unused space in the tar archive with 0x00. -This sometimes leads to warning messages from C<Archive::Tar>. - - Invalid header block at offset nnn - -A fix for that problem is scheduled to be released in the following levels -of AIX, all of which should be coming out in the 4th quarter of 2009: - - AIX 5.3 TL7 SP10 - AIX 5.3 TL8 SP8 - AIX 5.3 TL9 SP5 - AIX 5.3 TL10 SP2 - - AIX 6.1 TL0 SP11 - AIX 6.1 TL1 SP7 - AIX 6.1 TL2 SP6 - AIX 6.1 TL3 SP3 - -The IBM APAR number for this problem is IZ50240 (Reported component ID: -5765G0300 / AIX 5.3). It is possible to get an ifix for that problem. -If you need an ifix please contact your local IBM AIX support. - -=head1 TODO - -=over 4 - -=item Check if passed in handles are open for read/write - -Currently I don't know of any portable pure perl way to do this. -Suggestions welcome. - -=item Allow archives to be passed in as string - -Currently, we only allow opened filehandles or filenames, but -not strings. The internals would need some reworking to facilitate -stringified archives. - -=item Facilitate processing an opened filehandle of a compressed archive - -Currently, we only support this if the filehandle is an IO::Zlib object. -Environments, like apache, will present you with an opened filehandle -to an uploaded file, which might be a compressed archive. - -=back - -=head1 SEE ALSO - -=over 4 - -=item The GNU tar specification - -C<http://www.gnu.org/software/tar/manual/tar.html> - -=item The PAX format specication - -The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html> - -=item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html> - -=item GNU tar intends to switch to POSIX compatibility - -GNU Tar authors have expressed their intention to become completely -POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html> - -=item A Comparison between various tar implementations - -Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs> - -=back - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>. - -=head1 ACKNOWLEDGEMENTS - -Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas, -Rainer Tammer and especially Andrew Savige for their help and suggestions. - -=head1 COPYRIGHT - -This module is copyright (c) 2002 - 2009 Jos Boumans -E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm deleted file mode 100755 index aef1d623fa8..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Tar/Constant.pm +++ /dev/null @@ -1,86 +0,0 @@ -package Archive::Tar::Constant; - -BEGIN { - require Exporter; - - $VERSION = '0.02'; - @ISA = qw[Exporter]; - - require Time::Local if $^O eq "MacOS"; -} - -use Package::Constants; -@EXPORT = Package::Constants->list( __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 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'; -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,70) : 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 - }; - -use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; -use constant BZIP_MAGIC_NUM => qr/^BZh\d/; - -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'; - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm deleted file mode 100755 index 0815bb67620..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Tar/File.pm +++ /dev/null @@ -1,660 +0,0 @@ -package Archive::Tar::File; -use strict; - -use Carp (); -use IO::File; -use File::Spec::Unix (); -use File::Spec (); -use File::Basename (); - -### avoid circular use, so only require; -require Archive::Tar; -use Archive::Tar::Constant; - -use vars qw[@ISA $VERSION]; -#@ISA = qw[Archive::Tar]; -$VERSION = '0.02'; - -### set value to 1 to oct() it during the unpack ### -my $tmpl = [ - name => 0, # string - mode => 1, # octal - uid => 1, # octal - gid => 1, # octal - size => 1, # octal - mtime => 1, # octal - chksum => 1, # octal - type => 0, # character - linkname => 0, # string - magic => 0, # string - version => 0, # 2 bytes - uname => 0, # string - gname => 0, # string - devmajor => 1, # octal - devminor => 1, # octal - prefix => 0, - -### 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 { - $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ - } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); - - 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( $dirs ); - - ### so sometimes the last element is '' -- probably when trailing - ### dir slashes are encountered... this is of course pointless, - ### so remove it - pop @dirs while @dirs and not length $dirs[-1]; - - ### 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 - map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS; - - my $prefix = File::Spec::Unix->catdir( - grep { length } $vol, @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; - - 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 emtpy - 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; -} - -=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; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip.pm b/Master/tlpkg/tlperl/lib/Archive/Zip.pm deleted file mode 100755 index 8fd86c93b72..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip.pm +++ /dev/null @@ -1,2059 +0,0 @@ -package Archive::Zip; - -use strict; -BEGIN { - require 5.003_96; -} -use UNIVERSAL (); -use Carp (); -use Cwd (); -use IO::File (); -use IO::Seekable (); -use Compress::Raw::Zlib (); -use File::Spec (); -use File::Temp (); -use FileHandle (); - -use vars qw( $VERSION @ISA ); -BEGIN { - $VERSION = '1.30'; - - require Exporter; - @ISA = qw( Exporter ); -} - -use vars qw( $ChunkSize $ErrorHandler ); -BEGIN { - # This is the size we'll try to read, write, and (de)compress. - # You could set it to something different if you had lots of memory - # and needed more speed. - $ChunkSize ||= 32768; - - $ErrorHandler = \&Carp::carp; -} - -# BEGIN block is necessary here so that other modules can use the constants. -use vars qw( @EXPORT_OK %EXPORT_TAGS ); -BEGIN { - @EXPORT_OK = ('computeCRC32'); - %EXPORT_TAGS = ( - CONSTANTS => [ qw( - FA_MSDOS - FA_UNIX - GPBF_ENCRYPTED_MASK - GPBF_DEFLATING_COMPRESSION_MASK - GPBF_HAS_DATA_DESCRIPTOR_MASK - COMPRESSION_STORED - COMPRESSION_DEFLATED - COMPRESSION_LEVEL_NONE - COMPRESSION_LEVEL_DEFAULT - COMPRESSION_LEVEL_FASTEST - COMPRESSION_LEVEL_BEST_COMPRESSION - IFA_TEXT_FILE_MASK - IFA_TEXT_FILE - IFA_BINARY_FILE - ) ], - - MISC_CONSTANTS => [ qw( - FA_AMIGA - FA_VAX_VMS - FA_VM_CMS - FA_ATARI_ST - FA_OS2_HPFS - FA_MACINTOSH - FA_Z_SYSTEM - FA_CPM - FA_TOPS20 - FA_WINDOWS_NTFS - FA_QDOS - FA_ACORN - FA_VFAT - FA_MVS - FA_BEOS - FA_TANDEM - FA_THEOS - GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK - GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK - GPBF_IS_COMPRESSED_PATCHED_DATA_MASK - COMPRESSION_SHRUNK - DEFLATING_COMPRESSION_NORMAL - DEFLATING_COMPRESSION_MAXIMUM - DEFLATING_COMPRESSION_FAST - DEFLATING_COMPRESSION_SUPER_FAST - COMPRESSION_REDUCED_1 - COMPRESSION_REDUCED_2 - COMPRESSION_REDUCED_3 - COMPRESSION_REDUCED_4 - COMPRESSION_IMPLODED - COMPRESSION_TOKENIZED - COMPRESSION_DEFLATED_ENHANCED - COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED - ) ], - - ERROR_CODES => [ qw( - AZ_OK - AZ_STREAM_END - AZ_ERROR - AZ_FORMAT_ERROR - AZ_IO_ERROR - ) ], - - # For Internal Use Only - PKZIP_CONSTANTS => [ qw( - SIGNATURE_FORMAT - SIGNATURE_LENGTH - LOCAL_FILE_HEADER_SIGNATURE - LOCAL_FILE_HEADER_FORMAT - LOCAL_FILE_HEADER_LENGTH - CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE - DATA_DESCRIPTOR_FORMAT - DATA_DESCRIPTOR_LENGTH - DATA_DESCRIPTOR_SIGNATURE - DATA_DESCRIPTOR_FORMAT_NO_SIG - DATA_DESCRIPTOR_LENGTH_NO_SIG - CENTRAL_DIRECTORY_FILE_HEADER_FORMAT - CENTRAL_DIRECTORY_FILE_HEADER_LENGTH - END_OF_CENTRAL_DIRECTORY_SIGNATURE - END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING - END_OF_CENTRAL_DIRECTORY_FORMAT - END_OF_CENTRAL_DIRECTORY_LENGTH - ) ], - - # For Internal Use Only - UTILITY_METHODS => [ qw( - _error - _printError - _ioError - _formatError - _subclassResponsibility - _binmode - _isSeekable - _newFileHandle - _readSignature - _asZipDirName - ) ], - ); - - # Add all the constant names and error code names to @EXPORT_OK - Exporter::export_ok_tags( qw( - CONSTANTS - ERROR_CODES - PKZIP_CONSTANTS - UTILITY_METHODS - MISC_CONSTANTS - ) ); - -} - -# Error codes -use constant AZ_OK => 0; -use constant AZ_STREAM_END => 1; -use constant AZ_ERROR => 2; -use constant AZ_FORMAT_ERROR => 3; -use constant AZ_IO_ERROR => 4; - -# File types -# Values of Archive::Zip::Member->fileAttributeFormat() - -use constant FA_MSDOS => 0; -use constant FA_AMIGA => 1; -use constant FA_VAX_VMS => 2; -use constant FA_UNIX => 3; -use constant FA_VM_CMS => 4; -use constant FA_ATARI_ST => 5; -use constant FA_OS2_HPFS => 6; -use constant FA_MACINTOSH => 7; -use constant FA_Z_SYSTEM => 8; -use constant FA_CPM => 9; -use constant FA_TOPS20 => 10; -use constant FA_WINDOWS_NTFS => 11; -use constant FA_QDOS => 12; -use constant FA_ACORN => 13; -use constant FA_VFAT => 14; -use constant FA_MVS => 15; -use constant FA_BEOS => 16; -use constant FA_TANDEM => 17; -use constant FA_THEOS => 18; - -# general-purpose bit flag masks -# Found in Archive::Zip::Member->bitFlag() - -use constant GPBF_ENCRYPTED_MASK => 1 << 0; -use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1; -use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3; - -# deflating compression types, if compressionMethod == COMPRESSION_DEFLATED -# ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK ) - -use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1; -use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1; -use constant DEFLATING_COMPRESSION_FAST => 2 << 1; -use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1; - -# compression method - -# these two are the only ones supported in this module -use constant COMPRESSION_STORED => 0; # file is stored (no compression) -use constant COMPRESSION_DEFLATED => 8; # file is Deflated -use constant COMPRESSION_LEVEL_NONE => 0; -use constant COMPRESSION_LEVEL_DEFAULT => -1; -use constant COMPRESSION_LEVEL_FASTEST => 1; -use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9; - -# internal file attribute bits -# Found in Archive::Zip::Member::internalFileAttributes() - -use constant IFA_TEXT_FILE_MASK => 1; -use constant IFA_TEXT_FILE => 1; -use constant IFA_BINARY_FILE => 0; - -# PKZIP file format miscellaneous constants (for internal use only) -use constant SIGNATURE_FORMAT => "V"; -use constant SIGNATURE_LENGTH => 4; - -# these lengths are without the signature. -use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50; -use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2"; -use constant LOCAL_FILE_HEADER_LENGTH => 26; - -# PKZIP docs don't mention the signature, but Info-Zip writes it. -use constant DATA_DESCRIPTOR_SIGNATURE => 0x08074b50; -use constant DATA_DESCRIPTOR_FORMAT => "V3"; -use constant DATA_DESCRIPTOR_LENGTH => 12; - -# but the signature is apparently optional. -use constant DATA_DESCRIPTOR_FORMAT_NO_SIG => "V2"; -use constant DATA_DESCRIPTOR_LENGTH_NO_SIG => 8; - -use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50; -use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2"; -use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42; - -use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50; -use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING => - pack( "V", END_OF_CENTRAL_DIRECTORY_SIGNATURE ); -use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v"; -use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18; - -use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1; -use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2; -use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5; - -# the rest of these are not supported in this module -use constant COMPRESSION_SHRUNK => 1; # file is Shrunk -use constant COMPRESSION_REDUCED_1 => 2; # file is Reduced CF=1 -use constant COMPRESSION_REDUCED_2 => 3; # file is Reduced CF=2 -use constant COMPRESSION_REDUCED_3 => 4; # file is Reduced CF=3 -use constant COMPRESSION_REDUCED_4 => 5; # file is Reduced CF=4 -use constant COMPRESSION_IMPLODED => 6; # file is Imploded -use constant COMPRESSION_TOKENIZED => 7; # reserved for Tokenizing compr. -use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating -use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10; - -# Load the various required classes -require Archive::Zip::Archive; -require Archive::Zip::Member; -require Archive::Zip::FileMember; -require Archive::Zip::DirectoryMember; -require Archive::Zip::ZipFileMember; -require Archive::Zip::NewFileMember; -require Archive::Zip::StringMember; - -use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive'; -use constant ZIPMEMBERCLASS => 'Archive::Zip::Member'; - -# Convenience functions - -sub _ISA ($$) { - # Can't rely on Scalar::Util, so use the next best way - local $@; - !! eval { ref $_[0] and $_[0]->isa($_[1]) }; -} - -sub _CAN ($$) { - local $@; - !! eval { ref $_[0] and $_[0]->can($_[1]) }; -} - - - - - -##################################################################### -# Methods - -sub new { - my $class = shift; - return $class->ZIPARCHIVECLASS->new(@_); -} - -sub computeCRC32 { - my ( $data, $crc ); - - if ( ref( $_[0] ) eq 'HASH' ) { - $data = $_[0]->{string}; - $crc = $_[0]->{checksum}; - } - else { - $data = shift; - $data = shift if ref($data); - $crc = shift; - } - - return Compress::Raw::Zlib::crc32( $data, $crc ); -} - -# Report or change chunk size used for reading and writing. -# Also sets Zlib's default buffer size (eventually). -sub setChunkSize { - shift if ref( $_[0] ) eq 'Archive::Zip::Archive'; - my $chunkSize = ( ref( $_[0] ) eq 'HASH' ) ? shift->{chunkSize} : shift; - my $oldChunkSize = $Archive::Zip::ChunkSize; - $Archive::Zip::ChunkSize = $chunkSize if ($chunkSize); - return $oldChunkSize; -} - -sub chunkSize { - return $Archive::Zip::ChunkSize; -} - -sub setErrorHandler { - my $errorHandler = ( ref( $_[0] ) eq 'HASH' ) ? shift->{subroutine} : shift; - $errorHandler = \&Carp::carp unless defined($errorHandler); - my $oldErrorHandler = $Archive::Zip::ErrorHandler; - $Archive::Zip::ErrorHandler = $errorHandler; - return $oldErrorHandler; -} - - - - - -###################################################################### -# Private utility functions (not methods). - -sub _printError { - my $string = join ( ' ', @_, "\n" ); - my $oldCarpLevel = $Carp::CarpLevel; - $Carp::CarpLevel += 2; - &{$ErrorHandler} ($string); - $Carp::CarpLevel = $oldCarpLevel; -} - -# This is called on format errors. -sub _formatError { - shift if ref( $_[0] ); - _printError( 'format error:', @_ ); - return AZ_FORMAT_ERROR; -} - -# This is called on IO errors. -sub _ioError { - shift if ref( $_[0] ); - _printError( 'IO error:', @_, ':', $! ); - return AZ_IO_ERROR; -} - -# This is called on generic errors. -sub _error { - shift if ref( $_[0] ); - _printError( 'error:', @_ ); - return AZ_ERROR; -} - -# Called when a subclass should have implemented -# something but didn't -sub _subclassResponsibility { - Carp::croak("subclass Responsibility\n"); -} - -# Try to set the given file handle or object into binary mode. -sub _binmode { - my $fh = shift; - return _CAN( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh); -} - -# Attempt to guess whether file handle is seekable. -# Because of problems with Windows, this only returns true when -# the file handle is a real file. -sub _isSeekable { - my $fh = shift; - return 0 unless ref $fh; - if ( _ISA($fh, 'IO::Scalar') ) { - # IO::Scalar objects are brokenly-seekable - return 0; - } - if ( _ISA($fh, 'IO::String') ) { - return 1; - } - if ( _ISA($fh, 'IO::Seekable') ) { - # Unfortunately, some things like FileHandle objects - # return true for Seekable, but AREN'T!!!!! - if ( _ISA($fh, 'FileHandle') ) { - return 0; - } else { - return 1; - } - } - if ( _CAN($fh, 'stat') ) { - return -f $fh; - } - return ( - _CAN($fh, 'seek') and _CAN($fh, 'tell') - ) ? 1 : 0; -} - -# Print to the filehandle, while making sure the pesky Perl special global -# variables don't interfere. -sub _print -{ - my ($self, $fh, @data) = @_; - - local $\; - - return $fh->print(@data); -} - -# Return an opened IO::Handle -# my ( $status, fh ) = _newFileHandle( 'fileName', 'w' ); -# Can take a filename, file handle, or ref to GLOB -# Or, if given something that is a ref but not an IO::Handle, -# passes back the same thing. -sub _newFileHandle { - my $fd = shift; - my $status = 1; - my $handle; - - if ( ref($fd) ) { - if ( _ISA($fd, 'IO::Scalar') or _ISA($fd, 'IO::String') ) { - $handle = $fd; - } elsif ( _ISA($fd, 'IO::Handle') or ref($fd) eq 'GLOB' ) { - $handle = IO::File->new; - $status = $handle->fdopen( $fd, @_ ); - } else { - $handle = $fd; - } - } else { - $handle = IO::File->new; - $status = $handle->open( $fd, @_ ); - } - - return ( $status, $handle ); -} - -# Returns next signature from given file handle, leaves -# file handle positioned afterwards. -# In list context, returns ($status, $signature) -# ( $status, $signature) = _readSignature( $fh, $fileName ); - -sub _readSignature { - my $fh = shift; - my $fileName = shift; - my $expectedSignature = shift; # optional - - my $signatureData; - my $bytesRead = $fh->read( $signatureData, SIGNATURE_LENGTH ); - if ( $bytesRead != SIGNATURE_LENGTH ) { - return _ioError("reading header signature"); - } - my $signature = unpack( SIGNATURE_FORMAT, $signatureData ); - my $status = AZ_OK; - - # compare with expected signature, if any, or any known signature. - if ( ( defined($expectedSignature) && $signature != $expectedSignature ) - || ( !defined($expectedSignature) - && $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE - && $signature != LOCAL_FILE_HEADER_SIGNATURE - && $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE - && $signature != DATA_DESCRIPTOR_SIGNATURE ) ) - { - my $errmsg = sprintf( "bad signature: 0x%08x", $signature ); - if ( _isSeekable($fh) ) - { - $errmsg .= - sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH ); - } - - $status = _formatError("$errmsg in file $fileName"); - } - - return ( $status, $signature ); -} - -# Utility method to make and open a temp file. -# Will create $temp_dir if it doesn't exist. -# Returns file handle and name: -# -# my ($fh, $name) = Archive::Zip::tempFile(); -# my ($fh, $name) = Archive::Zip::tempFile('mytempdir'); -# - -sub tempFile { - my $dir = ( ref( $_[0] ) eq 'HASH' ) ? shift->{tempDir} : shift; - my ( $fh, $filename ) = File::Temp::tempfile( - SUFFIX => '.zip', - UNLINK => 0, # we will delete it! - $dir ? ( DIR => $dir ) : () - ); - return ( undef, undef ) unless $fh; - my ( $status, $newfh ) = _newFileHandle( $fh, 'w+' ); - return ( $newfh, $filename ); -} - -# Return the normalized directory name as used in a zip file (path -# separators become slashes, etc.). -# Will translate internal slashes in path components (i.e. on Macs) to -# underscores. Discards volume names. -# When $forceDir is set, returns paths with trailing slashes (or arrays -# with trailing blank members). -# -# If third argument is a reference, returns volume information there. -# -# input output -# . ('.') '.' -# ./a ('a') a -# ./a/b ('a','b') a/b -# ./a/b/ ('a','b') a/b -# a/b/ ('a','b') a/b -# /a/b/ ('','a','b') /a/b -# c:\a\b\c.doc ('','a','b','c.doc') /a/b/c.doc # on Windoze -# "i/o maps:whatever" ('i_o maps', 'whatever') "i_o maps/whatever" # on Macs -sub _asZipDirName -{ - my $name = shift; - my $forceDir = shift; - my $volReturn = shift; - my ( $volume, $directories, $file ) = - File::Spec->splitpath( File::Spec->canonpath($name), $forceDir ); - $$volReturn = $volume if ( ref($volReturn) ); - my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories); - if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component - push ( @dirs, defined($file) ? $file : '' ); - #return wantarray ? @dirs : join ( '/', @dirs ); - return join ( '/', @dirs ); -} - -# Return an absolute local name for a zip name. -# Assume a directory if zip name has trailing slash. -# Takes an optional volume name in FS format (like 'a:'). -# -sub _asLocalName -{ - my $name = shift; # zip format - my $volume = shift; - $volume = '' unless defined($volume); # local FS format - - my @paths = split ( /\//, $name ); - my $filename = pop (@paths); - $filename = '' unless defined($filename); - my $localDirs = @paths ? File::Spec->catdir(@paths) : ''; - my $localName = File::Spec->catpath( $volume, $localDirs, $filename ); - unless ( $volume ) { - $localName = File::Spec->rel2abs( $localName, Cwd::getcwd() ); - } - return $localName; -} - -1; - -__END__ - -=pod - -=head1 NAME - -Archive::Zip - Provide an interface to ZIP archive files. - -=head1 SYNOPSIS - - # Create a Zip file - use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); - my $zip = Archive::Zip->new(); - - # Add a directory - my $dir_member = $zip->addDirectory( 'dirname/' ); - - # Add a file from a string with compression - my $string_member = $zip->addString( 'This is a test', 'stringMember.txt' ); - $string_member->desiredCompressionMethod( COMPRESSION_DEFLATED ); - - # Add a file from disk - my $file_member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' ); - - # Save the Zip file - unless ( $zip->writeToFileNamed('someZip.zip') == AZ_OK ) { - die 'write error'; - } - - # Read a Zip file - my $somezip = Archive::Zip->new(); - unless ( $somezip->read( 'someZip.zip' ) == AZ_OK ) { - die 'read error'; - } - - # Change the compression type for a file in the Zip - my $member = $somezip->memberNamed( 'stringMember.txt' ); - $member->desiredCompressionMethod( COMPRESSION_STORED ); - unless ( $zip->writeToFileNamed( 'someOtherZip.zip' ) == AZ_OK ) { - die 'write error'; - } - -=head1 DESCRIPTION - -The Archive::Zip module allows a Perl program to create, manipulate, read, -and write Zip archive files. - -Zip archives can be created, or you can read from existing zip files. - -Once created, they can be written to files, streams, or strings. Members -can be added, removed, extracted, replaced, rearranged, and enumerated. -They can also be renamed or have their dates, comments, or other attributes -queried or modified. Their data can be compressed or uncompressed as needed. - -Members can be created from members in existing Zip files, or from existing -directories, files, or strings. - -This module uses the L<Compress::Raw::Zlib> library to read and write the -compressed streams inside the files. - -One can use L<Archive::Zip::MemberRead> to read the zip file archive members -as if they were files. - -=head2 File Naming - -Regardless of what your local file system uses for file naming, names in a -Zip file are in Unix format (I<forward> slashes (/) separating directory -names, etc.). - -C<Archive::Zip> tries to be consistent with file naming conventions, and will -translate back and forth between native and Zip file names. - -However, it can't guess which format names are in. So two rules control what -kind of file name you must pass various routines: - -=over 4 - -=item Names of files are in local format. - -C<File::Spec> and C<File::Basename> are used for various file -operations. When you're referring to a file on your system, use its -file naming conventions. - -=item Names of archive members are in Unix format. - -This applies to every method that refers to an archive member, or -provides a name for new archive members. The C<extract()> methods -that can take one or two names will convert from local to zip names -if you call them with a single name. - -=back - -=head2 Archive::Zip Object Model - -=head2 Overview - -Archive::Zip::Archive objects are what you ordinarily deal with. -These maintain the structure of a zip file, without necessarily -holding data. When a zip is read from a disk file, the (possibly -compressed) data still lives in the file, not in memory. Archive -members hold information about the individual members, but not -(usually) the actual member data. When the zip is written to a -(different) file, the member data is compressed or copied as needed. -It is possible to make archive members whose data is held in a string -in memory, but this is not done when a zip file is read. Directory -members don't have any data. - -=head2 Inheritance - - Exporter - Archive::Zip Common base class, has defs. - Archive::Zip::Archive A Zip archive. - Archive::Zip::Member Abstract superclass for all members. - Archive::Zip::StringMember Member made from a string - Archive::Zip::FileMember Member made from an external file - Archive::Zip::ZipFileMember Member that lives in a zip file - Archive::Zip::NewFileMember Member whose data is in a file - Archive::Zip::DirectoryMember Member that is a directory - -=head1 EXPORTS - -=over 4 - -=item :CONSTANTS - -Exports the following constants: - -FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK -GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK -COMPRESSION_STORED COMPRESSION_DEFLATED IFA_TEXT_FILE_MASK -IFA_TEXT_FILE IFA_BINARY_FILE COMPRESSION_LEVEL_NONE -COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST -COMPRESSION_LEVEL_BEST_COMPRESSION - -=item :MISC_CONSTANTS - -Exports the following constants (only necessary for extending the -module): - -FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST FA_OS2_HPFS -FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS -GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK -GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK -GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK -DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM -DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST -COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3 -COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED -COMPRESSION_DEFLATED_ENHANCED -COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED - -=item :ERROR_CODES - -Explained below. Returned from most methods. - -AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR - -=back - -=head1 ERROR CODES - -Many of the methods in Archive::Zip return error codes. These are implemented -as inline subroutines, using the C<use constant> pragma. They can be imported -into your namespace using the C<:ERROR_CODES> tag: - - use Archive::Zip qw( :ERROR_CODES ); - - ... - - unless ( $zip->read( 'myfile.zip' ) == AZ_OK ) { - die "whoops!"; - } - -=over 4 - -=item AZ_OK (0) - -Everything is fine. - -=item AZ_STREAM_END (1) - -The read stream (or central directory) ended normally. - -=item AZ_ERROR (2) - -There was some generic kind of error. - -=item AZ_FORMAT_ERROR (3) - -There is a format error in a ZIP file being read. - -=item AZ_IO_ERROR (4) - -There was an IO error. - -=back - -=head2 Compression - -Archive::Zip allows each member of a ZIP file to be compressed (using the -Deflate algorithm) or uncompressed. - -Other compression algorithms that some versions of ZIP have been able to -produce are not supported. Each member has two compression methods: the -one it's stored as (this is always COMPRESSION_STORED for string and external -file members), and the one you desire for the member in the zip file. - -These can be different, of course, so you can make a zip member that is not -compressed out of one that is, and vice versa. - -You can inquire about the current compression and set the desired -compression method: - - my $member = $zip->memberNamed( 'xyz.txt' ); - $member->compressionMethod(); # return current compression - - # set to read uncompressed - $member->desiredCompressionMethod( COMPRESSION_STORED ); - - # set to read compressed - $member->desiredCompressionMethod( COMPRESSION_DEFLATED ); - -There are two different compression methods: - -=over 4 - -=item COMPRESSION_STORED - -File is stored (no compression) - -=item COMPRESSION_DEFLATED - -File is Deflated - -=back - -=head2 Compression Levels - -If a member's desiredCompressionMethod is COMPRESSION_DEFLATED, you -can choose different compression levels. This choice may affect the -speed of compression and decompression, as well as the size of the -compressed member data. - - $member->desiredCompressionLevel( 9 ); - -The levels given can be: - -=over 4 - -=item 0 or COMPRESSION_LEVEL_NONE - -This is the same as saying - - $member->desiredCompressionMethod( COMPRESSION_STORED ); - -=item 1 .. 9 - -1 gives the best speed and worst compression, and 9 gives the -best compression and worst speed. - -=item COMPRESSION_LEVEL_FASTEST - -This is a synonym for level 1. - -=item COMPRESSION_LEVEL_BEST_COMPRESSION - -This is a synonym for level 9. - -=item COMPRESSION_LEVEL_DEFAULT - -This gives a good compromise between speed and compression, -and is currently equivalent to 6 (this is in the zlib code). -This is the level that will be used if not specified. - -=back - -=head1 Archive::Zip Methods - -The Archive::Zip class (and its invisible subclass Archive::Zip::Archive) -implement generic zip file functionality. Creating a new Archive::Zip object -actually makes an Archive::Zip::Archive object, but you don't have to worry -about this unless you're subclassing. - -=head2 Constructor - -=over 4 - -=item new( [$fileName] ) - -Make a new, empty zip archive. - - my $zip = Archive::Zip->new(); - -If an additional argument is passed, new() will call read() -to read the contents of an archive: - - my $zip = Archive::Zip->new( 'xyz.zip' ); - -If a filename argument is passed and the read fails for any -reason, new will return undef. For this reason, it may be -better to call read separately. - -=back - -=head2 Zip Archive Utility Methods - -These Archive::Zip methods may be called as functions or as object -methods. Do not call them as class methods: - - $zip = Archive::Zip->new(); - $crc = Archive::Zip::computeCRC32( 'ghijkl' ); # OK - $crc = $zip->computeCRC32( 'ghijkl' ); # also OK - $crc = Archive::Zip->computeCRC32( 'ghijkl' ); # NOT OK - -=over 4 - -=item Archive::Zip::computeCRC32( $string [, $crc] ) - -This is a utility function that uses the Compress::Raw::Zlib CRC -routine to compute a CRC-32. You can get the CRC of a string: - - $crc = Archive::Zip::computeCRC32( $string ); - -Or you can compute the running CRC: - - $crc = 0; - $crc = Archive::Zip::computeCRC32( 'abcdef', $crc ); - $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc ); - -=item Archive::Zip::setChunkSize( $number ) - -Report or change chunk size used for reading and writing. -This can make big differences in dealing with large files. -Currently, this defaults to 32K. This also changes the chunk -size used for Compress::Raw::Zlib. You must call setChunkSize() -before reading or writing. This is not exportable, so you -must call it like: - - Archive::Zip::setChunkSize( 4096 ); - -or as a method on a zip (though this is a global setting). -Returns old chunk size. - -=item Archive::Zip::chunkSize() - -Returns the current chunk size: - - my $chunkSize = Archive::Zip::chunkSize(); - -=item Archive::Zip::setErrorHandler( \&subroutine ) - -Change the subroutine called with error strings. This -defaults to \&Carp::carp, but you may want to change it to -get the error strings. This is not exportable, so you must -call it like: - - Archive::Zip::setErrorHandler( \&myErrorHandler ); - -If myErrorHandler is undef, resets handler to default. -Returns old error handler. Note that if you call Carp::carp -or a similar routine or if you're chaining to the default -error handler from your error handler, you may want to -increment the number of caller levels that are skipped (do -not just set it to a number): - - $Carp::CarpLevel++; - -=item Archive::Zip::tempFile( [$tmpdir] ) - -Create a uniquely named temp file. It will be returned open -for read/write. If C<$tmpdir> is given, it is used as the -name of a directory to create the file in. If not given, -creates the file using C<File::Spec::tmpdir()>. Generally, you can -override this choice using the - - $ENV{TMPDIR} - -environment variable. But see the L<File::Spec|File::Spec> -documentation for your system. Note that on many systems, if you're -running in taint mode, then you must make sure that C<$ENV{TMPDIR}> is -untainted for it to be used. -Will I<NOT> create C<$tmpdir> if it doesn't exist (this is a change -from prior versions!). Returns file handle and name: - - my ($fh, $name) = Archive::Zip::tempFile(); - my ($fh, $name) = Archive::Zip::tempFile('myTempDir'); - my $fh = Archive::Zip::tempFile(); # if you don't need the name - -=back - -=head2 Zip Archive Accessors - -=over 4 - -=item members() - -Return a copy of the members array - - my @members = $zip->members(); - -=item numberOfMembers() - -Return the number of members I have - -=item memberNames() - -Return a list of the (internal) file names of the zip members - -=item memberNamed( $string ) - -Return ref to member whose filename equals given filename or -undef. C<$string> must be in Zip (Unix) filename format. - -=item membersMatching( $regex ) - -Return array of members whose filenames match given regular -expression in list context. Returns number of matching -members in scalar context. - - my @textFileMembers = $zip->membersMatching( '.*\.txt' ); - # or - my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' ); - -=item diskNumber() - -Return the disk that I start on. Not used for writing zips, -but might be interesting if you read a zip in. This should be -0, as Archive::Zip does not handle multi-volume archives. - -=item diskNumberWithStartOfCentralDirectory() - -Return the disk number that holds the beginning of the -central directory. Not used for writing zips, but might be -interesting if you read a zip in. This should be 0, as -Archive::Zip does not handle multi-volume archives. - -=item numberOfCentralDirectoriesOnThisDisk() - -Return the number of CD structures in the zipfile last read in. -Not used for writing zips, but might be interesting if you read a zip -in. - -=item numberOfCentralDirectories() - -Return the number of CD structures in the zipfile last read in. -Not used for writing zips, but might be interesting if you read a zip -in. - -=item centralDirectorySize() - -Returns central directory size, as read from an external zip -file. Not used for writing zips, but might be interesting if -you read a zip in. - -=item centralDirectoryOffsetWRTStartingDiskNumber() - -Returns the offset into the zip file where the CD begins. Not -used for writing zips, but might be interesting if you read a -zip in. - -=item zipfileComment( [$string] ) - -Get or set the zipfile comment. Returns the old comment. - - print $zip->zipfileComment(); - $zip->zipfileComment( 'New Comment' ); - -=item eocdOffset() - -Returns the (unexpected) number of bytes between where the -EOCD was found and where it expected to be. This is normally -0, but would be positive if something (a virus, perhaps) had -added bytes somewhere before the EOCD. Not used for writing -zips, but might be interesting if you read a zip in. Here is -an example of how you can diagnose this: - - my $zip = Archive::Zip->new('somefile.zip'); - if ($zip->eocdOffset()) - { - warn "A virus has added ", $zip->eocdOffset, " bytes of garbage\n"; - } - -The C<eocdOffset()> is used to adjust the starting position of member -headers, if necessary. - -=item fileName() - -Returns the name of the file last read from. If nothing has -been read yet, returns an empty string; if read from a file -handle, returns the handle in string form. - -=back - -=head2 Zip Archive Member Operations - -Various operations on a zip file modify members. When a member is -passed as an argument, you can either use a reference to the member -itself, or the name of a member. Of course, using the name requires -that names be unique within a zip (this is not enforced). - -=over 4 - -=item removeMember( $memberOrName ) - -Remove and return the given member, or match its name and -remove it. Returns undef if member or name doesn't exist in this -Zip. No-op if member does not belong to this zip. - -=item replaceMember( $memberOrName, $newMember ) - -Remove and return the given member, or match its name and -remove it. Replace with new member. Returns undef if member or -name doesn't exist in this Zip, or if C<$newMember> is undefined. - -It is an (undiagnosed) error to provide a C<$newMember> that is a -member of the zip being modified. - - my $member1 = $zip->removeMember( 'xyz' ); - my $member2 = $zip->replaceMember( 'abc', $member1 ); - # now, $member2 (named 'abc') is not in $zip, - # and $member1 (named 'xyz') is, having taken $member2's place. - -=item extractMember( $memberOrName [, $extractedName ] ) - -Extract the given member, or match its name and extract it. -Returns undef if member doesn't exist in this Zip. If -optional second arg is given, use it as the name of the -extracted member. Otherwise, the internal filename of the -member is used as the name of the extracted file or -directory. -If you pass C<$extractedName>, it should be in the local file -system's format. -All necessary directories will be created. Returns C<AZ_OK> -on success. - -=item extractMemberWithoutPaths( $memberOrName [, $extractedName ] ) - -Extract the given member, or match its name and extract it. -Does not use path information (extracts into the current -directory). Returns undef if member doesn't exist in this -Zip. -If optional second arg is given, use it as the name of the -extracted member (its paths will be deleted too). Otherwise, -the internal filename of the member (minus paths) is used as -the name of the extracted file or directory. Returns C<AZ_OK> -on success. - -=item addMember( $member ) - -Append a member (possibly from another zip file) to the zip -file. Returns the new member. Generally, you will use -addFile(), addDirectory(), addFileOrDirectory(), addString(), -or read() to add members. - - # Move member named 'abc' to end of zip: - my $member = $zip->removeMember( 'abc' ); - $zip->addMember( $member ); - -=item updateMember( $memberOrName, $fileName ) - -Update a single member from the file or directory named C<$fileName>. -Returns the (possibly added or updated) member, if any; C<undef> on -errors. -The comparison is based on C<lastModTime()> and (in the case of a -non-directory) the size of the file. - -=item addFile( $fileName [, $newName ] ) - -Append a member whose data comes from an external file, -returning the member or undef. The member will have its file -name set to the name of the external file, and its -desiredCompressionMethod set to COMPRESSION_DEFLATED. The -file attributes and last modification time will be set from -the file. -If the name given does not represent a readable plain file or -symbolic link, undef will be returned. C<$fileName> must be -in the format required for the local file system. -The optional C<$newName> argument sets the internal file name -to something different than the given $fileName. C<$newName>, -if given, must be in Zip name format (i.e. Unix). -The text mode bit will be set if the contents appears to be -text (as returned by the C<-T> perl operator). - - -I<NOTE> that you shouldn't (generally) use absolute path names -in zip member names, as this will cause problems with some zip -tools as well as introduce a security hole and make the zip -harder to use. - -=item addDirectory( $directoryName [, $fileName ] ) - - - -Append a member created from the given directory name. The -directory name does not have to name an existing directory. -If the named directory exists, the file modification time and -permissions are set from the existing directory, otherwise -they are set to now and permissive default permissions. -C<$directoryName> must be in local file system format. -The optional second argument sets the name of the archive -member (which defaults to C<$directoryName>). If given, it -must be in Zip (Unix) format. -Returns the new member. - -=item addFileOrDirectory( $name [, $newName ] ) - - - -Append a member from the file or directory named $name. If -$newName is given, use it for the name of the new member. -Will add or remove trailing slashes from $newName as needed. -C<$name> must be in local file system format. -The optional second argument sets the name of the archive -member (which defaults to C<$name>). If given, it must be in -Zip (Unix) format. - -=item addString( $stringOrStringRef, $name ) - - - -Append a member created from the given string or string -reference. The name is given by the second argument. -Returns the new member. The last modification time will be -set to now, and the file attributes will be set to permissive -defaults. - - my $member = $zip->addString( 'This is a test', 'test.txt' ); - -=item contents( $memberOrMemberName [, $newContents ] ) - - - -Returns the uncompressed data for a particular member, or -undef. - - print "xyz.txt contains " . $zip->contents( 'xyz.txt' ); - -Also can change the contents of a member: - - $zip->contents( 'xyz.txt', 'This is the new contents' ); - -If called expecting an array as the return value, it will include -the status as the second value in the array. - - ($content, $status) = $zip->contents( 'xyz.txt'); - -=back - -=head2 Zip Archive I/O operations - - -A Zip archive can be written to a file or file handle, or read from -one. - -=over 4 - -=item writeToFileNamed( $fileName ) - - - -Write a zip archive to named file. Returns C<AZ_OK> on -success. - - my $status = $zip->writeToFileNamed( 'xx.zip' ); - die "error somewhere" if $status != AZ_OK; - -Note that if you use the same name as an existing zip file -that you read in, you will clobber ZipFileMembers. So -instead, write to a different file name, then delete the -original. -If you use the C<overwrite()> or C<overwriteAs()> methods, you can -re-write the original zip in this way. -C<$fileName> should be a valid file name on your system. - -=item writeToFileHandle( $fileHandle [, $seekable] ) - -Write a zip archive to a file handle. Return AZ_OK on -success. The optional second arg tells whether or not to try -to seek backwards to re-write headers. If not provided, it is -set if the Perl C<-f> test returns true. This could fail on -some operating systems, though. - - my $fh = IO::File->new( 'someFile.zip', 'w' ); - unless ( $zip->writeToFileHandle( $fh ) == AZ_OK ) { - # error handling - } - -If you pass a file handle that is not seekable (like if -you're writing to a pipe or a socket), pass a false second -argument: - - my $fh = IO::File->new( '| cat > somefile.zip', 'w' ); - $zip->writeToFileHandle( $fh, 0 ); # fh is not seekable - -If this method fails during the write of a member, that -member and all following it will return false from -C<wasWritten()>. See writeCentralDirectory() for a way to -deal with this. -If you want, you can write data to the file handle before -passing it to writeToFileHandle(); this could be used (for -instance) for making self-extracting archives. However, this -only works reliably when writing to a real file (as opposed -to STDOUT or some other possible non-file). - -See examples/selfex.pl for how to write a self-extracting -archive. - -=item writeCentralDirectory( $fileHandle [, $offset ] ) - -Writes the central directory structure to the given file -handle. - -Returns AZ_OK on success. If given an $offset, will -seek to that point before writing. This can be used for -recovery in cases where writeToFileHandle or writeToFileNamed -returns an IO error because of running out of space on the -destination file. - -You can truncate the zip by seeking backwards and then writing the -directory: - - my $fh = IO::File->new( 'someFile.zip', 'w' ); - my $retval = $zip->writeToFileHandle( $fh ); - if ( $retval == AZ_IO_ERROR ) { - my @unwritten = grep { not $_->wasWritten() } $zip->members(); - if (@unwritten) { - $zip->removeMember( $member ) foreach my $member ( @unwritten ); - $zip->writeCentralDirectory( $fh, - $unwritten[0]->writeLocalHeaderRelativeOffset()); - } - } - -=item overwriteAs( $newName ) - -Write the zip to the specified file, as safely as possible. -This is done by first writing to a temp file, then renaming -the original if it exists, then renaming the temp file, then -deleting the renamed original if it exists. Returns AZ_OK if -successful. - -=item overwrite() - -Write back to the original zip file. See overwriteAs() above. -If the zip was not ever read from a file, this generates an -error. - -=item read( $fileName ) - -Read zipfile headers from a zip file, appending new members. -Returns C<AZ_OK> or error code. - - my $zipFile = Archive::Zip->new(); - my $status = $zipFile->read( '/some/FileName.zip' ); - -=item readFromFileHandle( $fileHandle, $filename ) - -Read zipfile headers from an already-opened file handle, -appending new members. Does not close the file handle. -Returns C<AZ_OK> or error code. Note that this requires a -seekable file handle; reading from a stream is not yet -supported. - - my $fh = IO::File->new( '/some/FileName.zip', 'r' ); - my $zip1 = Archive::Zip->new(); - my $status = $zip1->readFromFileHandle( $fh ); - my $zip2 = Archive::Zip->new(); - $status = $zip2->readFromFileHandle( $fh ); - -=back - -=head2 Zip Archive Tree operations - -These used to be in Archive::Zip::Tree but got moved into -Archive::Zip. They enable operation on an entire tree of members or -files. -A usage example: - - use Archive::Zip; - my $zip = Archive::Zip->new(); - - # add all readable files and directories below . as xyz/* - $zip->addTree( '.', 'xyz' ); - - # add all readable plain files below /abc as def/* - $zip->addTree( '/abc', 'def', sub { -f && -r } ); - - # add all .c files below /tmp as stuff/* - $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' ); - - # add all .o files below /tmp as stuff/* if they aren't writable - $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } ); - - # add all .so files below /tmp that are smaller than 200 bytes as stuff/* - $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } ); - - # and write them into a file - $zip->writeToFileNamed('xxx.zip'); - - # now extract the same files into /tmpx - $zip->extractTree( 'stuff', '/tmpx' ); - -=over 4 - -=item $zip->addTree( $root, $dest [,$pred] ) -- Add tree of files to a zip - -C<$root> is the root of the tree of files and directories to be -added. It is a valid directory name on your system. C<$dest> is -the name for the root in the zip file (undef or blank means -to use relative pathnames). It is a valid ZIP directory name -(that is, it uses forward slashes (/) for separating -directory components). C<$pred> is an optional subroutine -reference to select files: it is passed the name of the -prospective file or directory using C<$_>, and if it returns -true, the file or directory will be included. The default is -to add all readable files and directories. For instance, -using - - my $pred = sub { /\.txt/ }; - $zip->addTree( '.', '', $pred ); - -will add all the .txt files in and below the current -directory, using relative names, and making the names -identical in the zipfile: - - original name zip member name - ./xyz xyz - ./a/ a/ - ./a/b a/b - -To translate absolute to relative pathnames, just pass them -in: $zip->addTree( '/c/d', 'a' ); - - original name zip member name - /c/d/xyz a/xyz - /c/d/a/ a/a/ - /c/d/a/b a/a/b - -Returns AZ_OK on success. Note that this will not follow -symbolic links to directories. Note also that this does not -check for the validity of filenames. - -Note that you generally I<don't> want to make zip archive member names -absolute. - -=item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] ) - -$root is the root of the tree of files and directories to be -added $dest is the name for the root in the zip file (undef -means to use relative pathnames) $pattern is a (non-anchored) -regular expression for filenames to match $pred is an -optional subroutine reference to select files: it is passed -the name of the prospective file or directory in C<$_>, and -if it returns true, the file or directory will be included. -The default is to add all readable files and directories. To -add all files in and below the current dirctory whose names -end in C<.pl>, and make them extract into a subdirectory -named C<xyz>, do this: - - $zip->addTreeMatching( '.', 'xyz', '\.pl$' ) - -To add all I<writable> files in and below the dirctory named -C</abc> whose names end in C<.pl>, and make them extract into -a subdirectory named C<xyz>, do this: - - $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } ) - -Returns AZ_OK on success. Note that this will not follow -symbolic links to directories. - -=item $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] ); - - - -Update a zip file from a directory tree. - -C<updateTree()> takes the same arguments as C<addTree()>, but first -checks to see whether the file or directory already exists in the zip -file, and whether it has been changed. - -If the fourth argument C<$mirror> is true, then delete all my members -if corresponding files weren't found. - - -Returns an error code or AZ_OK if all is well. - -=item $zip->extractTree() - - - -=item $zip->extractTree( $root ) - - - -=item $zip->extractTree( $root, $dest ) - - - -=item $zip->extractTree( $root, $dest, $volume ) - - - -If you don't give any arguments at all, will extract all the -files in the zip with their original names. - - -If you supply one argument for C<$root>, C<extractTree> will extract -all the members whose names start with C<$root> into the current -directory, stripping off C<$root> first. -C<$root> is in Zip (Unix) format. -For instance, - - $zip->extractTree( 'a' ); - -when applied to a zip containing the files: -a/x a/b/c ax/d/e d/e will extract: - - -a/x as ./x - - -a/b/c as ./b/c - - -If you give two arguments, C<extractTree> extracts all the members -whose names start with C<$root>. It will translate C<$root> into -C<$dest> to construct the destination file name. -C<$root> and C<$dest> are in Zip (Unix) format. -For instance, - - $zip->extractTree( 'a', 'd/e' ); - -when applied to a zip containing the files: -a/x a/b/c ax/d/e d/e will extract: - - -a/x to d/e/x - - -a/b/c to d/e/b/c and ignore ax/d/e and d/e - - -If you give three arguments, C<extractTree> extracts all the members -whose names start with C<$root>. It will translate C<$root> into -C<$dest> to construct the destination file name, and then it will -convert to local file system format, using C<$volume> as the name of -the destination volume. - - -C<$root> and C<$dest> are in Zip (Unix) format. - - -C<$volume> is in local file system format. - - -For instance, under Windows, - - $zip->extractTree( 'a', 'd/e', 'f:' ); - -when applied to a zip containing the files: -a/x a/b/c ax/d/e d/e will extract: - - -a/x to f:d/e/x - - -a/b/c to f:d/e/b/c and ignore ax/d/e and d/e - - -If you want absolute paths (the prior example used paths relative to -the current directory on the destination volume, you can specify these -in C<$dest>: - - $zip->extractTree( 'a', '/d/e', 'f:' ); - -when applied to a zip containing the files: -a/x a/b/c ax/d/e d/e will extract: - - -a/x to f:\d\e\x - - -a/b/c to f:\d\e\b\c and ignore ax/d/e and d/e - -Returns an error code or AZ_OK if everything worked OK. - -=back - -=head1 MEMBER OPERATIONS - - -=head2 Member Class Methods - - -Several constructors allow you to construct members without adding -them to a zip archive. These work the same as the addFile(), -addDirectory(), and addString() zip instance methods described above, -but they don't add the new members to a zip. - -=over 4 - -=item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName] ) - - - -Construct a new member from the given string. Returns undef -on error. - - my $member = Archive::Zip::Member->newFromString( 'This is a test', - 'xyz.txt' ); - -=item newFromFile( $fileName ) - - - -Construct a new member from the given file. Returns undef on -error. - - my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' ); - -=item newDirectoryNamed( $directoryName [, $zipname ] ) - - - -Construct a new member from the given directory. -C<$directoryName> must be a valid name on your file system; it doesn't -have to exist. - - -If given, C<$zipname> will be the name of the zip member; it must be a -valid Zip (Unix) name. If not given, it will be converted from -C<$directoryName>. - - -Returns undef on error. - - my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' ); - -=back - -=head2 Member Simple accessors - - -These methods get (and/or set) member attribute values. - -=over 4 - -=item versionMadeBy() - - - -Gets the field from the member header. - -=item fileAttributeFormat( [$format] ) - - - -Gets or sets the field from the member header. These are -C<FA_*> values. - -=item versionNeededToExtract() - - - -Gets the field from the member header. - -=item bitFlag() - - - -Gets the general purpose bit field from the member header. -This is where the C<GPBF_*> bits live. - -=item compressionMethod() - - - -Returns the member compression method. This is the method -that is currently being used to compress the member data. -This will be COMPRESSION_STORED for added string or file -members, or any of the C<COMPRESSION_*> values for members -from a zip file. However, this module can only handle members -whose data is in COMPRESSION_STORED or COMPRESSION_DEFLATED -format. - -=item desiredCompressionMethod( [$method] ) - - - -Get or set the member's C<desiredCompressionMethod>. This is -the compression method that will be used when the member is -written. Returns prior desiredCompressionMethod. Only -COMPRESSION_DEFLATED or COMPRESSION_STORED are valid -arguments. Changing to COMPRESSION_STORED will change the -member desiredCompressionLevel to 0; changing to -COMPRESSION_DEFLATED will change the member -desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT. - -=item desiredCompressionLevel( [$method] ) - - - -Get or set the member's desiredCompressionLevel This is the -method that will be used to write. Returns prior -desiredCompressionLevel. Valid arguments are 0 through 9, -COMPRESSION_LEVEL_NONE, COMPRESSION_LEVEL_DEFAULT, -COMPRESSION_LEVEL_BEST_COMPRESSION, and -COMPRESSION_LEVEL_FASTEST. 0 or COMPRESSION_LEVEL_NONE will -change the desiredCompressionMethod to COMPRESSION_STORED. -All other arguments will change the desiredCompressionMethod -to COMPRESSION_DEFLATED. - -=item externalFileName() - - - -Return the member's external file name, if any, or undef. - -=item fileName() - - - -Get or set the member's internal filename. Returns the -(possibly new) filename. Names will have backslashes -converted to forward slashes, and will have multiple -consecutive slashes converted to single ones. - -=item lastModFileDateTime() - - - -Return the member's last modification date/time stamp in -MS-DOS format. - -=item lastModTime() - - - -Return the member's last modification date/time stamp, -converted to unix localtime format. - - print "Mod Time: " . scalar( localtime( $member->lastModTime() ) ); - -=item setLastModFileDateTimeFromUnix() - -Set the member's lastModFileDateTime from the given unix -time. - - $member->setLastModFileDateTimeFromUnix( time() ); - -=item internalFileAttributes() - -Return the internal file attributes field from the zip -header. This is only set for members read from a zip file. - -=item externalFileAttributes() - -Return member attributes as read from the ZIP file. Note that -these are NOT UNIX! - -=item unixFileAttributes( [$newAttributes] ) - -Get or set the member's file attributes using UNIX file -attributes. Returns old attributes. - - my $oldAttribs = $member->unixFileAttributes( 0666 ); - -Note that the return value has more than just the file -permissions, so you will have to mask off the lowest bits for -comparisions. - -=item localExtraField( [$newField] ) - -Gets or sets the extra field that was read from the local -header. This is not set for a member from a zip file until -after the member has been written out. The extra field must -be in the proper format. - -=item cdExtraField( [$newField] ) - -Gets or sets the extra field that was read from the central -directory header. The extra field must be in the proper -format. - -=item extraFields() - -Return both local and CD extra fields, concatenated. - -=item fileComment( [$newComment] ) - -Get or set the member's file comment. - -=item hasDataDescriptor() - -Get or set the data descriptor flag. If this is set, the -local header will not necessarily have the correct data -sizes. Instead, a small structure will be stored at the end -of the member data with these values. This should be -transparent in normal operation. - -=item crc32() - -Return the CRC-32 value for this member. This will not be set -for members that were constructed from strings or external -files until after the member has been written. - -=item crc32String() - -Return the CRC-32 value for this member as an 8 character -printable hex string. This will not be set for members that -were constructed from strings or external files until after -the member has been written. - -=item compressedSize() - -Return the compressed size for this member. This will not be -set for members that were constructed from strings or -external files until after the member has been written. - -=item uncompressedSize() - -Return the uncompressed size for this member. - -=item isEncrypted() - -Return true if this member is encrypted. The Archive::Zip -module does not currently create or extract encrypted -members. - -=item isTextFile( [$flag] ) - -Returns true if I am a text file. Also can set the status if -given an argument (then returns old state). Note that this -module does not currently do anything with this flag upon -extraction or storage. That is, bytes are stored in native -format whether or not they came from a text file. - -=item isBinaryFile() - -Returns true if I am a binary file. Also can set the status -if given an argument (then returns old state). Note that this -module does not currently do anything with this flag upon -extraction or storage. That is, bytes are stored in native -format whether or not they came from a text file. - -=item extractToFileNamed( $fileName ) - -Extract me to a file with the given name. The file will be -created with default modes. Directories will be created as -needed. -The C<$fileName> argument should be a valid file name on your -file system. -Returns AZ_OK on success. - -=item isDirectory() - -Returns true if I am a directory. - -=item writeLocalHeaderRelativeOffset() - -Returns the file offset in bytes the last time I was written. - -=item wasWritten() - -Returns true if I was successfully written. Reset at the -beginning of a write attempt. - -=back - -=head2 Low-level member data reading - -It is possible to use lower-level routines to access member data -streams, rather than the extract* methods and contents(). For -instance, here is how to print the uncompressed contents of a member -in chunks using these methods: - - my ( $member, $status, $bufferRef ); - $member = $zip->memberNamed( 'xyz.txt' ); - $member->desiredCompressionMethod( COMPRESSION_STORED ); - $status = $member->rewindData(); - die "error $status" unless $status == AZ_OK; - while ( ! $member->readIsDone() ) - { - ( $bufferRef, $status ) = $member->readChunk(); - die "error $status" - if $status != AZ_OK && $status != AZ_STREAM_END; - # do something with $bufferRef: - print $$bufferRef; - } - $member->endRead(); - -=over 4 - -=item readChunk( [$chunkSize] ) - -This reads the next chunk of given size from the member's -data stream and compresses or uncompresses it as necessary, -returning a reference to the bytes read and a status. If size -argument is not given, defaults to global set by -Archive::Zip::setChunkSize. Status is AZ_OK on success until -the last chunk, where it returns AZ_STREAM_END. Returns C<( -\$bytes, $status)>. - - my ( $outRef, $status ) = $self->readChunk(); - print $$outRef if $status != AZ_OK && $status != AZ_STREAM_END; - -=item rewindData() - -Rewind data and set up for reading data streams or writing -zip files. Can take options for C<inflateInit()> or -C<deflateInit()>, but this isn't likely to be necessary. -Subclass overrides should call this method. Returns C<AZ_OK> -on success. - -=item endRead() - -Reset the read variables and free the inflater or deflater. -Must be called to close files, etc. Returns AZ_OK on success. - -=item readIsDone() - -Return true if the read has run out of data or errored out. - -=item contents() - -Return the entire uncompressed member data or undef in scalar -context. When called in array context, returns C<( $string, -$status )>; status will be AZ_OK on success: - - my $string = $member->contents(); - # or - my ( $string, $status ) = $member->contents(); - die "error $status" unless $status == AZ_OK; - -Can also be used to set the contents of a member (this may -change the class of the member): - - $member->contents( "this is my new contents" ); - -=item extractToFileHandle( $fh ) - -Extract (and uncompress, if necessary) the member's contents -to the given file handle. Return AZ_OK on success. - -=back - -=head1 Archive::Zip::FileMember methods - -The Archive::Zip::FileMember class extends Archive::Zip::Member. It is the -base class for both ZipFileMember and NewFileMember classes. This class adds -an C<externalFileName> and an C<fh> member to keep track of the external -file. - -=over 4 - -=item externalFileName() - -Return the member's external filename. - -=item fh() - -Return the member's read file handle. Automatically opens file if -necessary. - -=back - -=head1 Archive::Zip::ZipFileMember methods - -The Archive::Zip::ZipFileMember class represents members that have been read -from external zip files. - -=over 4 - -=item diskNumberStart() - -Returns the disk number that the member's local header resides in. -Should be 0. - -=item localHeaderRelativeOffset() - -Returns the offset into the zip file where the member's local header -is. - -=item dataOffset() - -Returns the offset from the beginning of the zip file to the member's -data. - -=back - -=head1 REQUIRED MODULES - -L<Archive::Zip> requires several other modules: - -L<Carp> - -L<Compress::Raw::Zlib> - -L<Cwd> - -L<File::Basename> - -L<File::Copy> - -L<File::Find> - -L<File::Path> - -L<File::Spec> - -L<IO::File> - -L<IO::Seekable> - -L<Time::Local> - -=head1 BUGS AND CAVEATS - -=head2 When not to use Archive::Zip - -If you are just going to be extracting zips (and/or other archives) you -are recommended to look at using L<Archive::Extract> instead, as it is much -easier to use and factors out archive-specific functionality. - -=head2 Try to avoid IO::Scalar - -One of the most common ways to use Archive::Zip is to generate Zip files -in-memory. Most people have use L<IO::Scalar> for this purpose. - -Unfortunately, as of 1.11 this module no longer works with L<IO::Scalar> -as it incorrectly implements seeking. - -Anybody using L<IO::Scalar> should consider porting to L<IO::String>, -which is smaller, lighter, and is implemented to be perfectly compatible -with regular seekable filehandles. - -Support for L<IO::Scalar> most likely will B<not> be restored in the -future, as L<IO::Scalar> itself cannot change the way it is implemented -due to back-compatibility issues. - -=head1 TO DO - -* auto-choosing storing vs compression - -* extra field hooks (see notes.txt) - -* check for dups on addition/renaming? - -* Text file extraction (line end translation) - -* Reading zip files from non-seekable inputs - (Perhaps by proxying through IO::String?) - -* separate unused constants into separate module - -* cookbook style docs - -* Handle tainted paths correctly - -* Work on better compatability with other IO:: modules - -=head1 SUPPORT - -Bugs should be reported via the CPAN bug tracker - -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Archive-Zip> - -For other issues contact the maintainer - -=head1 AUTHOR - -Adam Kennedy E<lt>adamk@cpan.orgE<gt> - -Previously maintained by Steve Peters E<lt>steve@fisharerojo.orgE<gt>. - -File attributes code by Maurice Aubrey E<lt>maurice@lovelyfilth.comE<gt>. - -Originally by Ned Konz E<lt>nedkonz@cpan.orgE<gt>. - -=head1 COPYRIGHT - -Some parts copyright 2006 - 2009 Adam Kennedy. - -Some parts copyright 2005 Steve Peters. - -Original work copyright 2000 - 2004 Ned Konz. - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 SEE ALSO - -Look at L<Archive::Zip::MemberRead> which is a wrapper that allows one to -read Zip archive members as if they were files. - -L<Compress::Raw::Zlib>, L<Archive::Tar>, L<Archive::Extract> - -There is a Japanese translation of this -document at L<http://www.memb.jp/~deq/perl/doc-ja/Archive-Zip.html> -that was done by DEQ E<lt>deq@oct.zaq.ne.jpE<gt> . Thanks! - -=cut diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/Archive.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/Archive.pm deleted file mode 100755 index d9fd02e5e02..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/Archive.pm +++ /dev/null @@ -1,978 +0,0 @@ -package Archive::Zip::Archive; - -# Represents a generic ZIP archive - -use strict; -use File::Path; -use File::Find (); -use File::Spec (); -use File::Copy (); -use File::Basename; -use Cwd; - -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw( Archive::Zip ); -} - -use Archive::Zip qw( - :CONSTANTS - :ERROR_CODES - :PKZIP_CONSTANTS - :UTILITY_METHODS -); - -# Note that this returns undef on read errors, else new zip object. - -sub new { - my $class = shift; - my $self = bless( - { - 'diskNumber' => 0, - 'diskNumberWithStartOfCentralDirectory' => 0, - 'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members - 'numberOfCentralDirectories' => 0, # shld be # of members - 'centralDirectorySize' => 0, # must re-compute on write - 'centralDirectoryOffsetWRTStartingDiskNumber' => - 0, # must re-compute - 'writeEOCDOffset' => 0, - 'writeCentralDirectoryOffset' => 0, - 'zipfileComment' => '', - 'eocdOffset' => 0, - 'fileName' => '' - }, - $class - ); - $self->{'members'} = []; - my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift; - if ($fileName) { - my $status = $self->read($fileName); - return $status == AZ_OK ? $self : undef; - } - return $self; -} - -sub storeSymbolicLink { - my $self = shift; - $self->{'storeSymbolicLink'} = shift; -} - -sub members { - @{ shift->{'members'} }; -} - -sub numberOfMembers { - scalar( shift->members() ); -} - -sub memberNames { - my $self = shift; - return map { $_->fileName() } $self->members(); -} - -# return ref to member with given name or undef -sub memberNamed { - my $self = shift; - my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{zipName} : shift; - foreach my $member ( $self->members() ) { - return $member if $member->fileName() eq $fileName; - } - return undef; -} - -sub membersMatching { - my $self = shift; - my $pattern = ( ref( $_[0] ) eq 'HASH' ) ? shift->{regex} : shift; - return grep { $_->fileName() =~ /$pattern/ } $self->members(); -} - -sub diskNumber { - shift->{'diskNumber'}; -} - -sub diskNumberWithStartOfCentralDirectory { - shift->{'diskNumberWithStartOfCentralDirectory'}; -} - -sub numberOfCentralDirectoriesOnThisDisk { - shift->{'numberOfCentralDirectoriesOnThisDisk'}; -} - -sub numberOfCentralDirectories { - shift->{'numberOfCentralDirectories'}; -} - -sub centralDirectorySize { - shift->{'centralDirectorySize'}; -} - -sub centralDirectoryOffsetWRTStartingDiskNumber { - shift->{'centralDirectoryOffsetWRTStartingDiskNumber'}; -} - -sub zipfileComment { - my $self = shift; - my $comment = $self->{'zipfileComment'}; - if (@_) { - my $new_comment = ( ref( $_[0] ) eq 'HASH' ) ? shift->{comment} : shift; - $self->{'zipfileComment'} = pack( 'C0a*', $new_comment ); # avoid unicode - } - return $comment; -} - -sub eocdOffset { - shift->{'eocdOffset'}; -} - -# Return the name of the file last read. -sub fileName { - shift->{'fileName'}; -} - -sub removeMember { - my $self = shift; - my $member = ( ref( $_[0] ) eq 'HASH' ) ? shift->{memberOrZipName} : shift; - $member = $self->memberNamed($member) unless ref($member); - return undef unless $member; - my @newMembers = grep { $_ != $member } $self->members(); - $self->{'members'} = \@newMembers; - return $member; -} - -sub replaceMember { - my $self = shift; - - my ( $oldMember, $newMember ); - if ( ref( $_[0] ) eq 'HASH' ) { - $oldMember = $_[0]->{memberOrZipName}; - $newMember = $_[0]->{newMember}; - } - else { - ( $oldMember, $newMember ) = @_; - } - - $oldMember = $self->memberNamed($oldMember) unless ref($oldMember); - return undef unless $oldMember; - return undef unless $newMember; - my @newMembers = - map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members(); - $self->{'members'} = \@newMembers; - return $oldMember; -} - -sub extractMember { - my $self = shift; - - my ( $member, $name ); - if ( ref( $_[0] ) eq 'HASH' ) { - $member = $_[0]->{memberOrZipName}; - $name = $_[0]->{name}; - } - else { - ( $member, $name ) = @_; - } - - $member = $self->memberNamed($member) unless ref($member); - return _error('member not found') unless $member; - my $originalSize = $member->compressedSize(); - my ( $volumeName, $dirName, $fileName ); - if ( defined($name) ) { - ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name); - $dirName = File::Spec->catpath( $volumeName, $dirName, '' ); - } - else { - $name = $member->fileName(); - ( $dirName = $name ) =~ s{[^/]*$}{}; - $dirName = Archive::Zip::_asLocalName($dirName); - $name = Archive::Zip::_asLocalName($name); - } - if ( $dirName && !-d $dirName ) { - mkpath($dirName); - return _ioError("can't create dir $dirName") if ( !-d $dirName ); - } - my $rc = $member->extractToFileNamed( $name, @_ ); - - # TODO refactor this fix into extractToFileNamed() - $member->{'compressedSize'} = $originalSize; - return $rc; -} - -sub extractMemberWithoutPaths { - my $self = shift; - - my ( $member, $name ); - if ( ref( $_[0] ) eq 'HASH' ) { - $member = $_[0]->{memberOrZipName}; - $name = $_[0]->{name}; - } - else { - ( $member, $name ) = @_; - } - - $member = $self->memberNamed($member) unless ref($member); - return _error('member not found') unless $member; - my $originalSize = $member->compressedSize(); - return AZ_OK if $member->isDirectory(); - unless ($name) { - $name = $member->fileName(); - $name =~ s{.*/}{}; # strip off directories, if any - $name = Archive::Zip::_asLocalName($name); - } - my $rc = $member->extractToFileNamed( $name, @_ ); - $member->{'compressedSize'} = $originalSize; - return $rc; -} - -sub addMember { - my $self = shift; - my $newMember = ( ref( $_[0] ) eq 'HASH' ) ? shift->{member} : shift; - push( @{ $self->{'members'} }, $newMember ) if $newMember; - return $newMember; -} - -sub addFile { - my $self = shift; - - my ( $fileName, $newName, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $fileName = $_[0]->{filename}; - $newName = $_[0]->{zipName}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $fileName, $newName, $compressionLevel ) = @_; - } - - my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName ); - $newMember->desiredCompressionLevel($compressionLevel); - if ( $self->{'storeSymbolicLink'} && -l $fileName ) { - my $newMember = $self->ZIPMEMBERCLASS->newFromString(readlink $fileName, $newName); - # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP - $newMember->{'externalFileAttributes'} = 0xA1FF0000; - $self->addMember($newMember); - } else { - $self->addMember($newMember); - } - return $newMember; -} - -sub addString { - my $self = shift; - - my ( $stringOrStringRef, $name, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $stringOrStringRef = $_[0]->{string}; - $name = $_[0]->{zipName}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $stringOrStringRef, $name, $compressionLevel ) = @_;; - } - - my $newMember = $self->ZIPMEMBERCLASS->newFromString( - $stringOrStringRef, $name - ); - $newMember->desiredCompressionLevel($compressionLevel); - return $self->addMember($newMember); -} - -sub addDirectory { - my $self = shift; - - my ( $name, $newName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $name = $_[0]->{directoryName}; - $newName = $_[0]->{zipName}; - } - else { - ( $name, $newName ) = @_; - } - - my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName ); - if ( $self->{'storeSymbolicLink'} && -l $name ) { - my $link = readlink $name; - ( $newName =~ s{/$}{} ) if $newName; # Strip trailing / - my $newMember = $self->ZIPMEMBERCLASS->newFromString($link, $newName); - # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP - $newMember->{'externalFileAttributes'} = 0xA1FF0000; - $self->addMember($newMember); - } else { - $self->addMember($newMember); - } - return $newMember; -} - -# add either a file or a directory. - -sub addFileOrDirectory { - my $self = shift; - - my ( $name, $newName, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $name = $_[0]->{name}; - $newName = $_[0]->{zipName}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $name, $newName, $compressionLevel ) = @_; - } - - $name =~ s{/$}{}; - if ( $newName ) { - $newName =~ s{/$}{}; - } else { - $newName = $name; - } - if ( -f $name ) { - return $self->addFile( $name, $newName, $compressionLevel ); - } - elsif ( -d $name ) { - return $self->addDirectory( $name, $newName ); - } - else { - return _error("$name is neither a file nor a directory"); - } -} - -sub contents { - my $self = shift; - - my ( $member, $newContents ); - if ( ref( $_[0] ) eq 'HASH' ) { - $member = $_[0]->{memberOrZipName}; - $newContents = $_[0]->{contents}; - } - else { - ( $member, $newContents ) = @_; - } - - return _error('No member name given') unless $member; - $member = $self->memberNamed($member) unless ref($member); - return undef unless $member; - return $member->contents($newContents); -} - -sub writeToFileNamed { - my $self = shift; - my $fileName = - ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift; # local FS format - foreach my $member ( $self->members() ) { - if ( $member->_usesFileNamed($fileName) ) { - return _error( "$fileName is needed by member " - . $member->fileName() - . "; consider using overwrite() or overwriteAs() instead." ); - } - } - my ( $status, $fh ) = _newFileHandle( $fileName, 'w' ); - return _ioError("Can't open $fileName for write") unless $status; - my $retval = $self->writeToFileHandle( $fh, 1 ); - $fh->close(); - $fh = undef; - - return $retval; -} - -# It is possible to write data to the FH before calling this, -# perhaps to make a self-extracting archive. -sub writeToFileHandle { - my $self = shift; - - my ( $fh, $fhIsSeekable ); - if ( ref( $_[0] ) eq 'HASH' ) { - $fh = $_[0]->{fileHandle}; - $fhIsSeekable = - exists( $_[0]->{seek} ) ? $_[0]->{seek} : _isSeekable($fh); - } - else { - $fh = shift; - $fhIsSeekable = @_ ? shift : _isSeekable($fh); - } - - return _error('No filehandle given') unless $fh; - return _ioError('filehandle not open') unless $fh->opened(); - _binmode($fh); - - # Find out where the current position is. - my $offset = $fhIsSeekable ? $fh->tell() : 0; - $offset = 0 if $offset < 0; - - foreach my $member ( $self->members() ) { - my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset ); - $member->endRead(); - return $retval if $retval != AZ_OK; - $offset += $member->_localHeaderSize() + $member->_writeOffset(); - $offset += - $member->hasDataDescriptor() - ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH - : 0; - - # changed this so it reflects the last successful position - $self->{'writeCentralDirectoryOffset'} = $offset; - } - return $self->writeCentralDirectory($fh); -} - -# Write zip back to the original file, -# as safely as possible. -# Returns AZ_OK if successful. -sub overwrite { - my $self = shift; - return $self->overwriteAs( $self->{'fileName'} ); -} - -# Write zip to the specified file, -# as safely as possible. -# Returns AZ_OK if successful. -sub overwriteAs { - my $self = shift; - my $zipName = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{filename} : shift; - return _error("no filename in overwriteAs()") unless defined($zipName); - - my ( $fh, $tempName ) = Archive::Zip::tempFile(); - return _error( "Can't open temp file", $! ) unless $fh; - - ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk}; - - my $status = $self->writeToFileHandle($fh); - $fh->close(); - $fh = undef; - - if ( $status != AZ_OK ) { - unlink($tempName); - _printError("Can't write to $tempName"); - return $status; - } - - my $err; - - # rename the zip - if ( -f $zipName && !rename( $zipName, $backupName ) ) { - $err = $!; - unlink($tempName); - return _error( "Can't rename $zipName as $backupName", $err ); - } - - # move the temp to the original name (possibly copying) - unless ( File::Copy::move( $tempName, $zipName ) ) { - $err = $!; - rename( $backupName, $zipName ); - unlink($tempName); - return _error( "Can't move $tempName to $zipName", $err ); - } - - # unlink the backup - if ( -f $backupName && !unlink($backupName) ) { - $err = $!; - return _error( "Can't unlink $backupName", $err ); - } - - return AZ_OK; -} - -# Used only during writing -sub _writeCentralDirectoryOffset { - shift->{'writeCentralDirectoryOffset'}; -} - -sub _writeEOCDOffset { - shift->{'writeEOCDOffset'}; -} - -# Expects to have _writeEOCDOffset() set -sub _writeEndOfCentralDirectory { - my ( $self, $fh ) = @_; - - $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING) - or return _ioError('writing EOCD Signature'); - my $zipfileCommentLength = length( $self->zipfileComment() ); - - my $header = pack( - END_OF_CENTRAL_DIRECTORY_FORMAT, - 0, # {'diskNumber'}, - 0, # {'diskNumberWithStartOfCentralDirectory'}, - $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'}, - $self->numberOfMembers(), # {'numberOfCentralDirectories'}, - $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(), - $self->_writeCentralDirectoryOffset(), - $zipfileCommentLength - ); - $self->_print($fh, $header) - or return _ioError('writing EOCD header'); - if ($zipfileCommentLength) { - $self->_print($fh, $self->zipfileComment() ) - or return _ioError('writing zipfile comment'); - } - return AZ_OK; -} - -# $offset can be specified to truncate a zip file. -sub writeCentralDirectory { - my $self = shift; - - my ( $fh, $offset ); - if ( ref( $_[0] ) eq 'HASH' ) { - $fh = $_[0]->{fileHandle}; - $offset = $_[0]->{offset}; - } - else { - ( $fh, $offset ) = @_; - } - - if ( defined($offset) ) { - $self->{'writeCentralDirectoryOffset'} = $offset; - $fh->seek( $offset, IO::Seekable::SEEK_SET ) - or return _ioError('seeking to write central directory'); - } - else { - $offset = $self->_writeCentralDirectoryOffset(); - } - - foreach my $member ( $self->members() ) { - my $status = $member->_writeCentralDirectoryFileHeader($fh); - return $status if $status != AZ_OK; - $offset += $member->_centralDirectoryHeaderSize(); - $self->{'writeEOCDOffset'} = $offset; - } - return $self->_writeEndOfCentralDirectory($fh); -} - -sub read { - my $self = shift; - my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift; - return _error('No filename given') unless $fileName; - my ( $status, $fh ) = _newFileHandle( $fileName, 'r' ); - return _ioError("opening $fileName for read") unless $status; - - $status = $self->readFromFileHandle( $fh, $fileName ); - return $status if $status != AZ_OK; - - $fh->close(); - $self->{'fileName'} = $fileName; - return AZ_OK; -} - -sub readFromFileHandle { - my $self = shift; - - my ( $fh, $fileName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $fh = $_[0]->{fileHandle}; - $fileName = $_[0]->{filename}; - } - else { - ( $fh, $fileName ) = @_; - } - - $fileName = $fh unless defined($fileName); - return _error('No filehandle given') unless $fh; - return _ioError('filehandle not open') unless $fh->opened(); - - _binmode($fh); - $self->{'fileName'} = "$fh"; - - # TODO: how to support non-seekable zips? - return _error('file not seekable') - unless _isSeekable($fh); - - $fh->seek( 0, 0 ); # rewind the file - - my $status = $self->_findEndOfCentralDirectory($fh); - return $status if $status != AZ_OK; - - my $eocdPosition = $fh->tell(); - - $status = $self->_readEndOfCentralDirectory($fh); - return $status if $status != AZ_OK; - - $fh->seek( $eocdPosition - $self->centralDirectorySize(), - IO::Seekable::SEEK_SET ) - or return _ioError("Can't seek $fileName"); - - # Try to detect garbage at beginning of archives - # This should be 0 - $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here - - $self->centralDirectoryOffsetWRTStartingDiskNumber(); - - for ( ; ; ) { - my $newMember = - $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName, - $self->eocdOffset() ); - my $signature; - ( $status, $signature ) = _readSignature( $fh, $fileName ); - return $status if $status != AZ_OK; - last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE; - $status = $newMember->_readCentralDirectoryFileHeader(); - return $status if $status != AZ_OK; - $status = $newMember->endRead(); - return $status if $status != AZ_OK; - $newMember->_becomeDirectoryIfNecessary(); - push( @{ $self->{'members'} }, $newMember ); - } - - return AZ_OK; -} - -# Read EOCD, starting from position before signature. -# Return AZ_OK on success. -sub _readEndOfCentralDirectory { - my $self = shift; - my $fh = shift; - - # Skip past signature - $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR ) - or return _ioError("Can't seek past EOCD signature"); - - my $header = ''; - my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH ); - if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH ) { - return _ioError("reading end of central directory"); - } - - my $zipfileCommentLength; - ( - $self->{'diskNumber'}, - $self->{'diskNumberWithStartOfCentralDirectory'}, - $self->{'numberOfCentralDirectoriesOnThisDisk'}, - $self->{'numberOfCentralDirectories'}, - $self->{'centralDirectorySize'}, - $self->{'centralDirectoryOffsetWRTStartingDiskNumber'}, - $zipfileCommentLength - ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header ); - - if ($zipfileCommentLength) { - my $zipfileComment = ''; - $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength ); - if ( $bytesRead != $zipfileCommentLength ) { - return _ioError("reading zipfile comment"); - } - $self->{'zipfileComment'} = $zipfileComment; - } - - return AZ_OK; -} - -# Seek in my file to the end, then read backwards until we find the -# signature of the central directory record. Leave the file positioned right -# before the signature. Returns AZ_OK if success. -sub _findEndOfCentralDirectory { - my $self = shift; - my $fh = shift; - my $data = ''; - $fh->seek( 0, IO::Seekable::SEEK_END ) - or return _ioError("seeking to end"); - - my $fileLength = $fh->tell(); - if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) { - return _formatError("file is too short"); - } - - my $seekOffset = 0; - my $pos = -1; - for ( ; ; ) { - $seekOffset += 512; - $seekOffset = $fileLength if ( $seekOffset > $fileLength ); - $fh->seek( -$seekOffset, IO::Seekable::SEEK_END ) - or return _ioError("seek failed"); - my $bytesRead = $fh->read( $data, $seekOffset ); - if ( $bytesRead != $seekOffset ) { - return _ioError("read failed"); - } - $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING ); - last - if ( $pos >= 0 - or $seekOffset == $fileLength - or $seekOffset >= $Archive::Zip::ChunkSize ); - } - - if ( $pos >= 0 ) { - $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR ) - or return _ioError("seeking to EOCD"); - return AZ_OK; - } - else { - return _formatError("can't find EOCD signature"); - } -} - -# Used to avoid taint problems when chdir'ing. -# Not intended to increase security in any way; just intended to shut up the -T -# complaints. If your Cwd module is giving you unreliable returns from cwd() -# you have bigger problems than this. -sub _untaintDir { - my $dir = shift; - $dir =~ m/\A(.+)\z/s; - return $1; -} - -sub addTree { - my $self = shift; - - my ( $root, $dest, $pred, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $root = $_[0]->{root}; - $dest = $_[0]->{zipName}; - $pred = $_[0]->{select}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $root, $dest, $pred, $compressionLevel ) = @_; - } - - return _error("root arg missing in call to addTree()") - unless defined($root); - $dest = '' unless defined($dest); - $pred = sub { -r } unless defined($pred); - - my @files; - my $startDir = _untaintDir( cwd() ); - - return _error( 'undef returned by _untaintDir on cwd ', cwd() ) - unless $startDir; - - # This avoids chdir'ing in Find, in a way compatible with older - # versions of File::Find. - my $wanted = sub { - local $main::_ = $File::Find::name; - my $dir = _untaintDir($File::Find::dir); - chdir($startDir); - push( @files, $File::Find::name ) if (&$pred); - chdir($dir); - }; - - File::Find::find( $wanted, $root ); - - my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash - my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E"; - - $dest = _asZipDirName( $dest, 1 ); # with trailing slash - - foreach my $fileName (@files) { - my $isDir = -d $fileName; - - # normalize, remove leading ./ - my $archiveName = _asZipDirName( $fileName, $isDir ); - if ( $archiveName eq $rootZipName ) { $archiveName = $dest } - else { $archiveName =~ s{$pattern}{$dest} } - next if $archiveName =~ m{^\.?/?$}; # skip current dir - my $member = $isDir - ? $self->addDirectory( $fileName, $archiveName ) - : $self->addFile( $fileName, $archiveName ); - $member->desiredCompressionLevel($compressionLevel); - - return _error("add $fileName failed in addTree()") if !$member; - } - return AZ_OK; -} - -sub addTreeMatching { - my $self = shift; - - my ( $root, $dest, $pattern, $pred, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $root = $_[0]->{root}; - $dest = $_[0]->{zipName}; - $pattern = $_[0]->{pattern}; - $pred = $_[0]->{select}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $root, $dest, $pattern, $pred, $compressionLevel ) = @_; - } - - return _error("root arg missing in call to addTreeMatching()") - unless defined($root); - $dest = '' unless defined($dest); - return _error("pattern missing in call to addTreeMatching()") - unless defined($pattern); - my $matcher = - $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r }; - return $self->addTree( $root, $dest, $matcher, $compressionLevel ); -} - -# $zip->extractTree( $root, $dest [, $volume] ); -# -# $root and $dest are Unix-style. -# $volume is in local FS format. -# -sub extractTree { - my $self = shift; - - my ( $root, $dest, $volume ); - if ( ref( $_[0] ) eq 'HASH' ) { - $root = $_[0]->{root}; - $dest = $_[0]->{zipName}; - $volume = $_[0]->{volume}; - } - else { - ( $root, $dest, $volume ) = @_; - } - - $root = '' unless defined($root); - $dest = './' unless defined($dest); - my $pattern = "^\Q$root"; - my @members = $self->membersMatching($pattern); - - foreach my $member (@members) { - my $fileName = $member->fileName(); # in Unix format - $fileName =~ s{$pattern}{$dest}; # in Unix format - # convert to platform format: - $fileName = Archive::Zip::_asLocalName( $fileName, $volume ); - my $status = $member->extractToFileNamed($fileName); - return $status if $status != AZ_OK; - } - return AZ_OK; -} - -# $zip->updateMember( $memberOrName, $fileName ); -# Returns (possibly updated) member, if any; undef on errors. - -sub updateMember { - my $self = shift; - - my ( $oldMember, $fileName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $oldMember = $_[0]->{memberOrZipName}; - $fileName = $_[0]->{name}; - } - else { - ( $oldMember, $fileName ) = @_; - } - - if ( !defined($fileName) ) { - _error("updateMember(): missing fileName argument"); - return undef; - } - - my @newStat = stat($fileName); - if ( !@newStat ) { - _ioError("Can't stat $fileName"); - return undef; - } - - my $isDir = -d _; - - my $memberName; - - if ( ref($oldMember) ) { - $memberName = $oldMember->fileName(); - } - else { - $oldMember = $self->memberNamed( $memberName = $oldMember ) - || $self->memberNamed( $memberName = - _asZipDirName( $oldMember, $isDir ) ); - } - - unless ( defined($oldMember) - && $oldMember->lastModTime() == $newStat[9] - && $oldMember->isDirectory() == $isDir - && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) ) - { - - # create the new member - my $newMember = $isDir - ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName ) - : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName ); - - unless ( defined($newMember) ) { - _error("creation of member $fileName failed in updateMember()"); - return undef; - } - - # replace old member or append new one - if ( defined($oldMember) ) { - $self->replaceMember( $oldMember, $newMember ); - } - else { $self->addMember($newMember); } - - return $newMember; - } - - return $oldMember; -} - -# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] ); -# -# This takes the same arguments as addTree, but first checks to see -# whether the file or directory already exists in the zip file. -# -# If the fourth argument $mirror is true, then delete all my members -# if corresponding files weren't found. - -sub updateTree { - my $self = shift; - - my ( $root, $dest, $pred, $mirror, $compressionLevel ); - if ( ref( $_[0] ) eq 'HASH' ) { - $root = $_[0]->{root}; - $dest = $_[0]->{zipName}; - $pred = $_[0]->{select}; - $mirror = $_[0]->{mirror}; - $compressionLevel = $_[0]->{compressionLevel}; - } - else { - ( $root, $dest, $pred, $mirror, $compressionLevel ) = @_; - } - - return _error("root arg missing in call to updateTree()") - unless defined($root); - $dest = '' unless defined($dest); - $pred = sub { -r } unless defined($pred); - - $dest = _asZipDirName( $dest, 1 ); - my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash - my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E"; - - my @files; - my $startDir = _untaintDir( cwd() ); - - return _error( 'undef returned by _untaintDir on cwd ', cwd() ) - unless $startDir; - - # This avoids chdir'ing in Find, in a way compatible with older - # versions of File::Find. - my $wanted = sub { - local $main::_ = $File::Find::name; - my $dir = _untaintDir($File::Find::dir); - chdir($startDir); - push( @files, $File::Find::name ) if (&$pred); - chdir($dir); - }; - - File::Find::find( $wanted, $root ); - - # Now @files has all the files that I could potentially be adding to - # the zip. Only add the ones that are necessary. - # For each file (updated or not), add its member name to @done. - my %done; - foreach my $fileName (@files) { - my @newStat = stat($fileName); - my $isDir = -d _; - - # normalize, remove leading ./ - my $memberName = _asZipDirName( $fileName, $isDir ); - if ( $memberName eq $rootZipName ) { $memberName = $dest } - else { $memberName =~ s{$pattern}{$dest} } - next if $memberName =~ m{^\.?/?$}; # skip current dir - - $done{$memberName} = 1; - my $changedMember = $self->updateMember( $memberName, $fileName ); - $changedMember->desiredCompressionLevel($compressionLevel); - return _error("updateTree failed to update $fileName") - unless ref($changedMember); - } - - # @done now has the archive names corresponding to all the found files. - # If we're mirroring, delete all those members that aren't in @done. - if ($mirror) { - foreach my $member ( $self->members() ) { - $self->removeMember($member) - unless $done{ $member->fileName() }; - } - } - - return AZ_OK; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/BufferedFileHandle.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/BufferedFileHandle.pm deleted file mode 100755 index 4e56f9f007c..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/BufferedFileHandle.pm +++ /dev/null @@ -1,131 +0,0 @@ -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.30'; - $VERSION = eval $VERSION; -} - -sub new { - my $class = shift || __PACKAGE__; - $class = ref($class) || $class; - my $self = bless( - { - content => '', - position => 0, - size => 0 - }, - $class - ); - return $self; -} - -# Utility method to read entire file -sub readFromFile { - my $self = shift; - my $fileName = shift; - my $fh = IO::File->new( $fileName, "r" ); - CORE::binmode($fh); - if ( !$fh ) { - Carp::carp("Can't open $fileName: $!\n"); - return undef; - } - local $/ = undef; - $self->{content} = <$fh>; - $self->{size} = length( $self->{content} ); - return $self; -} - -sub contents { - my $self = shift; - if (@_) { - $self->{content} = shift; - $self->{size} = length( $self->{content} ); - } - return $self->{content}; -} - -sub binmode { 1 } - -sub close { 1 } - -sub opened { 1 } - -sub eof { - my $self = shift; - return $self->{position} >= $self->{size}; -} - -sub seek { - my $self = shift; - my $pos = shift; - my $whence = shift; - - # SEEK_SET - if ( $whence == 0 ) { $self->{position} = $pos; } - - # SEEK_CUR - elsif ( $whence == 1 ) { $self->{position} += $pos; } - - # SEEK_END - elsif ( $whence == 2 ) { $self->{position} = $self->{size} + $pos; } - else { return 0; } - - return 1; -} - -sub tell { return shift->{position}; } - -# Copy my data to given buffer -sub read { - my $self = shift; - my $buf = \( $_[0] ); - shift; - my $len = shift; - my $offset = shift || 0; - - $$buf = '' if not defined($$buf); - my $bytesRead = - ( $self->{position} + $len > $self->{size} ) - ? ( $self->{size} - $self->{position} ) - : $len; - substr( $$buf, $offset, $bytesRead ) = - substr( $self->{content}, $self->{position}, $bytesRead ); - $self->{position} += $bytesRead; - return $bytesRead; -} - -# Copy given buffer to me -sub write { - my $self = shift; - my $buf = \( $_[0] ); - shift; - my $len = shift; - my $offset = shift || 0; - - $$buf = '' if not defined($$buf); - my $bufLen = length($$buf); - my $bytesWritten = - ( $offset + $len > $bufLen ) - ? $bufLen - $offset - : $len; - substr( $self->{content}, $self->{position}, $bytesWritten ) = - substr( $$buf, $offset, $bytesWritten ); - $self->{size} = length( $self->{content} ); - return $bytesWritten; -} - -sub clearerr() { 1 } - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/DirectoryMember.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/DirectoryMember.pm deleted file mode 100755 index c9d3705f08f..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/DirectoryMember.pm +++ /dev/null @@ -1,80 +0,0 @@ -package Archive::Zip::DirectoryMember; - -use strict; -use File::Path; - -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw( Archive::Zip::Member ); -} - -use Archive::Zip qw( - :ERROR_CODES - :UTILITY_METHODS -); - -sub _newNamed { - my $class = shift; - my $fileName = shift; # FS name - my $newName = shift; # Zip name - $newName = _asZipDirName($fileName) unless $newName; - my $self = $class->new(@_); - $self->{'externalFileName'} = $fileName; - $self->fileName($newName); - - if ( -e $fileName ) { - - # -e does NOT do a full stat, so we need to do one now - if ( -d _ ) { - my @stat = stat(_); - $self->unixFileAttributes( $stat[2] ); - my $mod_t = $stat[9]; - if ( $^O eq 'MSWin32' and !$mod_t ) { - $mod_t = time(); - } - $self->setLastModFileDateTimeFromUnix($mod_t); - - } else { # hmm.. trying to add a non-directory? - _error( $fileName, ' exists but is not a directory' ); - return undef; - } - } else { - $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS ); - $self->setLastModFileDateTimeFromUnix( time() ); - } - return $self; -} - -sub externalFileName { - shift->{'externalFileName'}; -} - -sub isDirectory { - return 1; -} - -sub extractToFileNamed { - my $self = shift; - my $name = shift; # local FS name - my $attribs = $self->unixFileAttributes() & 07777; - mkpath( $name, 0, $attribs ); # croaks on error - utime( $self->lastModTime(), $self->lastModTime(), $name ); - return AZ_OK; -} - -sub fileName { - my $self = shift; - my $newName = shift; - $newName =~ s{/?$}{/} if defined($newName); - return $self->SUPER::fileName($newName); -} - -# So people don't get too confused. This way it looks like the problem -# is in their code... -sub contents { - return wantarray ? ( undef, AZ_OK ) : undef; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/FAQ.pod b/Master/tlpkg/tlperl/lib/Archive/Zip/FAQ.pod deleted file mode 100755 index 2b2d8ed9e88..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/FAQ.pod +++ /dev/null @@ -1,467 +0,0 @@ - -=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 isn't 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. - - -If that doesn't get rid of the problem, fix your computer or get rid of -Windows. - -=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 isn't currently supported, though writing to a stream is. diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/FileMember.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/FileMember.pm deleted file mode 100755 index a9b8cf5d7be..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/FileMember.pm +++ /dev/null @@ -1,64 +0,0 @@ -package Archive::Zip::FileMember; - -use strict; -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw ( Archive::Zip::Member ); -} - -use Archive::Zip qw( - :UTILITY_METHODS -); - -sub externalFileName { - shift->{'externalFileName'}; -} - -# Return true if I depend on the named file -sub _usesFileNamed { - my $self = shift; - my $fileName = shift; - my $xfn = $self->externalFileName(); - return undef if ref($xfn); - return $xfn eq $fileName; -} - -sub fh { - my $self = shift; - $self->_openFile() - if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened(); - return $self->{'fh'}; -} - -# opens my file handle from my file name -sub _openFile { - my $self = shift; - my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' ); - if ( !$status ) { - _ioError( "Can't open", $self->externalFileName() ); - return undef; - } - $self->{'fh'} = $fh; - _binmode($fh); - return $fh; -} - -# Make sure I close my file handle -sub endRead { - my $self = shift; - undef $self->{'fh'}; # _closeFile(); - return $self->SUPER::endRead(@_); -} - -sub _become { - my $self = shift; - my $newClass = shift; - return $self if ref($self) eq $newClass; - delete( $self->{'externalFileName'} ); - delete( $self->{'fh'} ); - return $self->SUPER::_become($newClass); -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/Member.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/Member.pm deleted file mode 100755 index f86ef75d55d..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/Member.pm +++ /dev/null @@ -1,1083 +0,0 @@ -package Archive::Zip::Member; - -# A generic membet of an archive - -use strict; -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw( Archive::Zip ); -} - -use Archive::Zip qw( - :CONSTANTS - :MISC_CONSTANTS - :ERROR_CODES - :PKZIP_CONSTANTS - :UTILITY_METHODS -); - -use Time::Local (); -use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS ); -use File::Path; -use File::Basename; - -use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember'; -use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember'; -use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember'; -use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember'; - -# Unix perms for default creation of files/dirs. -use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755; -use constant DEFAULT_FILE_PERMISSIONS => 0100666; -use constant DIRECTORY_ATTRIB => 040000; -use constant FILE_ATTRIB => 0100000; - -# Returns self if successful, else undef -# Assumes that fh is positioned at beginning of central directory file header. -# Leaves fh positioned immediately after file header or EOCD signature. -sub _newFromZipFile { - my $class = shift; - my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_); - return $self; -} - -sub newFromString { - my $class = shift; - - my ( $stringOrStringRef, $fileName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $stringOrStringRef = $_[0]->{string}; - $fileName = $_[0]->{zipName}; - } - else { - ( $stringOrStringRef, $fileName ) = @_; - } - - my $self = $class->STRINGMEMBERCLASS->_newFromString( $stringOrStringRef, - $fileName ); - return $self; -} - -sub newFromFile { - my $class = shift; - - my ( $fileName, $zipName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $fileName = $_[0]->{fileName}; - $zipName = $_[0]->{zipName}; - } - else { - ( $fileName, $zipName ) = @_; - } - - my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed( $fileName, - $zipName ); - return $self; -} - -sub newDirectoryNamed { - my $class = shift; - - my ( $directoryName, $newName ); - if ( ref( $_[0] ) eq 'HASH' ) { - $directoryName = $_[0]->{directoryName}; - $newName = $_[0]->{zipName}; - } - else { - ( $directoryName, $newName ) = @_; - } - - my $self = $class->DIRECTORYMEMBERCLASS->_newNamed( $directoryName, - $newName ); - return $self; -} - -sub new { - my $class = shift; - my $self = { - 'lastModFileDateTime' => 0, - 'fileAttributeFormat' => FA_UNIX, - 'versionMadeBy' => 20, - 'versionNeededToExtract' => 20, - 'bitFlag' => 0, - 'compressionMethod' => COMPRESSION_STORED, - 'desiredCompressionMethod' => COMPRESSION_STORED, - 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE, - 'internalFileAttributes' => 0, - 'externalFileAttributes' => 0, # set later - 'fileName' => '', - 'cdExtraField' => '', - 'localExtraField' => '', - 'fileComment' => '', - 'crc32' => 0, - 'compressedSize' => 0, - 'uncompressedSize' => 0, - 'isSymbolicLink' => 0, - @_ - }; - bless( $self, $class ); - $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS ); - return $self; -} - -sub _becomeDirectoryIfNecessary { - my $self = shift; - $self->_become(DIRECTORYMEMBERCLASS) - if $self->isDirectory(); - return $self; -} - -# Morph into given class (do whatever cleanup I need to do) -sub _become { - return bless( $_[0], $_[1] ); -} - -sub versionMadeBy { - shift->{'versionMadeBy'}; -} - -sub fileAttributeFormat { - my $self = shift; - - if (@_) { - $self->{fileAttributeFormat} = ( ref( $_[0] ) eq 'HASH' ) - ? $_[0]->{format} : $_[0]; - } - else { - return $self->{fileAttributeFormat}; - } -} - -sub versionNeededToExtract { - shift->{'versionNeededToExtract'}; -} - -sub bitFlag { - my $self = shift; - - # Set General Purpose Bit Flags according to the desiredCompressionLevel setting - if ( $self->desiredCompressionLevel == 1 || $self->desiredCompressionLevel == 2 ) { - $self->{'bitFlag'} = DEFLATING_COMPRESSION_FAST; - } elsif ( $self->desiredCompressionLevel == 3 || $self->desiredCompressionLevel == 4 - || $self->desiredCompressionLevel == 5 || $self->desiredCompressionLevel == 6 - || $self->desiredCompressionLevel == 7 ) { - $self->{'bitFlag'} = DEFLATING_COMPRESSION_NORMAL; - } elsif ( $self->desiredCompressionLevel == 8 || $self->desiredCompressionLevel == 9 ) { - $self->{'bitFlag'} = DEFLATING_COMPRESSION_MAXIMUM; - } - $self->{'bitFlag'}; -} - -sub compressionMethod { - shift->{'compressionMethod'}; -} - -sub desiredCompressionMethod { - my $self = shift; - my $newDesiredCompressionMethod = - ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionMethod} : shift; - my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'}; - if ( defined($newDesiredCompressionMethod) ) { - $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod; - if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) { - $self->{'desiredCompressionLevel'} = 0; - $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK; - - } elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) { - $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT; - } - } - return $oldDesiredCompressionMethod; -} - -sub desiredCompressionLevel { - my $self = shift; - my $newDesiredCompressionLevel = - ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionLevel} : shift; - my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'}; - if ( defined($newDesiredCompressionLevel) ) { - $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel; - $self->{'desiredCompressionMethod'} = ( - $newDesiredCompressionLevel - ? COMPRESSION_DEFLATED - : COMPRESSION_STORED - ); - } - return $oldDesiredCompressionLevel; -} - -sub fileName { - my $self = shift; - my $newName = shift; - if ($newName) { - $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems - $self->{'fileName'} = $newName; - } - return $self->{'fileName'}; -} - -sub lastModFileDateTime { - my $modTime = shift->{'lastModFileDateTime'}; - $modTime =~ m/^(\d+)$/; # untaint - return $1; -} - -sub lastModTime { - my $self = shift; - return _dosToUnixTime( $self->lastModFileDateTime() ); -} - -sub setLastModFileDateTimeFromUnix { - my $self = shift; - my $time_t = shift; - $self->{'lastModFileDateTime'} = _unixToDosTime($time_t); -} - -sub internalFileAttributes { - shift->{'internalFileAttributes'}; -} - -sub externalFileAttributes { - shift->{'externalFileAttributes'}; -} - -# Convert UNIX permissions into proper value for zip file -# Usable as a function or a method -sub _mapPermissionsFromUnix { - my $self = shift; - my $mode = shift; - my $attribs = $mode << 16; - - # Microsoft Windows Explorer needs this bit set for directories - if ( $mode & DIRECTORY_ATTRIB ) { - $attribs |= 16; - } - - return $attribs; - - # TODO: map more MS-DOS perms -} - -# Convert ZIP permissions into Unix ones -# -# This was taken from Info-ZIP group's portable UnZip -# zipfile-extraction program, version 5.50. -# http://www.info-zip.org/pub/infozip/ -# -# See the mapattr() function in unix/unix.c -# See the attribute format constants in unzpriv.h -# -# XXX Note that there's one situation that isn't implemented -# yet that depends on the "extra field." -sub _mapPermissionsToUnix { - my $self = shift; - - my $format = $self->{'fileAttributeFormat'}; - my $attribs = $self->{'externalFileAttributes'}; - - my $mode = 0; - - if ( $format == FA_AMIGA ) { - $attribs = $attribs >> 17 & 7; # Amiga RWE bits - $mode = $attribs << 6 | $attribs << 3 | $attribs; - return $mode; - } - - if ( $format == FA_THEOS ) { - $attribs &= 0xF1FFFFFF; - if ( ( $attribs & 0xF0000000 ) != 0x40000000 ) { - $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits - } - else { - $attribs &= 0x41FFFFFF; # leave directory bit as set - } - } - - if ( $format == FA_UNIX - || $format == FA_VAX_VMS - || $format == FA_ACORN - || $format == FA_ATARI_ST - || $format == FA_BEOS - || $format == FA_QDOS - || $format == FA_TANDEM ) - { - $mode = $attribs >> 16; - return $mode if $mode != 0 or not $self->localExtraField; - - # warn("local extra field is: ", $self->localExtraField, "\n"); - - # XXX This condition is not implemented - # I'm just including the comments from the info-zip section for now. - - # Some (non-Info-ZIP) implementations of Zip for Unix and - # VMS (and probably others ??) leave 0 in the upper 16-bit - # part of the external_file_attributes field. Instead, they - # store file permission attributes in some extra field. - # As a work-around, we search for the presence of one of - # these extra fields and fall back to the MSDOS compatible - # part of external_file_attributes if one of the known - # e.f. types has been detected. - # Later, we might implement extraction of the permission - # bits from the VMS extra field. But for now, the work-around - # should be sufficient to provide "readable" extracted files. - # (For ASI Unix e.f., an experimental remap from the e.f. - # mode value IS already provided!) - } - - # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the - # Unix attributes in the upper 16 bits of the external attributes - # field, just like Info-ZIP's Zip for Unix. We try to use that - # value, after a check for consistency with the MSDOS attribute - # bits (see below). - if ( $format == FA_MSDOS ) { - $mode = $attribs >> 16; - } - - # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20 - $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4; - - # keep previous $mode setting when its "owner" - # part appears to be consistent with DOS attribute flags! - return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 ); - $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs; - return $mode; -} - -sub unixFileAttributes { - my $self = shift; - my $oldPerms = $self->_mapPermissionsToUnix; - - my $perms; - if ( @_ ) { - $perms = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{attributes} : $_[0]; - - if ( $self->isDirectory ) { - $perms &= ~FILE_ATTRIB; - $perms |= DIRECTORY_ATTRIB; - } else { - $perms &= ~DIRECTORY_ATTRIB; - $perms |= FILE_ATTRIB; - } - $self->{externalFileAttributes} = $self->_mapPermissionsFromUnix($perms); - } - - return $oldPerms; -} - -sub localExtraField { - my $self = shift; - - if (@_) { - $self->{localExtraField} = ( ref( $_[0] ) eq 'HASH' ) - ? $_[0]->{field} : $_[0]; - } - else { - return $self->{localExtraField}; - } -} - -sub cdExtraField { - my $self = shift; - - if (@_) { - $self->{cdExtraField} = ( ref( $_[0] ) eq 'HASH' ) - ? $_[0]->{field} : $_[0]; - } - else { - return $self->{cdExtraField}; - } -} - -sub extraFields { - my $self = shift; - return $self->localExtraField() . $self->cdExtraField(); -} - -sub fileComment { - my $self = shift; - - if (@_) { - $self->{fileComment} = ( ref( $_[0] ) eq 'HASH' ) - ? pack( 'C0a*', $_[0]->{comment} ) : pack( 'C0a*', $_[0] ); - } - else { - return $self->{fileComment}; - } -} - -sub hasDataDescriptor { - my $self = shift; - if (@_) { - my $shouldHave = shift; - if ($shouldHave) { - $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK; - } - else { - $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK; - } - } - return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK; -} - -sub crc32 { - shift->{'crc32'}; -} - -sub crc32String { - sprintf( "%08x", shift->{'crc32'} ); -} - -sub compressedSize { - shift->{'compressedSize'}; -} - -sub uncompressedSize { - shift->{'uncompressedSize'}; -} - -sub isEncrypted { - shift->bitFlag() & GPBF_ENCRYPTED_MASK; -} - -sub isTextFile { - my $self = shift; - my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; - if (@_) { - my $flag = ( ref( $_[0] ) eq 'HASH' ) ? shift->{flag} : shift; - $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; - $self->{'internalFileAttributes'} |= - ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE ); - } - return $bit == IFA_TEXT_FILE; -} - -sub isBinaryFile { - my $self = shift; - my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; - if (@_) { - my $flag = shift; - $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; - $self->{'internalFileAttributes'} |= - ( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE ); - } - return $bit == IFA_BINARY_FILE; -} - -sub extractToFileNamed { - my $self = shift; - - # local FS name - my $name = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{name} : $_[0]; - $self->{'isSymbolicLink'} = 0; - - # Check if the file / directory is a symbolic link or not - if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) { - $self->{'isSymbolicLink'} = 1; - $self->{'newName'} = $name; - my ( $status, $fh ) = _newFileHandle( $name, 'r' ); - my $retval = $self->extractToFileHandle($fh); - $fh->close(); - } else { - #return _writeSymbolicLink($self, $name) if $self->isSymbolicLink(); - return _error("encryption unsupported") if $self->isEncrypted(); - mkpath( dirname($name) ); # croaks on error - my ( $status, $fh ) = _newFileHandle( $name, 'w' ); - return _ioError("Can't open file $name for write") unless $status; - my $retval = $self->extractToFileHandle($fh); - $fh->close(); - chmod ($self->unixFileAttributes(), $name) - or return _error("Can't chmod() ${name}: $!"); - utime( $self->lastModTime(), $self->lastModTime(), $name ); - return $retval; - } -} - -sub _writeSymbolicLink { - my $self = shift; - my $name = shift; - my $chunkSize = $Archive::Zip::ChunkSize; - #my ( $outRef, undef ) = $self->readChunk($chunkSize); - my $fh; - my $retval = $self->extractToFileHandle($fh); - my ( $outRef, undef ) = $self->readChunk(100); -} - -sub isSymbolicLink { - my $self = shift; - if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) { - $self->{'isSymbolicLink'} = 1; - } else { - return 0; - } - 1; -} - -sub isDirectory { - return 0; -} - -sub externalFileName { - return undef; -} - -# The following are used when copying data -sub _writeOffset { - shift->{'writeOffset'}; -} - -sub _readOffset { - shift->{'readOffset'}; -} - -sub writeLocalHeaderRelativeOffset { - shift->{'writeLocalHeaderRelativeOffset'}; -} - -sub wasWritten { shift->{'wasWritten'} } - -sub _dataEnded { - shift->{'dataEnded'}; -} - -sub _readDataRemaining { - shift->{'readDataRemaining'}; -} - -sub _inflater { - shift->{'inflater'}; -} - -sub _deflater { - shift->{'deflater'}; -} - -# Return the total size of my local header -sub _localHeaderSize { - my $self = shift; - return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH + - length( $self->fileName() ) + length( $self->localExtraField() ); -} - -# Return the total size of my CD header -sub _centralDirectoryHeaderSize { - my $self = shift; - return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH + - length( $self->fileName() ) + length( $self->cdExtraField() ) + - length( $self->fileComment() ); -} - -# DOS date/time format -# 0-4 (5) Second divided by 2 -# 5-10 (6) Minute (0-59) -# 11-15 (5) Hour (0-23 on a 24-hour clock) -# 16-20 (5) Day of the month (1-31) -# 21-24 (4) Month (1 = January, 2 = February, etc.) -# 25-31 (7) Year offset from 1980 (add 1980 to get actual year) - -# Convert DOS date/time format to unix time_t format -# NOT AN OBJECT METHOD! -sub _dosToUnixTime { - my $dt = shift; - return time() unless defined($dt); - - my $year = ( ( $dt >> 25 ) & 0x7f ) + 80; - my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1; - my $mday = ( ( $dt >> 16 ) & 0x1f ); - - my $hour = ( ( $dt >> 11 ) & 0x1f ); - my $min = ( ( $dt >> 5 ) & 0x3f ); - my $sec = ( ( $dt << 1 ) & 0x3e ); - - # catch errors - my $time_t = - eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); }; - return time() if ($@); - return $time_t; -} - -# Note, this isn't exactly UTC 1980, it's 1980 + 12 hours and 1 -# minute so that nothing timezoney can muck us up. -my $safe_epoch = 315576060; - -# convert a unix time to DOS date/time -# NOT AN OBJECT METHOD! -sub _unixToDosTime { - my $time_t = shift; - unless ($time_t) { - _error("Tried to add member with zero or undef value for time"); - $time_t = $safe_epoch; - } - if ( $time_t < $safe_epoch ) { - _ioError("Unsupported date before 1980 encountered, moving to 1980"); - $time_t = $safe_epoch; - } - my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t); - my $dt = 0; - $dt += ( $sec >> 1 ); - $dt += ( $min << 5 ); - $dt += ( $hour << 11 ); - $dt += ( $mday << 16 ); - $dt += ( ( $mon + 1 ) << 21 ); - $dt += ( ( $year - 80 ) << 25 ); - return $dt; -} - -# Write my local header to a file handle. -# Stores the offset to the start of the header in my -# writeLocalHeaderRelativeOffset member. -# Returns AZ_OK on success. -sub _writeLocalFileHeader { - my $self = shift; - my $fh = shift; - - my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE ); - $self->_print($fh, $signatureData) - or return _ioError("writing local header signature"); - - my $header = pack( - LOCAL_FILE_HEADER_FORMAT, - $self->versionNeededToExtract(), - $self->bitFlag(), - $self->desiredCompressionMethod(), - $self->lastModFileDateTime(), - $self->crc32(), - $self->compressedSize(), # may need to be re-written later - $self->uncompressedSize(), - length( $self->fileName() ), - length( $self->localExtraField() ) - ); - - $self->_print($fh, $header) or return _ioError("writing local header"); - - # Check for a valid filename or a filename equal to a literal `0' - if ( $self->fileName() || $self->fileName eq '0' ) { - $self->_print($fh, $self->fileName() ) - or return _ioError("writing local header filename"); - } - if ( $self->localExtraField() ) { - $self->_print($fh, $self->localExtraField() ) - or return _ioError("writing local extra field"); - } - - return AZ_OK; -} - -sub _writeCentralDirectoryFileHeader { - my $self = shift; - my $fh = shift; - - my $sigData = - pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE ); - $self->_print($fh, $sigData) - or return _ioError("writing central directory header signature"); - - my $fileNameLength = length( $self->fileName() ); - my $extraFieldLength = length( $self->cdExtraField() ); - my $fileCommentLength = length( $self->fileComment() ); - - my $header = pack( - CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, - $self->versionMadeBy(), - $self->fileAttributeFormat(), - $self->versionNeededToExtract(), - $self->bitFlag(), - $self->desiredCompressionMethod(), - $self->lastModFileDateTime(), - $self->crc32(), # these three fields should have been updated - $self->_writeOffset(), # by writing the data stream out - $self->uncompressedSize(), # - $fileNameLength, - $extraFieldLength, - $fileCommentLength, - 0, # {'diskNumberStart'}, - $self->internalFileAttributes(), - $self->externalFileAttributes(), - $self->writeLocalHeaderRelativeOffset() - ); - - $self->_print($fh, $header) - or return _ioError("writing central directory header"); - if ($fileNameLength) { - $self->_print($fh, $self->fileName() ) - or return _ioError("writing central directory header signature"); - } - if ($extraFieldLength) { - $self->_print($fh, $self->cdExtraField() ) - or return _ioError("writing central directory extra field"); - } - if ($fileCommentLength) { - $self->_print($fh, $self->fileComment() ) - or return _ioError("writing central directory file comment"); - } - - return AZ_OK; -} - -# This writes a data descriptor to the given file handle. -# Assumes that crc32, writeOffset, and uncompressedSize are -# set correctly (they should be after a write). -# Further, the local file header should have the -# GPBF_HAS_DATA_DESCRIPTOR_MASK bit set. -sub _writeDataDescriptor { - my $self = shift; - my $fh = shift; - my $header = pack( - SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT, - DATA_DESCRIPTOR_SIGNATURE, - $self->crc32(), - $self->_writeOffset(), # compressed size - $self->uncompressedSize() - ); - - $self->_print($fh, $header) - or return _ioError("writing data descriptor"); - return AZ_OK; -} - -# Re-writes the local file header with new crc32 and compressedSize fields. -# To be called after writing the data stream. -# Assumes that filename and extraField sizes didn't change since last written. -sub _refreshLocalFileHeader { - my $self = shift; - my $fh = shift; - - my $here = $fh->tell(); - $fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH, - IO::Seekable::SEEK_SET ) - or return _ioError("seeking to rewrite local header"); - - my $header = pack( - LOCAL_FILE_HEADER_FORMAT, - $self->versionNeededToExtract(), - $self->bitFlag(), - $self->desiredCompressionMethod(), - $self->lastModFileDateTime(), - $self->crc32(), - $self->_writeOffset(), # compressed size - $self->uncompressedSize(), - length( $self->fileName() ), - length( $self->localExtraField() ) - ); - - $self->_print($fh, $header) - or return _ioError("re-writing local header"); - $fh->seek( $here, IO::Seekable::SEEK_SET ) - or return _ioError("seeking after rewrite of local header"); - - return AZ_OK; -} - -sub readChunk { - my $self = shift; - my $chunkSize = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{chunkSize} : $_[0]; - - if ( $self->readIsDone() ) { - $self->endRead(); - my $dummy = ''; - return ( \$dummy, AZ_STREAM_END ); - } - - $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize); - $chunkSize = $self->_readDataRemaining() - if $chunkSize > $self->_readDataRemaining(); - - my $buffer = ''; - my $outputRef; - my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize ); - return ( \$buffer, $status ) unless $status == AZ_OK; - - $self->{'readDataRemaining'} -= $bytesRead; - $self->{'readOffset'} += $bytesRead; - - if ( $self->compressionMethod() == COMPRESSION_STORED ) { - $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} ); - } - - ( $outputRef, $status ) = &{ $self->{'chunkHandler'} }( $self, \$buffer ); - $self->{'writeOffset'} += length($$outputRef); - - $self->endRead() - if $self->readIsDone(); - - return ( $outputRef, $status ); -} - -# Read the next raw chunk of my data. Subclasses MUST implement. -# my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize ); -sub _readRawChunk { - my $self = shift; - return $self->_subclassResponsibility(); -} - -# A place holder to catch rewindData errors if someone ignores -# the error code. -sub _noChunk { - my $self = shift; - return ( \undef, _error("trying to copy chunk when init failed") ); -} - -# Basically a no-op so that I can have a consistent interface. -# ( $outputRef, $status) = $self->_copyChunk( \$buffer ); -sub _copyChunk { - my ( $self, $dataRef ) = @_; - return ( $dataRef, AZ_OK ); -} - -# ( $outputRef, $status) = $self->_deflateChunk( \$buffer ); -sub _deflateChunk { - my ( $self, $buffer ) = @_; - my ( $status ) = $self->_deflater()->deflate( $buffer, my $out ); - - if ( $self->_readDataRemaining() == 0 ) { - my $extraOutput; - ( $status ) = $self->_deflater()->flush($extraOutput); - $out .= $extraOutput; - $self->endRead(); - return ( \$out, AZ_STREAM_END ); - } - elsif ( $status == Z_OK ) { - return ( \$out, AZ_OK ); - } - else { - $self->endRead(); - my $retval = _error( 'deflate error', $status ); - my $dummy = ''; - return ( \$dummy, $retval ); - } -} - -# ( $outputRef, $status) = $self->_inflateChunk( \$buffer ); -sub _inflateChunk { - my ( $self, $buffer ) = @_; - my ( $status ) = $self->_inflater()->inflate( $buffer, my $out ); - my $retval; - $self->endRead() unless $status == Z_OK; - if ( $status == Z_OK || $status == Z_STREAM_END ) { - $retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK; - return ( \$out, $retval ); - } - else { - $retval = _error( 'inflate error', $status ); - my $dummy = ''; - return ( \$dummy, $retval ); - } -} - -sub rewindData { - my $self = shift; - my $status; - - # set to trap init errors - $self->{'chunkHandler'} = $self->can('_noChunk'); - - # Work around WinZip bug with 0-length DEFLATED files - $self->desiredCompressionMethod(COMPRESSION_STORED) - if $self->uncompressedSize() == 0; - - # assume that we're going to read the whole file, and compute the CRC anew. - $self->{'crc32'} = 0 - if ( $self->compressionMethod() == COMPRESSION_STORED ); - - # These are the only combinations of methods we deal with right now. - if ( $self->compressionMethod() == COMPRESSION_STORED - and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) - { - ( $self->{'deflater'}, $status ) = Compress::Raw::Zlib::Deflate->new( - '-Level' => $self->desiredCompressionLevel(), - '-WindowBits' => -MAX_WBITS(), # necessary magic - '-Bufsize' => $Archive::Zip::ChunkSize, - @_ - ); # pass additional options - return _error( 'deflateInit error:', $status ) - unless $status == Z_OK; - $self->{'chunkHandler'} = $self->can('_deflateChunk'); - } - elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED - and $self->desiredCompressionMethod() == COMPRESSION_STORED ) - { - ( $self->{'inflater'}, $status ) = Compress::Raw::Zlib::Inflate->new( - '-WindowBits' => -MAX_WBITS(), # necessary magic - '-Bufsize' => $Archive::Zip::ChunkSize, - @_ - ); # pass additional options - return _error( 'inflateInit error:', $status ) - unless $status == Z_OK; - $self->{'chunkHandler'} = $self->can('_inflateChunk'); - } - elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() ) { - $self->{'chunkHandler'} = $self->can('_copyChunk'); - } - else { - return _error( - sprintf( - "Unsupported compression combination: read %d, write %d", - $self->compressionMethod(), - $self->desiredCompressionMethod() - ) - ); - } - - $self->{'readDataRemaining'} = - ( $self->compressionMethod() == COMPRESSION_STORED ) - ? $self->uncompressedSize() - : $self->compressedSize(); - $self->{'dataEnded'} = 0; - $self->{'readOffset'} = 0; - - return AZ_OK; -} - -sub endRead { - my $self = shift; - delete $self->{'inflater'}; - delete $self->{'deflater'}; - $self->{'dataEnded'} = 1; - $self->{'readDataRemaining'} = 0; - return AZ_OK; -} - -sub readIsDone { - my $self = shift; - return ( $self->_dataEnded() or !$self->_readDataRemaining() ); -} - -sub contents { - my $self = shift; - my $newContents = shift; - - if ( defined($newContents) ) { - - # change our type and call the subclass contents method. - $self->_become(STRINGMEMBERCLASS); - return $self->contents( pack( 'C0a*', $newContents ) ) - ; # in case of Unicode - } - else { - my $oldCompression = - $self->desiredCompressionMethod(COMPRESSION_STORED); - my $status = $self->rewindData(@_); - if ( $status != AZ_OK ) { - $self->endRead(); - return $status; - } - my $retval = ''; - while ( $status == AZ_OK ) { - my $ref; - ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() ); - - # did we get it in one chunk? - if ( length($$ref) == $self->uncompressedSize() ) { - $retval = $$ref; - } - else { $retval .= $$ref } - } - $self->desiredCompressionMethod($oldCompression); - $self->endRead(); - $status = AZ_OK if $status == AZ_STREAM_END; - $retval = undef unless $status == AZ_OK; - return wantarray ? ( $retval, $status ) : $retval; - } -} - -sub extractToFileHandle { - my $self = shift; - return _error("encryption unsupported") if $self->isEncrypted(); - my $fh = ( ref( $_[0] ) eq 'HASH' ) ? shift->{fileHandle} : shift; - _binmode($fh); - my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED); - my $status = $self->rewindData(@_); - $status = $self->_writeData($fh) if $status == AZ_OK; - $self->desiredCompressionMethod($oldCompression); - $self->endRead(); - return $status; -} - -# write local header and data stream to file handle -sub _writeToFileHandle { - my $self = shift; - my $fh = shift; - my $fhIsSeekable = shift; - my $offset = shift; - - return _error("no member name given for $self") - if $self->fileName() eq ''; - - $self->{'writeLocalHeaderRelativeOffset'} = $offset; - $self->{'wasWritten'} = 0; - - # Determine if I need to write a data descriptor - # I need to do this if I can't refresh the header - # and I don't know compressed size or crc32 fields. - my $headerFieldsUnknown = ( - ( $self->uncompressedSize() > 0 ) - and ($self->compressionMethod() == COMPRESSION_STORED - or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) - ); - - my $shouldWriteDataDescriptor = - ( $headerFieldsUnknown and not $fhIsSeekable ); - - $self->hasDataDescriptor(1) - if ($shouldWriteDataDescriptor); - - $self->{'writeOffset'} = 0; - - my $status = $self->rewindData(); - ( $status = $self->_writeLocalFileHeader($fh) ) - if $status == AZ_OK; - ( $status = $self->_writeData($fh) ) - if $status == AZ_OK; - if ( $status == AZ_OK ) { - $self->{'wasWritten'} = 1; - if ( $self->hasDataDescriptor() ) { - $status = $self->_writeDataDescriptor($fh); - } - elsif ($headerFieldsUnknown) { - $status = $self->_refreshLocalFileHeader($fh); - } - } - - return $status; -} - -# Copy my (possibly compressed) data to given file handle. -# Returns C<AZ_OK> on success -sub _writeData { - my $self = shift; - my $writeFh = shift; - - # If symbolic link, just create one if the operating system is Linux, Unix, BSD or VMS - # TODO: Add checks for other operating systems - if ( $self->{'isSymbolicLink'} == 1 && $^O eq 'linux' ) { - my $chunkSize = $Archive::Zip::ChunkSize; - my ( $outRef, $status ) = $self->readChunk($chunkSize); - symlink $$outRef, $self->{'newName'}; - } else { - return AZ_OK if ( $self->uncompressedSize() == 0 ); - my $status; - my $chunkSize = $Archive::Zip::ChunkSize; - while ( $self->_readDataRemaining() > 0 ) { - my $outRef; - ( $outRef, $status ) = $self->readChunk($chunkSize); - return $status if ( $status != AZ_OK and $status != AZ_STREAM_END ); - - if ( length($$outRef) > 0 ) { - $self->_print($writeFh, $$outRef) - or return _ioError("write error during copy"); - } - - last if $status == AZ_STREAM_END; - } - $self->{'compressedSize'} = $self->_writeOffset(); - } - return AZ_OK; -} - -# Return true if I depend on the named file -sub _usesFileNamed { - return 0; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/MemberRead.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/MemberRead.pm deleted file mode 100755 index a27bfdc45f0..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/MemberRead.pm +++ /dev/null @@ -1,333 +0,0 @@ -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.30'; - $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 diffrent 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 argumnet 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. - -=cut - -sub getline { - my $self = shift; - my $size = $self->buffer_size(); - my $sep = $self->_sep_re(); - - for (;;) { - if ( $sep - && defined($self->{buffer}) - && $self->{buffer} =~ s/^(.*?)$sep//s - ) { - $self->{line_no}++; - return $1; - } 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, <sreeji_k@yahoo.com> -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 diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/MockFileHandle.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/MockFileHandle.pm deleted file mode 100755 index bceb181ae13..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/MockFileHandle.pm +++ /dev/null @@ -1,69 +0,0 @@ -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.30'; - $VERSION = eval $VERSION; -} - -sub new { - my $class = shift || __PACKAGE__; - $class = ref($class) || $class; - my $self = bless( - { - 'position' => 0, - 'size' => 0 - }, - $class - ); - return $self; -} - -sub eof { - my $self = shift; - return $self->{'position'} >= $self->{'size'}; -} - -# Copy given buffer to me -sub print { - my $self = shift; - my $bytes = join( '', @_ ); - my $bytesWritten = $self->writeHook($bytes); - if ( $self->{'position'} + $bytesWritten > $self->{'size'} ) { - $self->{'size'} = $self->{'position'} + $bytesWritten; - } - $self->{'position'} += $bytesWritten; - return $bytesWritten; -} - -# Called on each write. -# Override in subclasses. -# Return number of bytes written (0 on error). -sub writeHook { - my $self = shift; - my $bytes = shift; - return length($bytes); -} - -sub binmode { 1 } - -sub close { 1 } - -sub clearerr { 1 } - -# I'm write-only! -sub read { 0 } - -sub tell { return shift->{'position'} } - -sub opened { 1 } - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/NewFileMember.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/NewFileMember.pm deleted file mode 100755 index 79178082151..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/NewFileMember.pm +++ /dev/null @@ -1,79 +0,0 @@ -package Archive::Zip::NewFileMember; - -use strict; -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw ( Archive::Zip::FileMember ); -} - -use Archive::Zip qw( - :CONSTANTS - :ERROR_CODES - :UTILITY_METHODS -); - -# Given a file name, set up for eventual writing. -sub _newFromFileNamed { - my $class = shift; - my $fileName = shift; # local FS format - my $newName = shift; - $newName = _asZipDirName($fileName) unless defined($newName); - return undef unless ( stat($fileName) && -r _ && !-d _ ); - my $self = $class->new(@_); - $self->{'fileName'} = $newName; - $self->{'externalFileName'} = $fileName; - $self->{'compressionMethod'} = COMPRESSION_STORED; - my @stat = stat(_); - $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7]; - $self->desiredCompressionMethod( - ( $self->compressedSize() > 0 ) - ? COMPRESSION_DEFLATED - : COMPRESSION_STORED - ); - $self->unixFileAttributes( $stat[2] ); - $self->setLastModFileDateTimeFromUnix( $stat[9] ); - $self->isTextFile( -T _ ); - return $self; -} - -sub rewindData { - my $self = shift; - - my $status = $self->SUPER::rewindData(@_); - return $status unless $status == AZ_OK; - - return AZ_IO_ERROR unless $self->fh(); - $self->fh()->clearerr(); - $self->fh()->seek( 0, IO::Seekable::SEEK_SET ) - or return _ioError( "rewinding", $self->externalFileName() ); - return AZ_OK; -} - -# Return bytes read. Note that first parameter is a ref to a buffer. -# my $data; -# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); -sub _readRawChunk { - my ( $self, $dataRef, $chunkSize ) = @_; - return ( 0, AZ_OK ) unless $chunkSize; - my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize ) - or return ( 0, _ioError("reading data") ); - return ( $bytesRead, AZ_OK ); -} - -# If I already exist, extraction is a no-op. -sub extractToFileNamed { - my $self = shift; - my $name = shift; # local FS name - if ( File::Spec->rel2abs($name) eq - File::Spec->rel2abs( $self->externalFileName() ) and -r $name ) - { - return AZ_OK; - } - else { - return $self->SUPER::extractToFileNamed( $name, @_ ); - } -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/StringMember.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/StringMember.pm deleted file mode 100755 index fe6760849ac..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/StringMember.pm +++ /dev/null @@ -1,64 +0,0 @@ -package Archive::Zip::StringMember; - -use strict; -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @ISA = qw( Archive::Zip::Member ); -} - -use Archive::Zip qw( - :CONSTANTS - :ERROR_CODES -); - -# Create a new string member. Default is COMPRESSION_STORED. -# Can take a ref to a string as well. -sub _newFromString { - my $class = shift; - my $string = shift; - my $name = shift; - my $self = $class->new(@_); - $self->contents($string); - $self->fileName($name) if defined($name); - - # Set the file date to now - $self->setLastModFileDateTimeFromUnix( time() ); - $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS ); - return $self; -} - -sub _become { - my $self = shift; - my $newClass = shift; - return $self if ref($self) eq $newClass; - delete( $self->{'contents'} ); - return $self->SUPER::_become($newClass); -} - -# Get or set my contents. Note that we do not call the superclass -# version of this, because it calls us. -sub contents { - my $self = shift; - my $string = shift; - if ( defined($string) ) { - $self->{'contents'} = - pack( 'C0a*', ( ref($string) eq 'SCALAR' ) ? $$string : $string ); - $self->{'uncompressedSize'} = $self->{'compressedSize'} = - length( $self->{'contents'} ); - $self->{'compressionMethod'} = COMPRESSION_STORED; - } - return $self->{'contents'}; -} - -# Return bytes read. Note that first parameter is a ref to a buffer. -# my $data; -# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); -sub _readRawChunk { - my ( $self, $dataRef, $chunkSize ) = @_; - $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize ); - return ( length($$dataRef), AZ_OK ); -} - -1; diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/Tree.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/Tree.pm deleted file mode 100755 index fb8bc0b3c7e..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/Tree.pm +++ /dev/null @@ -1,49 +0,0 @@ -package Archive::Zip::Tree; - -use strict; -use vars qw{$VERSION}; -BEGIN { - $VERSION = '1.30'; -} - -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 SYNOPSIS - -=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 - diff --git a/Master/tlpkg/tlperl/lib/Archive/Zip/ZipFileMember.pm b/Master/tlpkg/tlperl/lib/Archive/Zip/ZipFileMember.pm deleted file mode 100755 index cc606697b15..00000000000 --- a/Master/tlpkg/tlperl/lib/Archive/Zip/ZipFileMember.pm +++ /dev/null @@ -1,416 +0,0 @@ -package Archive::Zip::ZipFileMember; - -use strict; -use vars qw( $VERSION @ISA ); - -BEGIN { - $VERSION = '1.30'; - @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 isn't, 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; - - return _formatError( - "CRC or size mismatch while skipping data descriptor") - if ( $oldCrc32 != $self->{'crc32'} - || $oldUncompressedSize != $self->{'uncompressedSize'} ); - } - - 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 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; |