1 package Archive
::Zip
::Archive
;
3 # Represents a generic ZIP archive
13 use vars
qw( $VERSION @ISA );
17 @ISA = qw( Archive::Zip );
27 # Note that this returns undef on read errors, else new zip object.
34 'diskNumberWithStartOfCentralDirectory' => 0,
35 'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
36 'numberOfCentralDirectories' => 0, # shld be # of members
37 'centralDirectorySize' => 0, # must re-compute on write
38 'centralDirectoryOffsetWRTStartingDiskNumber' =>
40 'writeEOCDOffset' => 0,
41 'writeCentralDirectoryOffset' => 0,
42 'zipfileComment' => '',
48 $self->{'members'} = [];
50 my $status = $self->read(@_);
51 return $status == AZ_OK ?
$self : undef;
57 @
{ shift->{'members'} };
61 scalar( shift->members() );
66 return map { $_->fileName() } $self->members();
69 # return ref to member with given name or undef
71 my ( $self, $fileName ) = @_;
72 foreach my $member ( $self->members() ) {
73 return $member if $member->fileName() eq $fileName;
79 my ( $self, $pattern ) = @_;
80 return grep { $_->fileName() =~ /$pattern/ } $self->members();
84 shift->{'diskNumber'};
87 sub diskNumberWithStartOfCentralDirectory
{
88 shift->{'diskNumberWithStartOfCentralDirectory'};
91 sub numberOfCentralDirectoriesOnThisDisk
{
92 shift->{'numberOfCentralDirectoriesOnThisDisk'};
95 sub numberOfCentralDirectories
{
96 shift->{'numberOfCentralDirectories'};
99 sub centralDirectorySize
{
100 shift->{'centralDirectorySize'};
103 sub centralDirectoryOffsetWRTStartingDiskNumber
{
104 shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
109 my $comment = $self->{'zipfileComment'};
111 $self->{'zipfileComment'} = pack( 'C0a*', shift() ); # avoid unicode
117 shift->{'eocdOffset'};
120 # Return the name of the file last read.
126 my ( $self, $member ) = @_;
127 $member = $self->memberNamed($member) unless ref($member);
128 return undef unless $member;
129 my @newMembers = grep { $_ != $member } $self->members();
130 $self->{'members'} = \
@newMembers;
135 my ( $self, $oldMember, $newMember ) = @_;
136 $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
137 return undef unless $oldMember;
138 return undef unless $newMember;
140 map { ( $_ == $oldMember ) ?
$newMember : $_ } $self->members();
141 $self->{'members'} = \
@newMembers;
148 $member = $self->memberNamed($member) unless ref($member);
149 return _error
('member not found') unless $member;
150 my $originalSize = $member->compressedSize();
151 my $name = shift; # local FS name if given
152 my ( $volumeName, $dirName, $fileName );
153 if ( defined($name) ) {
154 ( $volumeName, $dirName, $fileName ) = File
::Spec
->splitpath($name);
155 $dirName = File
::Spec
->catpath( $volumeName, $dirName, '' );
158 $name = $member->fileName();
159 ( $dirName = $name ) =~ s{[^/]*$}{};
160 $dirName = Archive
::Zip
::_asLocalName
($dirName);
161 $name = Archive
::Zip
::_asLocalName
($name);
163 if ( $dirName && !-d
$dirName ) {
165 return _ioError
("can't create dir $dirName") if ( !-d
$dirName );
167 my $rc = $member->extractToFileNamed( $name, @_ );
169 # TODO refactor this fix into extractToFileNamed()
170 $member->{'compressedSize'} = $originalSize;
174 sub extractMemberWithoutPaths
{
177 $member = $self->memberNamed($member) unless ref($member);
178 return _error
('member not found') unless $member;
179 my $originalSize = $member->compressedSize();
180 return AZ_OK
if $member->isDirectory();
183 $name = $member->fileName();
184 $name =~ s{.*/}{}; # strip off directories, if any
185 $name = Archive
::Zip
::_asLocalName
($name);
187 my $rc = $member->extractToFileNamed( $name, @_ );
188 $member->{'compressedSize'} = $originalSize;
193 my ( $self, $newMember ) = @_;
194 push( @
{ $self->{'members'} }, $newMember ) if $newMember;
200 my $fileName = shift;
202 my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
203 $self->addMember($newMember) if defined($newMember);
209 my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
210 return $self->addMember($newMember);
214 my ( $self, $name, $newName ) = @_;
215 my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
216 $self->addMember($newMember);
220 # add either a file or a directory.
222 sub addFileOrDirectory
{
223 my ( $self, $name, $newName ) = @_;
225 ( $newName =~ s{/$}{} ) if $newName;
226 return $self->addFile( $name, $newName );
229 ( $newName =~ s{[^/]$}{&/} ) if $newName;
230 return $self->addDirectory( $name, $newName );
233 return _error
("$name is neither a file nor a directory");
238 my ( $self, $member, $newContents ) = @_;
239 return _error
('No member name given') unless $member;
240 $member = $self->memberNamed($member) unless ref($member);
241 return undef unless $member;
242 return $member->contents($newContents);
245 sub writeToFileNamed
{
247 my $fileName = shift; # local FS format
248 foreach my $member ( $self->members() ) {
249 if ( $member->_usesFileNamed($fileName) ) {
250 return _error
( "$fileName is needed by member "
251 . $member->fileName()
252 . "; consider using overwrite() or overwriteAs() instead." );
255 my ( $status, $fh ) = _newFileHandle
( $fileName, 'w' );
256 return _ioError
("Can't open $fileName for write") unless $status;
257 my $retval = $self->writeToFileHandle( $fh, 1 );
264 # It is possible to write data to the FH before calling this,
265 # perhaps to make a self-extracting archive.
266 sub writeToFileHandle
{
269 return _error
('No filehandle given') unless $fh;
270 return _ioError
('filehandle not open') unless $fh->opened();
272 my $fhIsSeekable = @_ ?
shift: _isSeekable
($fh);
275 # Find out where the current position is.
276 my $offset = $fhIsSeekable ?
$fh->tell() : 0;
277 $offset = 0 if $offset < 0;
279 foreach my $member ( $self->members() ) {
280 my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
282 return $retval if $retval != AZ_OK
;
283 $offset += $member->_localHeaderSize() + $member->_writeOffset();
285 $member->hasDataDescriptor()
286 ? DATA_DESCRIPTOR_LENGTH
+ SIGNATURE_LENGTH
289 # changed this so it reflects the last successful position
290 $self->{'writeCentralDirectoryOffset'} = $offset;
292 return $self->writeCentralDirectory($fh);
295 # Write zip back to the original file,
296 # as safely as possible.
297 # Returns AZ_OK if successful.
300 return $self->overwriteAs( $self->{'fileName'} );
303 # Write zip to the specified file,
304 # as safely as possible.
305 # Returns AZ_OK if successful.
309 return _error
("no filename in overwriteAs()") unless defined($zipName);
311 my ( $fh, $tempName ) = Archive
::Zip
::tempFile
();
312 return _error
( "Can't open temp file", $! ) unless $fh;
314 ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
316 my $status = $self->writeToFileHandle($fh);
320 if ( $status != AZ_OK
) {
322 _printError
("Can't write to $tempName");
329 if ( -f
$zipName && !rename( $zipName, $backupName ) ) {
332 return _error
( "Can't rename $zipName as $backupName", $err );
335 # move the temp to the original name (possibly copying)
336 unless ( File
::Copy
::move
( $tempName, $zipName ) ) {
338 rename( $backupName, $zipName );
340 return _error
( "Can't move $tempName to $zipName", $err );
344 if ( -f
$backupName && !unlink($backupName) ) {
346 return _error
( "Can't unlink $backupName", $err );
352 # Used only during writing
353 sub _writeCentralDirectoryOffset
{
354 shift->{'writeCentralDirectoryOffset'};
357 sub _writeEOCDOffset
{
358 shift->{'writeEOCDOffset'};
361 # Expects to have _writeEOCDOffset() set
362 sub _writeEndOfCentralDirectory
{
363 my ( $self, $fh ) = @_;
365 $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING
)
366 or return _ioError
('writing EOCD Signature');
367 my $zipfileCommentLength = length( $self->zipfileComment() );
370 END_OF_CENTRAL_DIRECTORY_FORMAT
,
372 0, # {'diskNumberWithStartOfCentralDirectory'},
373 $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
374 $self->numberOfMembers(), # {'numberOfCentralDirectories'},
375 $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
376 $self->_writeCentralDirectoryOffset(),
377 $zipfileCommentLength
379 $self->_print($fh, $header)
380 or return _ioError
('writing EOCD header');
381 if ($zipfileCommentLength) {
382 $self->_print($fh, $self->zipfileComment() )
383 or return _ioError
('writing zipfile comment');
388 # $offset can be specified to truncate a zip file.
389 sub writeCentralDirectory
{
390 my ( $self, $fh, $offset ) = @_;
392 if ( defined($offset) ) {
393 $self->{'writeCentralDirectoryOffset'} = $offset;
394 $fh->seek( $offset, IO
::Seekable
::SEEK_SET
)
395 or return _ioError
('seeking to write central directory');
398 $offset = $self->_writeCentralDirectoryOffset();
401 foreach my $member ( $self->members() ) {
402 my $status = $member->_writeCentralDirectoryFileHeader($fh);
403 return $status if $status != AZ_OK
;
404 $offset += $member->_centralDirectoryHeaderSize();
405 $self->{'writeEOCDOffset'} = $offset;
407 return $self->_writeEndOfCentralDirectory($fh);
412 my $fileName = shift;
413 return _error
('No filename given') unless $fileName;
414 my ( $status, $fh ) = _newFileHandle
( $fileName, 'r' );
415 return _ioError
("opening $fileName for read") unless $status;
417 $status = $self->readFromFileHandle( $fh, $fileName );
418 return $status if $status != AZ_OK
;
421 $self->{'fileName'} = $fileName;
425 sub readFromFileHandle
{
428 my $fileName = shift;
429 $fileName = $fh unless defined($fileName);
430 return _error
('No filehandle given') unless $fh;
431 return _ioError
('filehandle not open') unless $fh->opened();
434 $self->{'fileName'} = "$fh";
436 # TODO: how to support non-seekable zips?
437 return _error
('file not seekable')
438 unless _isSeekable
($fh);
440 $fh->seek( 0, 0 ); # rewind the file
442 my $status = $self->_findEndOfCentralDirectory($fh);
443 return $status if $status != AZ_OK
;
445 my $eocdPosition = $fh->tell();
447 $status = $self->_readEndOfCentralDirectory($fh);
448 return $status if $status != AZ_OK
;
450 $fh->seek( $eocdPosition - $self->centralDirectorySize(),
451 IO
::Seekable
::SEEK_SET
)
452 or return _ioError
("Can't seek $fileName");
454 # Try to detect garbage at beginning of archives
456 $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
457 - $self->centralDirectoryOffsetWRTStartingDiskNumber();
461 $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
462 $self->eocdOffset() );
464 ( $status, $signature ) = _readSignature
( $fh, $fileName );
465 return $status if $status != AZ_OK
;
466 last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE
;
467 $status = $newMember->_readCentralDirectoryFileHeader();
468 return $status if $status != AZ_OK
;
469 $status = $newMember->endRead();
470 return $status if $status != AZ_OK
;
471 $newMember->_becomeDirectoryIfNecessary();
472 push( @
{ $self->{'members'} }, $newMember );
478 # Read EOCD, starting from position before signature.
479 # Return AZ_OK on success.
480 sub _readEndOfCentralDirectory
{
484 # Skip past signature
485 $fh->seek( SIGNATURE_LENGTH
, IO
::Seekable
::SEEK_CUR
)
486 or return _ioError
("Can't seek past EOCD signature");
489 my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH
);
490 if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH
) {
491 return _ioError
("reading end of central directory");
494 my $zipfileCommentLength;
496 $self->{'diskNumber'},
497 $self->{'diskNumberWithStartOfCentralDirectory'},
498 $self->{'numberOfCentralDirectoriesOnThisDisk'},
499 $self->{'numberOfCentralDirectories'},
500 $self->{'centralDirectorySize'},
501 $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
502 $zipfileCommentLength
503 ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT
, $header );
505 if ($zipfileCommentLength) {
506 my $zipfileComment = '';
507 $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
508 if ( $bytesRead != $zipfileCommentLength ) {
509 return _ioError
("reading zipfile comment");
511 $self->{'zipfileComment'} = $zipfileComment;
517 # Seek in my file to the end, then read backwards until we find the
518 # signature of the central directory record. Leave the file positioned right
519 # before the signature. Returns AZ_OK if success.
520 sub _findEndOfCentralDirectory
{
524 $fh->seek( 0, IO
::Seekable
::SEEK_END
)
525 or return _ioError
("seeking to end");
527 my $fileLength = $fh->tell();
528 if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH
+ 4 ) {
529 return _formatError
("file is too short");
536 $seekOffset = $fileLength if ( $seekOffset > $fileLength );
537 $fh->seek( -$seekOffset, IO
::Seekable
::SEEK_END
)
538 or return _ioError
("seek failed");
539 my $bytesRead = $fh->read( $data, $seekOffset );
540 if ( $bytesRead != $seekOffset ) {
541 return _ioError
("read failed");
543 $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING
);
546 or $seekOffset == $fileLength
547 or $seekOffset >= $Archive::Zip
::ChunkSize
);
551 $fh->seek( $pos - $seekOffset, IO
::Seekable
::SEEK_CUR
)
552 or return _ioError
("seeking to EOCD");
556 return _formatError
("can't find EOCD signature");
560 # Used to avoid taint problems when chdir'ing.
561 # Not intended to increase security in any way; just intended to shut up the -T
562 # complaints. If your Cwd module is giving you unreliable returns from cwd()
563 # you have bigger problems than this.
566 $dir =~ m/\A(.+)\z/s;
572 my $root = shift or return _error
("root arg missing in call to addTree()");
574 $dest = '' unless defined($dest);
575 my $pred = shift || sub { -r
};
577 my $startDir = _untaintDir
( cwd
() );
579 return _error
( 'undef returned by _untaintDir on cwd ', cwd
() )
582 # This avoids chdir'ing in Find, in a way compatible with older
583 # versions of File::Find.
585 local $main::_
= $File::Find
::name
;
586 my $dir = _untaintDir
($File::Find
::dir
);
588 push( @files, $File::Find
::name
) if (&$pred);
592 File
::Find
::find
( $wanted, $root );
594 my $rootZipName = _asZipDirName
( $root, 1 ); # with trailing slash
595 my $pattern = $rootZipName eq './' ?
'^' : "^\Q$rootZipName\E";
597 $dest = _asZipDirName
( $dest, 1 ); # with trailing slash
599 foreach my $fileName (@files) {
600 my $isDir = -d
$fileName;
602 # normalize, remove leading ./
603 my $archiveName = _asZipDirName
( $fileName, $isDir );
604 if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
605 else { $archiveName =~ s{$pattern}{$dest} }
606 next if $archiveName =~ m{^\.?/?$}; # skip current dir
608 ?
$self->addDirectory( $fileName, $archiveName )
609 : $self->addFile( $fileName, $archiveName );
610 return _error
("add $fileName failed in addTree()") if !$member;
615 sub addTreeMatching
{
618 or return _error
("root arg missing in call to addTreeMatching()");
620 $dest = '' unless defined($dest);
622 or return _error
("pattern missing in call to addTreeMatching()");
625 $pred ?
sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r
};
626 return $self->addTree( $root, $dest, $matcher );
629 # $zip->extractTree( $root, $dest [, $volume] );
631 # $root and $dest are Unix-style.
632 # $volume is in local FS format.
636 my $root = shift; # Zip format
637 $root = '' unless defined($root);
638 my $dest = shift; # Zip format
639 $dest = './' unless defined($dest);
640 my $volume = shift; # optional
641 my $pattern = "^\Q$root";
642 my @members = $self->membersMatching($pattern);
644 foreach my $member (@members) {
645 my $fileName = $member->fileName(); # in Unix format
646 $fileName =~ s{$pattern}{$dest}; # in Unix format
647 # convert to platform format:
648 $fileName = Archive
::Zip
::_asLocalName
( $fileName, $volume );
649 my $status = $member->extractToFileNamed($fileName);
650 return $status if $status != AZ_OK
;
655 # $zip->updateMember( $memberOrName, $fileName );
656 # Returns (possibly updated) member, if any; undef on errors.
660 my $oldMember = shift;
661 my $fileName = shift;
663 if ( !defined($fileName) ) {
664 _error
("updateMember(): missing fileName argument");
668 my @newStat = stat($fileName);
670 _ioError
("Can't stat $fileName");
678 if ( ref($oldMember) ) {
679 $memberName = $oldMember->fileName();
682 $oldMember = $self->memberNamed( $memberName = $oldMember )
683 || $self->memberNamed( $memberName =
684 _asZipDirName
( $oldMember, $isDir ) );
687 unless ( defined($oldMember)
688 && $oldMember->lastModTime() == $newStat[9]
689 && $oldMember->isDirectory() == $isDir
690 && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
693 # create the new member
694 my $newMember = $isDir
695 ?
$self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
696 : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
698 unless ( defined($newMember) ) {
699 _error
("creation of member $fileName failed in updateMember()");
703 # replace old member or append new one
704 if ( defined($oldMember) ) {
705 $self->replaceMember( $oldMember, $newMember );
707 else { $self->addMember($newMember); }
715 # $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
717 # This takes the same arguments as addTree, but first checks to see
718 # whether the file or directory already exists in the zip file.
720 # If the fourth argument $mirror is true, then delete all my members
721 # if corresponding files weren't found.
726 or return _error
("root arg missing in call to updateTree()");
728 $dest = '' unless defined($dest);
729 $dest = _asZipDirName
( $dest, 1 );
730 my $pred = shift || sub { -r
};
733 my $rootZipName = _asZipDirName
( $root, 1 ); # with trailing slash
734 my $pattern = $rootZipName eq './' ?
'^' : "^\Q$rootZipName\E";
737 my $startDir = _untaintDir
( cwd
() );
739 return _error
( 'undef returned by _untaintDir on cwd ', cwd
() )
742 # This avoids chdir'ing in Find, in a way compatible with older
743 # versions of File::Find.
745 local $main::_
= $File::Find
::name
;
746 my $dir = _untaintDir
($File::Find
::dir
);
748 push( @files, $File::Find
::name
) if (&$pred);
752 File
::Find
::find
( $wanted, $root );
754 # Now @files has all the files that I could potentially be adding to
755 # the zip. Only add the ones that are necessary.
756 # For each file (updated or not), add its member name to @done.
758 foreach my $fileName (@files) {
759 my @newStat = stat($fileName);
762 # normalize, remove leading ./
763 my $memberName = _asZipDirName
( $fileName, $isDir );
764 if ( $memberName eq $rootZipName ) { $memberName = $dest }
765 else { $memberName =~ s{$pattern}{$dest} }
766 next if $memberName =~ m{^\.?/?$}; # skip current dir
768 $done{$memberName} = 1;
769 my $changedMember = $self->updateMember( $memberName, $fileName );
770 return _error
("updateTree failed to update $fileName")
771 unless ref($changedMember);
774 # @done now has the archive names corresponding to all the found files.
775 # If we're mirroring, delete all those members that aren't in @done.
777 foreach my $member ( $self->members() ) {
778 $self->removeMember($member)
779 unless $done{ $member->fileName() };