summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Archive
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Archive')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Extract.pm1511
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Tar.pm2146
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Tar/Constant.pm86
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Tar/File.pm660
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip.pm2059
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/Archive.pm978
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/BufferedFileHandle.pm131
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/DirectoryMember.pm80
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/FAQ.pod467
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/FileMember.pm64
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/Member.pm1083
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/MemberRead.pm333
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/MockFileHandle.pm69
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/NewFileMember.pm79
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/StringMember.pm64
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/Tree.pm49
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Archive/Zip/ZipFileMember.pm416
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;