diff options
Diffstat (limited to 'lib/Archive/Zip')
-rw-r--r-- | lib/Archive/Zip/Archive.pm | 1020 | ||||
-rw-r--r-- | lib/Archive/Zip/BufferedFileHandle.pm | 131 | ||||
-rw-r--r-- | lib/Archive/Zip/DirectoryMember.pm | 80 | ||||
-rw-r--r-- | lib/Archive/Zip/FAQ.pod | 344 | ||||
-rw-r--r-- | lib/Archive/Zip/FileMember.pm | 64 | ||||
-rw-r--r-- | lib/Archive/Zip/Member.pm | 1247 | ||||
-rw-r--r-- | lib/Archive/Zip/MemberRead.pm | 348 | ||||
-rw-r--r-- | lib/Archive/Zip/MockFileHandle.pm | 69 | ||||
-rw-r--r-- | lib/Archive/Zip/NewFileMember.pm | 77 | ||||
-rw-r--r-- | lib/Archive/Zip/StringMember.pm | 64 | ||||
-rw-r--r-- | lib/Archive/Zip/Tree.pm | 48 | ||||
-rw-r--r-- | lib/Archive/Zip/ZipFileMember.pm | 416 |
12 files changed, 3908 insertions, 0 deletions
diff --git a/lib/Archive/Zip/Archive.pm b/lib/Archive/Zip/Archive.pm new file mode 100644 index 0000000..323de61 --- /dev/null +++ b/lib/Archive/Zip/Archive.pm @@ -0,0 +1,1020 @@ +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.49'; + @ISA = qw( Archive::Zip ); + + if ($^O eq 'MSWin32') { + require Win32; + require Encode; + Encode->import(qw{ encode_utf8 decode_utf8 }); + } +} + +use Archive::Zip qw( + :CONSTANTS + :ERROR_CODES + :PKZIP_CONSTANTS + :UTILITY_METHODS +); + +our $UNICODE; + +# 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, # should be # of members + 'numberOfCentralDirectories' => 0, # should 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) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $fileName = Win32::GetANSIPathName($fileName); + } + + my $newMember = Archive::Zip::Member->newFromFile($fileName, $newName); + $newMember->desiredCompressionLevel($compressionLevel); + if ($self->{'storeSymbolicLink'} && -l $fileName) { + my $newMember = + Archive::Zip::Member->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); + } + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $newMember->{'fileName'} = + encode_utf8(Win32::GetLongPathName($fileName)); + } + 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 = + Archive::Zip::Member->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) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = Win32::GetANSIPathName($name); + } + + my $newMember = Archive::Zip::Member->newDirectoryNamed($name, $newName); + if ($self->{'storeSymbolicLink'} && -l $name) { + my $link = readlink $name; + ($newName =~ s{/$}{}) if $newName; # Strip trailing / + my $newMember = Archive::Zip::Member->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); + } + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $newMember->{'fileName'} = encode_utf8(Win32::GetLongPathName($name)); + } + 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) = @_; + } + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = Win32::GetANSIPathName($name); + } + + $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) + || File::Copy::copy($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 = + Archive::Zip::Member->_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 ($self->{'diskNumber'} == 0xFFFF || + $self->{'diskNumberWithStartOfCentralDirectory'} == 0xFFFF || + $self->{'numberOfCentralDirectoriesOnThisDisk'} == 0xFFFF || + $self->{'numberOfCentralDirectories'} == 0xFFFF || + $self->{'centralDirectorySize'} == 0xFFFFFFFF || + $self->{'centralDirectoryOffsetWRTStartingDiskNumber'} == 0xFFFFFFFF) { + return _formatError("zip64 not supported" . Dumper($self)); + } +use Data::Dumper; + 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); + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + push(@files, Win32::GetANSIPathName($File::Find::name)) if (&$pred); + $dir = Win32::GetANSIPathName($dir); + } else { + push(@files, $File::Find::name) if (&$pred); + } + chdir($dir); + }; + + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $root = Win32::GetANSIPathName($root); + } + 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; + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $isDir = -d Win32::GetANSIPathName($fileName); + } else { + $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); + if (defined $dest) { + if ($dest !~ m{/$}) { + $dest .= '/'; + } + } else { + $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 + ? Archive::Zip::Member->newDirectoryNamed($fileName, $memberName) + : Archive::Zip::Member->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 were not 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/lib/Archive/Zip/BufferedFileHandle.pm b/lib/Archive/Zip/BufferedFileHandle.pm new file mode 100644 index 0000000..7abc35d --- /dev/null +++ b/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.49'; + $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/lib/Archive/Zip/DirectoryMember.pm b/lib/Archive/Zip/DirectoryMember.pm new file mode 100644 index 0000000..640306b --- /dev/null +++ b/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.49'; + @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/lib/Archive/Zip/FAQ.pod b/lib/Archive/Zip/FAQ.pod new file mode 100644 index 0000000..d03f883 --- /dev/null +++ b/lib/Archive/Zip/FAQ.pod @@ -0,0 +1,344 @@ +=head1 NAME
+
+Archive::Zip::FAQ - Answers to a few frequently asked questions about Archive::Zip
+
+=head1 DESCRIPTION
+
+It seems that I keep answering the same questions over and over again. I
+assume that this is because my documentation is deficient, rather than that
+people don't read the documentation.
+
+So this FAQ is an attempt to cut down on the number of personal answers I have
+to give. At least I can now say "You I<did> read the FAQ, right?".
+
+The questions are not in any particular order. The answers assume the current
+version of Archive::Zip; some of the answers depend on newly added/fixed
+functionality.
+
+=head1 Install problems on RedHat 8 or 9 with Perl 5.8.0
+
+B<Q:> Archive::Zip won't install on my RedHat 9 system! It's broke!
+
+B<A:> This has become something of a FAQ.
+Basically, RedHat broke some versions of Perl by setting LANG to UTF8.
+They apparently have a fixed version out as an update.
+
+You might try running CPAN or creating your Makefile after exporting the LANG
+environment variable as
+
+C<LANG=C>
+
+L<https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
+
+=head1 Why is my zip file so big?
+
+B<Q:> My zip file is actually bigger than what I stored in it! Why?
+
+B<A:> Some things to make sure of:
+
+=over 4
+
+=item Make sure that you are requesting COMPRESSION_DEFLATED if you are storing strings.
+
+$member->desiredCompressionMethod( COMPRESSION_DEFLATED );
+
+=item Don't make lots of little files if you can help it.
+
+Since zip computes the compression tables for each member, small
+members without much entropy won't compress well. Instead, if you've
+got lots of repeated strings in your data, try to combine them into
+one big member.
+
+=item Make sure that you are requesting COMPRESSION_STORED if you are storing things that are already compressed.
+
+If you're storing a .zip, .jpg, .mp3, or other compressed file in a zip,
+then don't compress them again. They'll get bigger.
+
+=back
+
+=head1 Sample code?
+
+B<Q:> Can you send me code to do (whatever)?
+
+B<A:> Have you looked in the C<examples/> directory yet? It contains:
+
+=over 4
+
+=item examples/calcSizes.pl -- How to find out how big a Zip file will be before writing it
+
+=item examples/copy.pl -- Copies one Zip file to another
+
+=item examples/extract.pl -- extract file(s) from a Zip
+
+=item examples/mailZip.pl -- make and mail a zip file
+
+=item examples/mfh.pl -- demo for use of MockFileHandle
+
+=item examples/readScalar.pl -- shows how to use IO::Scalar as the source of a Zip read
+
+=item examples/selfex.pl -- a brief example of a self-extracting Zip
+
+=item examples/unzipAll.pl -- uses Archive::Zip::Tree to unzip an entire Zip
+
+=item examples/updateZip.pl -- shows how to read/modify/write a Zip
+
+=item examples/updateTree.pl -- shows how to update a Zip in place
+
+=item examples/writeScalar.pl -- shows how to use IO::Scalar as the destination of a Zip write
+
+=item examples/writeScalar2.pl -- shows how to use IO::String as the destination of a Zip write
+
+=item examples/zip.pl -- Constructs a Zip file
+
+=item examples/zipcheck.pl -- One way to check a Zip file for validity
+
+=item examples/zipinfo.pl -- Prints out information about a Zip archive file
+
+=item examples/zipGrep.pl -- Searches for text in Zip files
+
+=item examples/ziptest.pl -- Lists a Zip file and checks member CRCs
+
+=item examples/ziprecent.pl -- Puts recent files into a zipfile
+
+=item examples/ziptest.pl -- Another way to check a Zip file for validity
+
+=back
+
+=head1 Can't Read/modify/write same Zip file
+
+B<Q:> Why can't I open a Zip file, add a member, and write it back? I get an
+error message when I try.
+
+B<A:> Because Archive::Zip doesn't (and can't, generally) read file contents into memory,
+the original Zip file is required to stay around until the writing of the new
+file is completed.
+
+The best way to do this is to write the Zip to a temporary file and then
+rename the temporary file to have the old name (possibly after deleting the
+old one).
+
+Archive::Zip v1.02 added the archive methods C<overwrite()> and
+C<overwriteAs()> to do this simply and carefully.
+
+See C<examples/updateZip.pl> for an example of this technique.
+
+=head1 File creation time not set
+
+B<Q:> Upon extracting files, I see that their modification (and access) times are
+set to the time in the Zip archive. However, their creation time is not set to
+the same time. Why?
+
+B<A:> Mostly because Perl doesn't give cross-platform access to I<creation time>.
+Indeed, many systems (like Unix) don't support such a concept.
+However, if yours does, you can easily set it. Get the modification time from
+the member using C<lastModTime()>.
+
+=head1 Can't use Archive::Zip on gzip files
+
+B<Q:> Can I use Archive::Zip to extract Unix gzip files?
+
+B<A:> No.
+
+There is a distinction between Unix gzip files, and Zip archives that
+also can use the gzip compression.
+
+Depending on the format of the gzip file, you can use L<Compress::Raw::Zlib>, or
+L<Archive::Tar> to decompress it (and de-archive it in the case of Tar files).
+
+You can unzip PKZIP/WinZip/etc/ archives using Archive::Zip (that's what
+it's for) as long as any compressed members are compressed using
+Deflate compression.
+
+=head1 Add a directory/tree to a Zip
+
+B<Q:> How can I add a directory (or tree) full of files to a Zip?
+
+B<A:> You can use the Archive::Zip::addTree*() methods:
+
+ use Archive::Zip;
+ my $zip = Archive::Zip->new();
+ # add all readable files and directories below . as xyz/*
+ $zip->addTree( '.', 'xyz' );
+ # add all readable plain files below /abc as def/*
+ $zip->addTree( '/abc', 'def', sub { -f && -r } );
+ # add all .c files below /tmp as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
+ # add all .o files below /tmp as stuff/* if they aren't writable
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
+ # add all .so files below /tmp that are smaller than 200 bytes as stuff/*
+ $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
+ # and write them into a file
+ $zip->writeToFileNamed('xxx.zip');
+
+=head1 Extract a directory/tree
+
+B<Q:> How can I extract some (or all) files from a Zip into a different
+directory?
+
+B<A:> You can use the Archive::Zip::extractTree() method:
+??? ||
+
+ # now extract the same files into /tmpx
+ $zip->extractTree( 'stuff', '/tmpx' );
+
+=head1 Update a directory/tree
+
+B<Q:> How can I update a Zip from a directory tree, adding or replacing only
+the newer files?
+
+B<A:> You can use the Archive::Zip::updateTree() method that was added in version 1.09.
+
+=head1 Zip times might be off by 1 second
+
+B<Q:> It bothers me greatly that my file times are wrong by one second about half
+the time. Why don't you do something about it?
+
+B<A:> Get over it. This is a result of the Zip format storing times in DOS
+format, which has a resolution of only two seconds.
+
+=head1 Zip times don't include time zone information
+
+B<Q:> My file times don't respect time zones. What gives?
+
+B<A:> If this is important to you, please submit patches to read the various
+Extra Fields that encode times with time zones. I'm just using the DOS
+Date/Time, which doesn't have a time zone.
+
+=head1 How do I make a self-extracting Zip
+
+B<Q:> I want to make a self-extracting Zip file. Can I do this?
+
+B<A:> Yes. You can write a self-extracting archive stub (that is, a version of
+unzip) to the output filehandle that you pass to writeToFileHandle(). See
+examples/selfex.pl for how to write a self-extracting archive.
+
+However, you should understand that this will only work on one kind of
+platform (the one for which the stub was compiled).
+
+=head1 How can I deal with Zips with prepended garbage (i.e. from Sircam)
+
+B<Q:> How can I tell if a Zip has been damaged by adding garbage to the
+beginning or inside the file?
+
+B<A:> I added code for this for the Amavis virus scanner. You can query archives
+for their 'eocdOffset' property, which should be 0:
+
+ if ($zip->eocdOffset > 0)
+ { warn($zip->eocdOffset . " bytes of garbage at beginning or within Zip") }
+
+When members are extracted, this offset will be used to adjust the start of
+the member if necessary.
+
+=head1 Can't extract Shrunk files
+
+B<Q:> I'm trying to extract a file out of a Zip produced by PKZIP, and keep
+getting this error message:
+
+ error: Unsupported compression combination: read 6, write 0
+
+B<A:> You can't uncompress this archive member. Archive::Zip only supports uncompressed
+members, and compressed members that are compressed using the compression
+supported by Compress::Raw::Zlib. That means only Deflated and Stored members.
+
+Your file is compressed using the Shrink format, which is not supported by
+Compress::Raw::Zlib.
+
+You could, perhaps, use a command-line UnZip program (like the Info-Zip
+one) to extract this.
+
+=head1 Can't do decryption
+
+B<Q:> How do I decrypt encrypted Zip members?
+
+B<A:> With some other program or library. Archive::Zip doesn't support decryption,
+and probably never will (unless I<you> write it).
+
+=head1 How to test file integrity?
+
+B<Q:> How can Archive::Zip can test the validity of a Zip file?
+
+B<A:> If you try to decompress the file, the gzip streams will report errors
+if you have garbage. Most of the time.
+
+If you try to open the file and a central directory structure can't be
+found, an error will be reported.
+
+When a file is being read, if we can't find a proper PK.. signature in
+the right places we report a format error.
+
+If there is added garbage at the beginning of a Zip file (as inserted
+by some viruses), you can find out about it, but Archive::Zip will ignore it,
+and you can still use the archive. When it gets written back out the
+added stuff will be gone.
+
+There are two ready-to-use utilities in the examples directory that can
+be used to test file integrity, or that you can use as examples
+for your own code:
+
+=over 4
+
+=item examples/zipcheck.pl shows how to use an attempted extraction to test a file.
+
+=item examples/ziptest.pl shows how to test CRCs in a file.
+
+=back
+
+=head1 Duplicate files in Zip?
+
+B<Q:> Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this?
+
+B<A:> As far as I can tell, this is not disallowed by the Zip spec. If you
+think it's a bad idea, check for it yourself:
+
+ $zip->addFile($someFile, $someName) unless $zip->memberNamed($someName);
+
+I can even imagine cases where this might be useful (for instance, multiple
+versions of files).
+
+=head1 File ownership/permissions/ACLS/etc
+
+B<Q:> Why doesn't Archive::Zip deal with file ownership, ACLs, etc.?
+
+B<A:> There is no standard way to represent these in the Zip file format. If
+you want to send me code to properly handle the various extra fields that
+have been used to represent these through the years, I'll look at it.
+
+=head1 I can't compile but ActiveState only has an old version of Archive::Zip
+
+B<Q:> I've only installed modules using ActiveState's PPM program and
+repository. But they have a much older version of Archive::Zip than is in CPAN. Will
+you send me a newer PPM?
+
+B<A:> Probably not, unless I get lots of extra time. But there's no reason you
+can't install the version from CPAN. Archive::Zip is pure Perl, so all you need is
+NMAKE, which you can get for free from Microsoft (see the FAQ in the
+ActiveState documentation for details on how to install CPAN modules).
+
+=head1 My JPEGs (or MP3's) don't compress when I put them into Zips!
+
+B<Q:> How come my JPEGs and MP3's don't compress much when I put them into Zips?
+
+B<A:> Because they're already compressed.
+
+=head1 Under Windows, things lock up/get damaged
+
+B<Q:> I'm using Windows. When I try to use Archive::Zip, my machine locks up/makes
+funny sounds/displays a BSOD/corrupts data. How can I fix this?
+
+B<A:> First, try the newest version of Compress::Raw::Zlib. I know of
+Windows-related problems prior to v1.14 of that library.
+
+=head1 Zip contents in a scalar
+
+B<Q:> I want to read a Zip file from (or write one to) a scalar variable instead
+of a file. How can I do this?
+
+B<A:> Use C<IO::String> and the C<readFromFileHandle()> and
+C<writeToFileHandle()> methods.
+See C<examples/readScalar.pl> and C<examples/writeScalar.pl>.
+
+=head1 Reading from streams
+
+B<Q:> How do I read from a stream (like for the Info-Zip C<funzip> program)?
+
+B<A:> This is not currently supported, though writing to a stream is.
diff --git a/lib/Archive/Zip/FileMember.pm b/lib/Archive/Zip/FileMember.pm new file mode 100644 index 0000000..5f1066e --- /dev/null +++ b/lib/Archive/Zip/FileMember.pm @@ -0,0 +1,64 @@ +package Archive::Zip::FileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.49'; + @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/lib/Archive/Zip/Member.pm b/lib/Archive/Zip/Member.pm new file mode 100644 index 0000000..0026aa6 --- /dev/null +++ b/lib/Archive/Zip/Member.pm @@ -0,0 +1,1247 @@ +package Archive::Zip::Member; + +# A generic member of an archive + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.49'; + @ISA = qw( Archive::Zip ); + + if ($^O eq 'MSWin32') { + require Win32; + require Encode; + Encode->import(qw{ decode_utf8 }); + } +} + +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; + +# 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 = Archive::Zip::ZipFileMember->_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 = + Archive::Zip::StringMember->_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 = + Archive::Zip::NewFileMember->_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 = + Archive::Zip::DirectoryMember->_newNamed($directoryName, $newName); + return $self; +} + +sub new { + my $class = shift; + my $self = { + 'lastModFileDateTime' => 0, + 'fileAttributeFormat' => FA_UNIX, + 'versionMadeBy' => 20, + 'versionNeededToExtract' => 20, + 'bitFlag' => ($Archive::Zip::UNICODE ? 0x0800 : 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, + 'password' => undef, # password for encrypted data + 'crc32c' => -1, # crc for decrypted data + @_ + }; + bless($self, $class); + $self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS); + return $self; +} + +sub _becomeDirectoryIfNecessary { + my $self = shift; + $self->_become('Archive::Zip::DirectoryMember') + 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; + } + + if ($Archive::Zip::UNICODE) { + $self->{'bitFlag'} |= 0x0800; + } + $self->{'bitFlag'}; +} + +sub password { + my $self = shift; + $self->{'password'} = shift if @_; + $self->{'password'}; +} + +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 + if $self->uncompressedSize() == 0; + } 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 (defined $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 is not 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(); + + my ($status, $fh); + if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) { + $name = decode_utf8(Win32::GetFullPathName($name)); + mkpath_win32($name); + Win32::CreateFile($name); + ($status, $fh) = _newFileHandle(Win32::GetANSIPathName($name), 'w'); + } else { + mkpath(dirname($name)); # croaks on error + ($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 mkpath_win32 { + my $path = shift; + use File::Spec; + + my ($volume, @path) = File::Spec->splitdir($path); + $path = File::Spec->catfile($volume, shift @path); + pop @path; + while (@path) { + $path = File::Spec->catfile($path, shift @path); + Win32::CreateDirectory($path); + } +} + +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; + { + use bytes; + 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; + { + use bytes; + 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 is not 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; +} + +sub head { + my ($self, $mode) = (@_, 0); + + use bytes; + return pack LOCAL_FILE_HEADER_FORMAT, + $self->versionNeededToExtract(), + $self->{'bitFlag'}, + $self->desiredCompressionMethod(), + $self->lastModFileDateTime(), + $self->hasDataDescriptor() + ? (0,0,0) # crc, compr & uncompr all zero if data descriptor present + : ( + $self->crc32(), + $mode + ? $self->_writeOffset() # compressed size + : $self->compressedSize(), # may need to be re-written later + $self->uncompressedSize(), + ), + length($self->fileName()), + length($self->localExtraField()); +} + +# 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 = $self->head(1); + + $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, $extraFieldLength, $fileCommentLength); + { + use bytes; + $fileNameLength = length($self->fileName()); + $extraFieldLength = length($self->cdExtraField()); + $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 = $self->head(1); + + $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; + + $buffer && $self->isEncrypted and $buffer = $self->_decode($buffer); + $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('Archive::Zip::StringMember'); + 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; + 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; + } + } + return AZ_OK; +} + +# Return true if I depend on the named file +sub _usesFileNamed { + return 0; +} + +# ############################################################################## +# +# Decrypt section +# +# H.Merijn Brand (Tux) 2011-06-28 +# +# ############################################################################## + +# This code is derived from the crypt source of unzip-6.0 dated 05 Jan 2007 +# Its license states: +# +# --8<--- +# Copyright (c) 1990-2007 Info-ZIP. All rights reserved. + +# See the accompanying file LICENSE, version 2005-Feb-10 or later +# (the contents of which are also included in (un)zip.h) for terms of use. +# If, for some reason, all these files are missing, the Info-ZIP license +# also may be found at: ftp://ftp.info-zip.org/pub/infozip/license.html +# +# crypt.c (full version) by Info-ZIP. Last revised: [see crypt.h] + +# The main encryption/decryption source code for Info-Zip software was +# originally written in Europe. To the best of our knowledge, it can +# be freely distributed in both source and object forms from any country, +# including the USA under License Exception TSU of the U.S. Export +# Administration Regulations (section 740.13(e)) of 6 June 2002. + +# NOTE on copyright history: +# Previous versions of this source package (up to version 2.8) were +# not copyrighted and put in the public domain. If you cannot comply +# with the Info-Zip LICENSE, you may want to look for one of those +# public domain versions. +# +# This encryption code is a direct transcription of the algorithm from +# Roger Schlafly, described by Phil Katz in the file appnote.txt. This +# file (appnote.txt) is distributed with the PKZIP program (even in the +# version without encryption capabilities). +# -->8--- + +# As of January 2000, US export regulations were amended to allow export +# of free encryption source code from the US. As of June 2002, these +# regulations were further relaxed to allow export of encryption binaries +# associated with free encryption source code. The Zip 2.31, UnZip 5.52 +# and Wiz 5.02 archives now include full crypto source code. As of the +# Zip 2.31 release, all official binaries include encryption support; the +# former "zcr" archives ceased to exist. +# (Note that restrictions may still exist in other countries, of course.) + +# For now, we just support the decrypt stuff +# All below methods are supposed to be private + +# use Data::Peek; + +my @keys; +my @crct = do { + my $xor = 0xedb88320; + my @crc = (0) x 1024; + + # generate a crc for every 8-bit value + foreach my $n (0 .. 255) { + my $c = $n; + $c = $c & 1 ? $xor ^ ($c >> 1) : $c >> 1 for 1 .. 8; + $crc[$n] = _revbe($c); + } + + # generate crc for each value followed by one, two, and three zeros */ + foreach my $n (0 .. 255) { + my $c = ($crc[($crc[$n] >> 24) ^ 0] ^ ($crc[$n] << 8)) & 0xffffffff; + $crc[$_ * 256 + $n] = $c for 1 .. 3; + } + map { _revbe($crc[$_]) } 0 .. 1023; +}; + +sub _crc32 { + my ($c, $b) = @_; + return ($crct[($c ^ $b) & 0xff] ^ ($c >> 8)); +} # _crc32 + +sub _revbe { + my $w = shift; + return (($w >> 24) + + (($w >> 8) & 0xff00) + + (($w & 0xff00) << 8) + + (($w & 0xff) << 24)); +} # _revbe + +sub _update_keys { + use integer; + my $c = shift; # signed int + $keys[0] = _crc32($keys[0], $c); + $keys[1] = (($keys[1] + ($keys[0] & 0xff)) * 0x08088405 + 1) & 0xffffffff; + my $keyshift = $keys[1] >> 24; + $keys[2] = _crc32($keys[2], $keyshift); +} # _update_keys + +sub _zdecode ($) { + my $c = shift; + my $t = ($keys[2] & 0xffff) | 2; + _update_keys($c ^= ((($t * ($t ^ 1)) >> 8) & 0xff)); + return $c; +} # _zdecode + +sub _decode { + my $self = shift; + my $buff = shift; + + $self->isEncrypted or return $buff; + + my $pass = $self->password; + defined $pass or return ""; + + @keys = (0x12345678, 0x23456789, 0x34567890); + _update_keys($_) for unpack "C*", $pass; + + # DDumper { uk => [ @keys ] }; + + my $head = substr $buff, 0, 12, ""; + my @head = map { _zdecode($_) } unpack "C*", $head; + my $x = + $self->{externalFileAttributes} + ? ($self->{lastModFileDateTime} >> 8) & 0xff + : $self->{crc32} >> 24; + $head[-1] == $x or return ""; # Password fail + + # Worth checking ... + $self->{crc32c} = (unpack LOCAL_FILE_HEADER_FORMAT, pack "C*", @head)[3]; + + # DHexDump ($buff); + $buff = pack "C*" => map { _zdecode($_) } unpack "C*" => $buff; + + # DHexDump ($buff); + return $buff; +} # _decode + +1; diff --git a/lib/Archive/Zip/MemberRead.pm b/lib/Archive/Zip/MemberRead.pm new file mode 100644 index 0000000..e0f0b14 --- /dev/null +++ b/lib/Archive/Zip/MemberRead.pm @@ -0,0 +1,348 @@ +package Archive::Zip::MemberRead; + +=head1 NAME + +Archive::Zip::MemberRead - A wrapper that lets you read Zip archive members as if they were files. + +=cut + +=head1 SYNOPSIS + + use Archive::Zip; + use Archive::Zip::MemberRead; + $zip = Archive::Zip->new("file.zip"); + $fh = Archive::Zip::MemberRead->new($zip, "subdir/abc.txt"); + while (defined($line = $fh->getline())) + { + print $fh->input_line_number . "#: $line\n"; + } + + $read = $fh->read($buffer, 32*1024); + print "Read $read bytes as :$buffer:\n"; + +=head1 DESCRIPTION + +The Archive::Zip::MemberRead module lets you read Zip archive member data +just like you read data from files. + +=head1 METHODS + +=over 4 + +=cut + +use strict; + +use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); + +use vars qw{$VERSION}; + +my $nl; + +BEGIN { + $VERSION = '1.49'; + $VERSION = eval $VERSION; + +# Requirement for newline conversion. Should check for e.g., DOS and OS/2 as well, but am too lazy. + $nl = $^O eq 'MSWin32' ? "\r\n" : "\n"; +} + +=item Archive::Zip::Member::readFileHandle() + +You can get a C<Archive::Zip::MemberRead> from an archive member by +calling C<readFileHandle()>: + + my $member = $zip->memberNamed('abc/def.c'); + my $fh = $member->readFileHandle(); + while (defined($line = $fh->getline())) + { + # ... + } + $fh->close(); + +=cut + +sub Archive::Zip::Member::readFileHandle { + return Archive::Zip::MemberRead->new(shift()); +} + +=item Archive::Zip::MemberRead->new($zip, $fileName) + +=item Archive::Zip::MemberRead->new($zip, $member) + +=item Archive::Zip::MemberRead->new($member) + +Construct a new Archive::Zip::MemberRead on the specified member. + + my $fh = Archive::Zip::MemberRead->new($zip, 'fred.c') + +=cut + +sub new { + my ($class, $zip, $file) = @_; + my ($self, $member); + + if ($zip && $file) # zip and filename, or zip and member + { + $member = ref($file) ? $file : $zip->memberNamed($file); + } elsif ($zip && !$file && ref($zip)) # just member + { + $member = $zip; + } else { + die( + 'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member' + ); + } + + $self = {}; + bless($self, $class); + $self->set_member($member); + return $self; +} + +sub set_member { + my ($self, $member) = @_; + + $self->{member} = $member; + $self->set_compression(COMPRESSION_STORED); + $self->rewind(); +} + +sub set_compression { + my ($self, $compression) = @_; + $self->{member}->desiredCompressionMethod($compression) if $self->{member}; +} + +=item setLineEnd(expr) + +Set the line end character to use. This is set to \n by default +except on Windows systems where it is set to \r\n. You will +only need to set this on systems which are not Windows or Unix +based and require a line end different from \n. +This is a class method so call as C<Archive::Zip::MemberRead>->C<setLineEnd($nl)> + +=cut + +sub setLineEnd { + shift; + $nl = shift; +} + +=item rewind() + +Rewinds an C<Archive::Zip::MemberRead> so that you can read from it again +starting at the beginning. + +=cut + +sub rewind { + my $self = shift; + + $self->_reset_vars(); + $self->{member}->rewindData() if $self->{member}; +} + +sub _reset_vars { + my $self = shift; + + $self->{line_no} = 0; + $self->{at_end} = 0; + + delete $self->{buffer}; +} + +=item input_record_separator(expr) + +If the argument is given, input_record_separator for this +instance is set to it. The current setting (which may be +the global $/) is always returned. + +=cut + +sub input_record_separator { + my $self = shift; + if (@_) { + $self->{sep} = shift; + $self->{sep_re} = + _sep_as_re($self->{sep}); # Cache the RE as an optimization + } + return exists $self->{sep} ? $self->{sep} : $/; +} + +# Return the input_record_separator in use as an RE fragment +# Note that if we have a per-instance input_record_separator +# we can just return the already converted value. Otherwise, +# the conversion must be done on $/ every time since we cannot +# know whether it has changed or not. +sub _sep_re { + my $self = shift; + + # Important to phrase this way: sep's value may be undef. + return exists $self->{sep} ? $self->{sep_re} : _sep_as_re($/); +} + +# Convert the input record separator into an RE and return it. +sub _sep_as_re { + my $sep = shift; + if (defined $sep) { + if ($sep eq '') { + return "(?:$nl){2,}"; + } else { + $sep =~ s/\n/$nl/og; + return quotemeta $sep; + } + } else { + return undef; + } +} + +=item input_line_number() + +Returns the current line number, but only if you're using C<getline()>. +Using C<read()> will not update the line number. + +=cut + +sub input_line_number { + my $self = shift; + return $self->{line_no}; +} + +=item close() + +Closes the given file handle. + +=cut + +sub close { + my $self = shift; + + $self->_reset_vars(); + $self->{member}->endRead(); +} + +=item buffer_size([ $size ]) + +Gets or sets the buffer size used for reads. +Default is the chunk size used by Archive::Zip. + +=cut + +sub buffer_size { + my ($self, $size) = @_; + + if (!$size) { + return $self->{chunkSize} || Archive::Zip::chunkSize(); + } else { + $self->{chunkSize} = $size; + } +} + +=item getline() + +Returns the next line from the currently open member. +Makes sense only for text files. +A read error is considered fatal enough to die. +Returns undef on eof. All subsequent calls would return undef, +unless a rewind() is called. +Note: The line returned has the input_record_separator (default: newline) removed. + +=item getline( { preserve_line_ending => 1 } ) + +Returns the next line including the line ending. + +=cut + +sub getline { + my ($self, $argref) = @_; + + my $size = $self->buffer_size(); + my $sep = $self->_sep_re(); + + my $preserve_line_ending; + if (ref $argref eq 'HASH') { + $preserve_line_ending = $argref->{'preserve_line_ending'}; + $sep =~ s/\\([^A-Za-z_0-9])+/$1/g; + } + + for (; ;) { + if ( $sep + && defined($self->{buffer}) + && $self->{buffer} =~ s/^(.*?)$sep//s) { + my $line = $1; + $self->{line_no}++; + if ($preserve_line_ending) { + return $line . $sep; + } else { + return $line; + } + } elsif ($self->{at_end}) { + $self->{line_no}++ if $self->{buffer}; + return delete $self->{buffer}; + } + my ($temp, $status) = $self->{member}->readChunk($size); + if ($status != AZ_OK && $status != AZ_STREAM_END) { + die "ERROR: Error reading chunk from archive - $status"; + } + $self->{at_end} = $status == AZ_STREAM_END; + $self->{buffer} .= $$temp; + } +} + +=item read($buffer, $num_bytes_to_read) + +Simulates a normal C<read()> system call. +Returns the no. of bytes read. C<undef> on error, 0 on eof, I<e.g.>: + + $fh = Archive::Zip::MemberRead->new($zip, "sreeji/secrets.bin"); + while (1) + { + $read = $fh->read($buffer, 1024); + die "FATAL ERROR reading my secrets !\n" if (!defined($read)); + last if (!$read); + # Do processing. + .... + } + +=cut + +# +# All these $_ are required to emulate read(). +# +sub read { + my $self = $_[0]; + my $size = $_[2]; + my ($temp, $status, $ret); + + ($temp, $status) = $self->{member}->readChunk($size); + if ($status != AZ_OK && $status != AZ_STREAM_END) { + $_[1] = undef; + $ret = undef; + } else { + $_[1] = $$temp; + $ret = length($$temp); + } + return $ret; +} + +1; + +=back + +=head1 AUTHOR + +Sreeji K. Das E<lt>sreeji_k@yahoo.comE<gt> + +See L<Archive::Zip> by Ned Konz without which this module does not make +any sense! + +Minor mods by Ned Konz. + +=head1 COPYRIGHT + +Copyright 2002 Sreeji K. Das. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Archive/Zip/MockFileHandle.pm b/lib/Archive/Zip/MockFileHandle.pm new file mode 100644 index 0000000..8065f95 --- /dev/null +++ b/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.49'; + $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/lib/Archive/Zip/NewFileMember.pm b/lib/Archive/Zip/NewFileMember.pm new file mode 100644 index 0000000..928d489 --- /dev/null +++ b/lib/Archive/Zip/NewFileMember.pm @@ -0,0 +1,77 @@ +package Archive::Zip::NewFileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.49'; + @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/lib/Archive/Zip/StringMember.pm b/lib/Archive/Zip/StringMember.pm new file mode 100644 index 0000000..50e74c6 --- /dev/null +++ b/lib/Archive/Zip/StringMember.pm @@ -0,0 +1,64 @@ +package Archive::Zip::StringMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.49'; + @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/lib/Archive/Zip/Tree.pm b/lib/Archive/Zip/Tree.pm new file mode 100644 index 0000000..303a057 --- /dev/null +++ b/lib/Archive/Zip/Tree.pm @@ -0,0 +1,48 @@ +package Archive::Zip::Tree; + +use strict; +use vars qw{$VERSION}; + +BEGIN { + $VERSION = '1.49'; +} + +use Archive::Zip; + +warn( + "Archive::Zip::Tree is deprecated; its methods have been moved into Archive::Zip." +) if $^W; + +1; + +__END__ + +=head1 NAME + +Archive::Zip::Tree - (DEPRECATED) methods for adding/extracting trees using Archive::Zip + +=head1 DESCRIPTION + +This module is deprecated, because all its methods were moved into the main +Archive::Zip module. + +It is included in the distribution merely to avoid breaking old code. + +See L<Archive::Zip>. + +=head1 AUTHOR + +Ned Konz, perl@bike-nomad.com + +=head1 COPYRIGHT + +Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=head1 SEE ALSO + +L<Archive::Zip> + +=cut + diff --git a/lib/Archive/Zip/ZipFileMember.pm b/lib/Archive/Zip/ZipFileMember.pm new file mode 100644 index 0000000..cd4c875 --- /dev/null +++ b/lib/Archive/Zip/ZipFileMember.pm @@ -0,0 +1,416 @@ +package Archive::Zip::ZipFileMember; + +use strict; +use vars qw( $VERSION @ISA ); + +BEGIN { + $VERSION = '1.49'; + @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 is not, I assume that +# I've already read the local header. +# Return ( $status, $self ) + +sub _become { + my $self = shift; + my $newClass = shift; + return $self if ref($self) eq $newClass; + + my $status = AZ_OK; + + if (_isSeekable($self->fh())) { + my $here = $self->fh()->tell(); + $status = $self->_seekToLocalHeader(); + $status = $self->_readLocalFileHeader() if $status == AZ_OK; + $self->fh()->seek($here, IO::Seekable::SEEK_SET); + return $status unless $status == AZ_OK; + } + + delete($self->{'eocdCrc32'}); + delete($self->{'diskNumberStart'}); + delete($self->{'localHeaderRelativeOffset'}); + delete($self->{'dataOffset'}); + + 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; + + # The buffer withe encrypted data is prefixed with a new + # encrypted 12 byte header. The size only changes when + # the buffer is also compressed + $self->isEncrypted && $oldUncompressedSize > $self->{uncompressedSize} + and $oldUncompressedSize -= DATA_DESCRIPTOR_LENGTH; + + return _formatError( + "CRC or size mismatch while skipping data descriptor") + if ( $oldCrc32 != $self->{'crc32'} + || $oldUncompressedSize != $self->{'uncompressedSize'}); + + $self->{'crc32'} = 0 + if $self->compressionMethod() == COMPRESSION_STORED ; + } + + return AZ_OK; +} + +# Read from a local file header into myself. Returns AZ_OK 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 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; |