diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Archive/Zip')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/Archive.pm | 978 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/BufferedFileHandle.pm | 131 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/DirectoryMember.pm | 80 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/FAQ.pod | 467 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/FileMember.pm | 64 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/Member.pm | 1083 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/MemberRead.pm | 333 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/MockFileHandle.pm | 69 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/NewFileMember.pm | 79 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/StringMember.pm | 64 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/Tree.pm | 49 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Archive/Zip/ZipFileMember.pm | 416 |
12 files changed, 3813 insertions, 0 deletions
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; |