diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Archive')
17 files changed, 10275 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Archive/Extract.pm b/Master/tlpkg/tlperl0/lib/Archive/Extract.pm new file mode 100755 index 00000000000..08676fb1e08 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Extract.pm @@ -0,0 +1,1511 @@ +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/tlperl0/lib/Archive/Tar.pm b/Master/tlpkg/tlperl0/lib/Archive/Tar.pm new file mode 100755 index 00000000000..006edbd5c3e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Tar.pm @@ -0,0 +1,2146 @@ +### 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/tlperl0/lib/Archive/Tar/Constant.pm b/Master/tlpkg/tlperl0/lib/Archive/Tar/Constant.pm new file mode 100755 index 00000000000..aef1d623fa8 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Tar/Constant.pm @@ -0,0 +1,86 @@ +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/tlperl0/lib/Archive/Tar/File.pm b/Master/tlpkg/tlperl0/lib/Archive/Tar/File.pm new file mode 100755 index 00000000000..0815bb67620 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Tar/File.pm @@ -0,0 +1,660 @@ +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/tlperl0/lib/Archive/Zip.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip.pm new file mode 100755 index 00000000000..8fd86c93b72 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip.pm @@ -0,0 +1,2059 @@ +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/tlperl0/lib/Archive/Zip/Archive.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/Archive.pm new file mode 100755 index 00000000000..d9fd02e5e02 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/Archive.pm @@ -0,0 +1,978 @@ +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/tlperl0/lib/Archive/Zip/BufferedFileHandle.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/BufferedFileHandle.pm new file mode 100755 index 00000000000..4e56f9f007c --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/BufferedFileHandle.pm @@ -0,0 +1,131 @@ +package Archive::Zip::BufferedFileHandle; + +# File handle that uses a string internally and can seek +# This is given as a demo for getting a zip file written +# to a string. +# I probably should just use IO::Scalar instead. +# Ned Konz, March 2000 + +use strict; +use IO::File; +use Carp; + +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.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/tlperl0/lib/Archive/Zip/DirectoryMember.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/DirectoryMember.pm new file mode 100755 index 00000000000..c9d3705f08f --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/DirectoryMember.pm @@ -0,0 +1,80 @@ +package Archive::Zip::DirectoryMember; + +use strict; +use File::Path; + +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.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/tlperl0/lib/Archive/Zip/FAQ.pod b/Master/tlpkg/tlperl0/lib/Archive/Zip/FAQ.pod new file mode 100755 index 00000000000..2b2d8ed9e88 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/FAQ.pod @@ -0,0 +1,467 @@ + +=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/tlperl0/lib/Archive/Zip/FileMember.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/FileMember.pm new file mode 100755 index 00000000000..a9b8cf5d7be --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/FileMember.pm @@ -0,0 +1,64 @@ +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/tlperl0/lib/Archive/Zip/Member.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/Member.pm new file mode 100755 index 00000000000..f86ef75d55d --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/Member.pm @@ -0,0 +1,1083 @@ +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/tlperl0/lib/Archive/Zip/MemberRead.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/MemberRead.pm new file mode 100755 index 00000000000..a27bfdc45f0 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/MemberRead.pm @@ -0,0 +1,333 @@ +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/tlperl0/lib/Archive/Zip/MockFileHandle.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/MockFileHandle.pm new file mode 100755 index 00000000000..bceb181ae13 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/MockFileHandle.pm @@ -0,0 +1,69 @@ +package Archive::Zip::MockFileHandle; + +# Output file handle that calls a custom write routine +# Ned Konz, March 2000 +# This is provided to help with writing zip files +# when you have to process them a chunk at a time. + +use strict; + +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.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/tlperl0/lib/Archive/Zip/NewFileMember.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/NewFileMember.pm new file mode 100755 index 00000000000..79178082151 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/NewFileMember.pm @@ -0,0 +1,79 @@ +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/tlperl0/lib/Archive/Zip/StringMember.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/StringMember.pm new file mode 100755 index 00000000000..fe6760849ac --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/StringMember.pm @@ -0,0 +1,64 @@ +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/tlperl0/lib/Archive/Zip/Tree.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/Tree.pm new file mode 100755 index 00000000000..fb8bc0b3c7e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/Tree.pm @@ -0,0 +1,49 @@ +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/tlperl0/lib/Archive/Zip/ZipFileMember.pm b/Master/tlpkg/tlperl0/lib/Archive/Zip/ZipFileMember.pm new file mode 100755 index 00000000000..cc606697b15 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Archive/Zip/ZipFileMember.pm @@ -0,0 +1,416 @@ +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; |