lib/Archive/Zip/Archive.pm

   1 package Archive::Zip::Archive;
   2
   3 # Represents a generic ZIP archive
   4
   5 use strict;
   6 use File::Path;
   7 use File::Find ();
   8 use File::Spec ();
   9 use File::Copy ();
  10 use File::Basename;
  11 use Cwd;
  12
  13 use vars qw( $VERSION @ISA );
  14
  15 BEGIN {
  16     $VERSION = '1.28';
  17     @ISA     = qw( Archive::Zip );
  18 }
  19
  20 use Archive::Zip qw(
  21   :CONSTANTS
  22   :ERROR_CODES
  23   :PKZIP_CONSTANTS
  24   :UTILITY_METHODS
  25 );
  26
  27 # Note that this returns undef on read errors, else new zip object.
  28
  29 sub new {
  30     my $class = shift;
  31     my $self  = bless(
  32         {
  33             'diskNumber'                            => 0,
  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' =>
  39               0,                            # must re-compute
  40             'writeEOCDOffset'             => 0,
  41             'writeCentralDirectoryOffset' => 0,
  42             'zipfileComment'              => '',
  43             'eocdOffset'                  => 0,
  44             'fileName'                    => ''
  45         },
  46         $class
  47     );
  48     $self->{'members'} = [];
  49     if (@_) {
  50         my $status = $self->read(@_);
  51         return $status == AZ_OK ? $self : undef;
  52     }
  53     return $self;
  54 }
  55
  56 sub storeSymbolicLink {
  57     my $self = shift;
  58     $self->{'storeSymbolicLink'} = shift;
  59 }
  60
  61 sub members {
  62     @{ shift->{'members'} };
  63 }
  64
  65 sub numberOfMembers {
  66     scalar( shift->members() );
  67 }
  68
  69 sub memberNames {
  70     my $self = shift;
  71     return map { $_->fileName() } $self->members();
  72 }
  73
  74 # return ref to member with given name or undef
  75 sub memberNamed {
  76     my ( $self, $fileName ) = @_;
  77     foreach my $member ( $self->members() ) {
  78         return $member if $member->fileName() eq $fileName;
  79     }
  80     return undef;
  81 }
  82
  83 sub membersMatching {
  84     my ( $self, $pattern ) = @_;
  85     return grep { $_->fileName() =~ /$pattern/ } $self->members();
  86 }
  87
  88 sub diskNumber {
  89     shift->{'diskNumber'};
  90 }
  91
  92 sub diskNumberWithStartOfCentralDirectory {
  93     shift->{'diskNumberWithStartOfCentralDirectory'};
  94 }
  95
  96 sub numberOfCentralDirectoriesOnThisDisk {
  97     shift->{'numberOfCentralDirectoriesOnThisDisk'};
  98 }
  99
 100 sub numberOfCentralDirectories {
 101     shift->{'numberOfCentralDirectories'};
 102 }
 103
 104 sub centralDirectorySize {
 105     shift->{'centralDirectorySize'};
 106 }
 107
 108 sub centralDirectoryOffsetWRTStartingDiskNumber {
 109     shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
 110 }
 111
 112 sub zipfileComment {
 113     my $self    = shift;
 114     my $comment = $self->{'zipfileComment'};
 115     if (@_) {
 116         $self->{'zipfileComment'} = pack( 'C0a*', shift() );    # avoid unicode
 117     }
 118     return $comment;
 119 }
 120
 121 sub eocdOffset {
 122     shift->{'eocdOffset'};
 123 }
 124
 125 # Return the name of the file last read.
 126 sub fileName {
 127     shift->{'fileName'};
 128 }
 129
 130 sub removeMember {
 131     my ( $self, $member ) = @_;
 132     $member = $self->memberNamed($member) unless ref($member);
 133     return undef unless $member;
 134     my @newMembers = grep { $_ != $member } $self->members();
 135     $self->{'members'} = \@newMembers;
 136     return $member;
 137 }
 138
 139 sub replaceMember {
 140     my ( $self, $oldMember, $newMember ) = @_;
 141     $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
 142     return undef unless $oldMember;
 143     return undef unless $newMember;
 144     my @newMembers =
 145       map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
 146     $self->{'members'} = \@newMembers;
 147     return $oldMember;
 148 }
 149
 150 sub extractMember {
 151     my $self   = shift;
 152     my $member = shift;
 153     $member = $self->memberNamed($member) unless ref($member);
 154     return _error('member not found') unless $member;
 155     my $originalSize = $member->compressedSize();
 156     my $name         = shift;                       # local FS name if given
 157     my ( $volumeName, $dirName, $fileName );
 158     if ( defined($name) ) {
 159         ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
 160         $dirName = File::Spec->catpath( $volumeName, $dirName, '' );
 161     }
 162     else {
 163         $name = $member->fileName();
 164         ( $dirName = $name ) =~ s{[^/]*$}{};
 165         $dirName = Archive::Zip::_asLocalName($dirName);
 166         $name    = Archive::Zip::_asLocalName($name);
 167     }
 168     if ( $dirName && !-d $dirName ) {
 169         mkpath($dirName);
 170         return _ioError("can't create dir $dirName") if ( !-d $dirName );
 171     }
 172     my $rc = $member->extractToFileNamed( $name, @_ );
 173
 174     # TODO refactor this fix into extractToFileNamed()
 175     $member->{'compressedSize'} = $originalSize;
 176     return $rc;
 177 }
 178
 179 sub extractMemberWithoutPaths {
 180     my $self   = shift;
 181     my $member = shift;
 182     $member = $self->memberNamed($member) unless ref($member);
 183     return _error('member not found') unless $member;
 184     my $originalSize = $member->compressedSize();
 185     return AZ_OK if $member->isDirectory();
 186     my $name = shift;
 187     unless ($name) {
 188         $name = $member->fileName();
 189         $name =~ s{.*/}{};    # strip off directories, if any
 190         $name = Archive::Zip::_asLocalName($name);
 191     }
 192     my $rc = $member->extractToFileNamed( $name, @_ );
 193     $member->{'compressedSize'} = $originalSize;
 194     return $rc;
 195 }
 196
 197 sub addMember {
 198     my ( $self, $newMember ) = @_;
 199     push( @{ $self->{'members'} }, $newMember ) if $newMember;
 200     return $newMember;
 201 }
 202
 203 sub addFile {
 204     my $self      = shift;
 205     my $fileName  = shift;
 206     my $newName   = shift;
 207     my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
 208     if ( $self->{'storeSymbolicLink'} && -l $fileName ) {
 209         my $newMember = $self->ZIPMEMBERCLASS->newFromString(readlink $fileName, $newName);
 210         # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
 211         $newMember->{'externalFileAttributes'} = 0xA1FF0000;
 212         $self->addMember($newMember);
 213     } else {
 214         $self->addMember($newMember);
 215     }
 216     return $newMember;
 217 }
 218
 219 sub addString {
 220     my $self      = shift;
 221     my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
 222     return $self->addMember($newMember);
 223 }
 224
 225 sub addDirectory {
 226     my ( $self, $name, $newName ) = @_;
 227     my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
 228     if ( $self->{'storeSymbolicLink'} && -l $name ) {
 229         my $link = readlink $name;
 230         ( $newName =~ s{/$}{} ) if $newName; # Strip trailing /
 231         my $newMember = $self->ZIPMEMBERCLASS->newFromString($link, $newName);
 232         # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
 233         $newMember->{'externalFileAttributes'} = 0xA1FF0000;
 234         $self->addMember($newMember);
 235     } else {
 236         $self->addMember($newMember);
 237     }
 238     return $newMember;
 239 }
 240
 241 # add either a file or a directory.
 242
 243 sub addFileOrDirectory {
 244     my ( $self, $name, $newName ) = @_;
 245     $name =~ s{/$}{};
 246     if ( $newName ) {
 247         $newName =~ s{/$}{};
 248     } else {
 249         $newName = $name;
 250     }
 251     if ( -f $name ) {
 252         return $self->addFile( $name, $newName );
 253     }
 254     elsif ( -d $name ) {
 255         return $self->addDirectory( $name, $newName );
 256     }
 257     else {
 258         return _error("$name is neither a file nor a directory");
 259     }
 260 }
 261
 262 sub contents {
 263     my ( $self, $member, $newContents ) = @_;
 264     return _error('No member name given') unless $member;
 265     $member = $self->memberNamed($member) unless ref($member);
 266     return undef unless $member;
 267     return $member->contents($newContents);
 268 }
 269
 270 sub writeToFileNamed {
 271     my $self     = shift;
 272     my $fileName = shift;    # local FS format
 273     foreach my $member ( $self->members() ) {
 274         if ( $member->_usesFileNamed($fileName) ) {
 275             return _error( "$fileName is needed by member "
 276                   . $member->fileName()
 277                   . "; consider using overwrite() or overwriteAs() instead." );
 278         }
 279     }
 280     my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
 281     return _ioError("Can't open $fileName for write") unless $status;
 282     my $retval = $self->writeToFileHandle( $fh, 1 );
 283     $fh->close();
 284     $fh = undef;
 285
 286     return $retval;
 287 }
 288
 289 # It is possible to write data to the FH before calling this,
 290 # perhaps to make a self-extracting archive.
 291 sub writeToFileHandle {
 292     my $self = shift;
 293     my $fh   = shift;
 294     return _error('No filehandle given')   unless $fh;
 295     return _ioError('filehandle not open') unless $fh->opened();
 296
 297     my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
 298     _binmode($fh);
 299
 300     # Find out where the current position is.
 301     my $offset = $fhIsSeekable ? $fh->tell() : 0;
 302     $offset = 0 if $offset < 0;
 303
 304     foreach my $member ( $self->members() ) {
 305         my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
 306         $member->endRead();
 307         return $retval if $retval != AZ_OK;
 308         $offset += $member->_localHeaderSize() + $member->_writeOffset();
 309         $offset +=
 310           $member->hasDataDescriptor()
 311           ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
 312           : 0;
 313
 314         # changed this so it reflects the last successful position
 315         $self->{'writeCentralDirectoryOffset'} = $offset;
 316     }
 317     return $self->writeCentralDirectory($fh);
 318 }
 319
 320 # Write zip back to the original file,
 321 # as safely as possible.
 322 # Returns AZ_OK if successful.
 323 sub overwrite {
 324     my $self = shift;
 325     return $self->overwriteAs( $self->{'fileName'} );
 326 }
 327
 328 # Write zip to the specified file,
 329 # as safely as possible.
 330 # Returns AZ_OK if successful.
 331 sub overwriteAs {
 332     my $self    = shift;
 333     my $zipName = shift;
 334     return _error("no filename in overwriteAs()") unless defined($zipName);
 335
 336     my ( $fh, $tempName ) = Archive::Zip::tempFile();
 337     return _error( "Can't open temp file", $! ) unless $fh;
 338
 339     ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
 340
 341     my $status = $self->writeToFileHandle($fh);
 342     $fh->close();
 343     $fh = undef;
 344
 345     if ( $status != AZ_OK ) {
 346         unlink($tempName);
 347         _printError("Can't write to $tempName");
 348         return $status;
 349     }
 350
 351     my $err;
 352
 353     # rename the zip
 354     if ( -f $zipName && !rename( $zipName, $backupName ) ) {
 355         $err = $!;
 356         unlink($tempName);
 357         return _error( "Can't rename $zipName as $backupName", $err );
 358     }
 359
 360     # move the temp to the original name (possibly copying)
 361     unless ( File::Copy::move( $tempName, $zipName ) ) {
 362         $err = $!;
 363         rename( $backupName, $zipName );
 364         unlink($tempName);
 365         return _error( "Can't move $tempName to $zipName", $err );
 366     }
 367
 368     # unlink the backup
 369     if ( -f $backupName && !unlink($backupName) ) {
 370         $err = $!;
 371         return _error( "Can't unlink $backupName", $err );
 372     }
 373
 374     return AZ_OK;
 375 }
 376
 377 # Used only during writing
 378 sub _writeCentralDirectoryOffset {
 379     shift->{'writeCentralDirectoryOffset'};
 380 }
 381
 382 sub _writeEOCDOffset {
 383     shift->{'writeEOCDOffset'};
 384 }
 385
 386 # Expects to have _writeEOCDOffset() set
 387 sub _writeEndOfCentralDirectory {
 388     my ( $self, $fh ) = @_;
 389
 390     $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
 391       or return _ioError('writing EOCD Signature');
 392     my $zipfileCommentLength = length( $self->zipfileComment() );
 393
 394     my $header = pack(
 395         END_OF_CENTRAL_DIRECTORY_FORMAT,
 396         0,                          # {'diskNumber'},
 397         0,                          # {'diskNumberWithStartOfCentralDirectory'},
 398         $self->numberOfMembers(),   # {'numberOfCentralDirectoriesOnThisDisk'},
 399         $self->numberOfMembers(),   # {'numberOfCentralDirectories'},
 400         $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
 401         $self->_writeCentralDirectoryOffset(),
 402         $zipfileCommentLength
 403     );
 404     $self->_print($fh, $header)
 405       or return _ioError('writing EOCD header');
 406     if ($zipfileCommentLength) {
 407         $self->_print($fh,  $self->zipfileComment() )
 408           or return _ioError('writing zipfile comment');
 409     }
 410     return AZ_OK;
 411 }
 412
 413 # $offset can be specified to truncate a zip file.
 414 sub writeCentralDirectory {
 415     my ( $self, $fh, $offset ) = @_;
 416
 417     if ( defined($offset) ) {
 418         $self->{'writeCentralDirectoryOffset'} = $offset;
 419         $fh->seek( $offset, IO::Seekable::SEEK_SET )
 420           or return _ioError('seeking to write central directory');
 421     }
 422     else {
 423         $offset = $self->_writeCentralDirectoryOffset();
 424     }
 425
 426     foreach my $member ( $self->members() ) {
 427         my $status = $member->_writeCentralDirectoryFileHeader($fh);
 428         return $status if $status != AZ_OK;
 429         $offset += $member->_centralDirectoryHeaderSize();
 430         $self->{'writeEOCDOffset'} = $offset;
 431     }
 432     return $self->_writeEndOfCentralDirectory($fh);
 433 }
 434
 435 sub read {
 436     my $self     = shift;
 437     my $fileName = shift;
 438     return _error('No filename given') unless $fileName;
 439     my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
 440     return _ioError("opening $fileName for read") unless $status;
 441
 442     $status = $self->readFromFileHandle( $fh, $fileName );
 443     return $status if $status != AZ_OK;
 444
 445     $fh->close();
 446     $self->{'fileName'} = $fileName;
 447     return AZ_OK;
 448 }
 449
 450 sub readFromFileHandle {
 451     my $self     = shift;
 452     my $fh       = shift;
 453     my $fileName = shift;
 454     $fileName = $fh unless defined($fileName);
 455     return _error('No filehandle given')   unless $fh;
 456     return _ioError('filehandle not open') unless $fh->opened();
 457
 458     _binmode($fh);
 459     $self->{'fileName'} = "$fh";
 460
 461     # TODO: how to support non-seekable zips?
 462     return _error('file not seekable')
 463       unless _isSeekable($fh);
 464
 465     $fh->seek( 0, 0 );    # rewind the file
 466
 467     my $status = $self->_findEndOfCentralDirectory($fh);
 468     return $status if $status != AZ_OK;
 469
 470     my $eocdPosition = $fh->tell();
 471
 472     $status = $self->_readEndOfCentralDirectory($fh);
 473     return $status if $status != AZ_OK;
 474
 475     $fh->seek( $eocdPosition - $self->centralDirectorySize(),
 476         IO::Seekable::SEEK_SET )
 477       or return _ioError("Can't seek $fileName");
 478
 479     # Try to detect garbage at beginning of archives
 480     # This should be 0
 481     $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
 482       - $self->centralDirectoryOffsetWRTStartingDiskNumber();
 483
 484     for ( ; ; ) {
 485         my $newMember =
 486           $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
 487             $self->eocdOffset() );
 488         my $signature;
 489         ( $status, $signature ) = _readSignature( $fh, $fileName );
 490         return $status if $status != AZ_OK;
 491         last           if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
 492         $status = $newMember->_readCentralDirectoryFileHeader();
 493         return $status if $status != AZ_OK;
 494         $status = $newMember->endRead();
 495         return $status if $status != AZ_OK;
 496         $newMember->_becomeDirectoryIfNecessary();
 497         push( @{ $self->{'members'} }, $newMember );
 498     }
 499
 500     return AZ_OK;
 501 }
 502
 503 # Read EOCD, starting from position before signature.
 504 # Return AZ_OK on success.
 505 sub _readEndOfCentralDirectory {
 506     my $self = shift;
 507     my $fh   = shift;
 508
 509     # Skip past signature
 510     $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
 511       or return _ioError("Can't seek past EOCD signature");
 512
 513     my $header = '';
 514     my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
 515     if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH ) {
 516         return _ioError("reading end of central directory");
 517     }
 518
 519     my $zipfileCommentLength;
 520     (
 521         $self->{'diskNumber'},
 522         $self->{'diskNumberWithStartOfCentralDirectory'},
 523         $self->{'numberOfCentralDirectoriesOnThisDisk'},
 524         $self->{'numberOfCentralDirectories'},
 525         $self->{'centralDirectorySize'},
 526         $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
 527         $zipfileCommentLength
 528     ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
 529
 530     if ($zipfileCommentLength) {
 531         my $zipfileComment = '';
 532         $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
 533         if ( $bytesRead != $zipfileCommentLength ) {
 534             return _ioError("reading zipfile comment");
 535         }
 536         $self->{'zipfileComment'} = $zipfileComment;
 537     }
 538
 539     return AZ_OK;
 540 }
 541
 542 # Seek in my file to the end, then read backwards until we find the
 543 # signature of the central directory record. Leave the file positioned right
 544 # before the signature. Returns AZ_OK if success.
 545 sub _findEndOfCentralDirectory {
 546     my $self = shift;
 547     my $fh   = shift;
 548     my $data = '';
 549     $fh->seek( 0, IO::Seekable::SEEK_END )
 550       or return _ioError("seeking to end");
 551
 552     my $fileLength = $fh->tell();
 553     if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) {
 554         return _formatError("file is too short");
 555     }
 556
 557     my $seekOffset = 0;
 558     my $pos        = -1;
 559     for ( ; ; ) {
 560         $seekOffset += 512;
 561         $seekOffset = $fileLength if ( $seekOffset > $fileLength );
 562         $fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
 563           or return _ioError("seek failed");
 564         my $bytesRead = $fh->read( $data, $seekOffset );
 565         if ( $bytesRead != $seekOffset ) {
 566             return _ioError("read failed");
 567         }
 568         $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
 569         last
 570           if ( $pos >= 0
 571             or $seekOffset == $fileLength
 572             or $seekOffset >= $Archive::Zip::ChunkSize );
 573     }
 574
 575     if ( $pos >= 0 ) {
 576         $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
 577           or return _ioError("seeking to EOCD");
 578         return AZ_OK;
 579     }
 580     else {
 581         return _formatError("can't find EOCD signature");
 582     }
 583 }
 584
 585 # Used to avoid taint problems when chdir'ing.
 586 # Not intended to increase security in any way; just intended to shut up the -T
 587 # complaints.  If your Cwd module is giving you unreliable returns from cwd()
 588 # you have bigger problems than this.
 589 sub _untaintDir {
 590     my $dir = shift;
 591     $dir =~ m/\A(.+)\z/s;
 592     return $1;
 593 }
 594
 595 sub addTree {
 596     my $self = shift;
 597     my $root = shift or return _error("root arg missing in call to addTree()");
 598     my $dest = shift;
 599     $dest = '' unless defined($dest);
 600     my $pred = shift || sub { -r };
 601     my $compressionLevel = shift;
 602     my @files;
 603     my $startDir = _untaintDir( cwd() );
 604
 605     return _error( 'undef returned by _untaintDir on cwd ', cwd() )
 606       unless $startDir;
 607
 608     # This avoids chdir'ing in Find, in a way compatible with older
 609     # versions of File::Find.
 610     my $wanted = sub {
 611         local $main::_ = $File::Find::name;
 612         my $dir = _untaintDir($File::Find::dir);
 613         chdir($startDir);
 614         push( @files, $File::Find::name ) if (&$pred);
 615         chdir($dir);
 616     };
 617
 618     File::Find::find( $wanted, $root );
 619
 620     my $rootZipName = _asZipDirName( $root, 1 );    # with trailing slash
 621     my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
 622
 623     $dest = _asZipDirName( $dest, 1 );              # with trailing slash
 624
 625     foreach my $fileName (@files) {
 626         my $isDir = -d $fileName;
 627
 628         # normalize, remove leading ./
 629         my $archiveName = _asZipDirName( $fileName, $isDir );
 630         if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
 631         else { $archiveName =~ s{$pattern}{$dest} }
 632         next if $archiveName =~ m{^\.?/?$};         # skip current dir
 633         my $member = $isDir
 634           ? $self->addDirectory( $fileName, $archiveName )
 635           : $self->addFile( $fileName, $archiveName );
 636         $member->desiredCompressionLevel($compressionLevel);
 637
 638         return _error("add $fileName failed in addTree()") if !$member;
 639     }
 640     return AZ_OK;
 641 }
 642
 643 sub addTreeMatching {
 644     my $self = shift;
 645     my $root = shift
 646       or return _error("root arg missing in call to addTreeMatching()");
 647     my $dest = shift;
 648     $dest = '' unless defined($dest);
 649     my $pattern = shift
 650       or return _error("pattern missing in call to addTreeMatching()");
 651     my $pred = shift;
 652     my $matcher =
 653       $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
 654     return $self->addTree( $root, $dest, $matcher );
 655 }
 656
 657 # $zip->extractTree( $root, $dest [, $volume] );
 658 #
 659 # $root and $dest are Unix-style.
 660 # $volume is in local FS format.
 661 #
 662 sub extractTree {
 663     my $self = shift;
 664     my $root = shift;    # Zip format
 665     $root = '' unless defined($root);
 666     my $dest = shift;    # Zip format
 667     $dest = './' unless defined($dest);
 668     my $volume  = shift;                              # optional
 669     my $pattern = "^\Q$root";
 670     my @members = $self->membersMatching($pattern);
 671
 672     foreach my $member (@members) {
 673         my $fileName = $member->fileName();           # in Unix format
 674         $fileName =~ s{$pattern}{$dest};    # in Unix format
 675                                             # convert to platform format:
 676         $fileName = Archive::Zip::_asLocalName( $fileName, $volume );
 677         my $status = $member->extractToFileNamed($fileName);
 678         return $status if $status != AZ_OK;
 679     }
 680     return AZ_OK;
 681 }
 682
 683 # $zip->updateMember( $memberOrName, $fileName );
 684 # Returns (possibly updated) member, if any; undef on errors.
 685
 686 sub updateMember {
 687     my $self      = shift;
 688     my $oldMember = shift;
 689     my $fileName  = shift;
 690
 691     if ( !defined($fileName) ) {
 692         _error("updateMember(): missing fileName argument");
 693         return undef;
 694     }
 695
 696     my @newStat = stat($fileName);
 697     if ( !@newStat ) {
 698         _ioError("Can't stat $fileName");
 699         return undef;
 700     }
 701
 702     my $isDir = -d _;
 703
 704     my $memberName;
 705
 706     if ( ref($oldMember) ) {
 707         $memberName = $oldMember->fileName();
 708     }
 709     else {
 710         $oldMember = $self->memberNamed( $memberName = $oldMember )
 711           || $self->memberNamed( $memberName =
 712               _asZipDirName( $oldMember, $isDir ) );
 713     }
 714
 715     unless ( defined($oldMember)
 716         && $oldMember->lastModTime() == $newStat[9]
 717         && $oldMember->isDirectory() == $isDir
 718         && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
 719     {
 720
 721         # create the new member
 722         my $newMember = $isDir
 723           ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
 724           : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
 725
 726         unless ( defined($newMember) ) {
 727             _error("creation of member $fileName failed in updateMember()");
 728             return undef;
 729         }
 730
 731         # replace old member or append new one
 732         if ( defined($oldMember) ) {
 733             $self->replaceMember( $oldMember, $newMember );
 734         }
 735         else { $self->addMember($newMember); }
 736
 737         return $newMember;
 738     }
 739
 740     return $oldMember;
 741 }
 742
 743 # $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
 744 #
 745 # This takes the same arguments as addTree, but first checks to see
 746 # whether the file or directory already exists in the zip file.
 747 #
 748 # If the fourth argument $mirror is true, then delete all my members
 749 # if corresponding files weren't found.
 750
 751 sub updateTree {
 752     my $self = shift;
 753     my $root = shift
 754       or return _error("root arg missing in call to updateTree()");
 755     my $dest = shift;
 756     $dest = '' unless defined($dest);
 757     $dest = _asZipDirName( $dest, 1 );
 758     my $pred = shift || sub { -r };
 759     my $mirror = shift;
 760
 761     my $rootZipName = _asZipDirName( $root, 1 );    # with trailing slash
 762     my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
 763
 764     my @files;
 765     my $startDir = _untaintDir( cwd() );
 766
 767     return _error( 'undef returned by _untaintDir on cwd ', cwd() )
 768       unless $startDir;
 769
 770     # This avoids chdir'ing in Find, in a way compatible with older
 771     # versions of File::Find.
 772     my $wanted = sub {
 773         local $main::_ = $File::Find::name;
 774         my $dir = _untaintDir($File::Find::dir);
 775         chdir($startDir);
 776         push( @files, $File::Find::name ) if (&$pred);
 777         chdir($dir);
 778     };
 779
 780     File::Find::find( $wanted, $root );
 781
 782     # Now @files has all the files that I could potentially be adding to
 783     # the zip. Only add the ones that are necessary.
 784     # For each file (updated or not), add its member name to @done.
 785     my %done;
 786     foreach my $fileName (@files) {
 787         my @newStat = stat($fileName);
 788         my $isDir   = -d _;
 789
 790         # normalize, remove leading ./
 791         my $memberName = _asZipDirName( $fileName, $isDir );
 792         if ( $memberName eq $rootZipName ) { $memberName = $dest }
 793         else { $memberName =~ s{$pattern}{$dest} }
 794         next if $memberName =~ m{^\.?/?$};    # skip current dir
 795
 796         $done{$memberName} = 1;
 797         my $changedMember = $self->updateMember( $memberName, $fileName );
 798         return _error("updateTree failed to update $fileName")
 799           unless ref($changedMember);
 800     }
 801
 802     # @done now has the archive names corresponding to all the found files.
 803     # If we're mirroring, delete all those members that aren't in @done.
 804     if ($mirror) {
 805         foreach my $member ( $self->members() ) {
 806             $self->removeMember($member)
 807               unless $done{ $member->fileName() };
 808         }
 809     }
 810
 811     return AZ_OK;
 812 }
 813
 814 1;