git.maemo.org Git - dh-make-perl/blob - dev/arm/libarchive-zip-perl/libarchive-zip-perl-1.18/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.18';
  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 members {
  57     @{ shift->{'members'} };
  58 }
  59
  60 sub numberOfMembers {
  61     scalar( shift->members() );
  62 }
  63
  64 sub memberNames {
  65     my $self = shift;
  66     return map { $_->fileName() } $self->members();
  67 }
  68
  69 # return ref to member with given name or undef
  70 sub memberNamed {
  71     my ( $self, $fileName ) = @_;
  72     foreach my $member ( $self->members() ) {
  73         return $member if $member->fileName() eq $fileName;
  74     }
  75     return undef;
  76 }
  77
  78 sub membersMatching {
  79     my ( $self, $pattern ) = @_;
  80     return grep { $_->fileName() =~ /$pattern/ } $self->members();
  81 }
  82
  83 sub diskNumber {
  84     shift->{'diskNumber'};
  85 }
  86
  87 sub diskNumberWithStartOfCentralDirectory {
  88     shift->{'diskNumberWithStartOfCentralDirectory'};
  89 }
  90
  91 sub numberOfCentralDirectoriesOnThisDisk {
  92     shift->{'numberOfCentralDirectoriesOnThisDisk'};
  93 }
  94
  95 sub numberOfCentralDirectories {
  96     shift->{'numberOfCentralDirectories'};
  97 }
  98
  99 sub centralDirectorySize {
 100     shift->{'centralDirectorySize'};
 101 }
 102
 103 sub centralDirectoryOffsetWRTStartingDiskNumber {
 104     shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
 105 }
 106
 107 sub zipfileComment {
 108     my $self    = shift;
 109     my $comment = $self->{'zipfileComment'};
 110     if (@_) {
 111         $self->{'zipfileComment'} = pack( 'C0a*', shift() );    # avoid unicode
 112     }
 113     return $comment;
 114 }
 115
 116 sub eocdOffset {
 117     shift->{'eocdOffset'};
 118 }
 119
 120 # Return the name of the file last read.
 121 sub fileName {
 122     shift->{'fileName'};
 123 }
 124
 125 sub removeMember {
 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;
 131     return $member;
 132 }
 133
 134 sub replaceMember {
 135     my ( $self, $oldMember, $newMember ) = @_;
 136     $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
 137     return undef unless $oldMember;
 138     return undef unless $newMember;
 139     my @newMembers =
 140       map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
 141     $self->{'members'} = \@newMembers;
 142     return $oldMember;
 143 }
 144
 145 sub extractMember {
 146     my $self   = shift;
 147     my $member = shift;
 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, '' );
 156     }
 157     else {
 158         $name = $member->fileName();
 159         ( $dirName = $name ) =~ s{[^/]*$}{};
 160         $dirName = Archive::Zip::_asLocalName($dirName);
 161         $name    = Archive::Zip::_asLocalName($name);
 162     }
 163     if ( $dirName && !-d $dirName ) {
 164         mkpath($dirName);
 165         return _ioError("can't create dir $dirName") if ( !-d $dirName );
 166     }
 167     my $rc = $member->extractToFileNamed( $name, @_ );
 168
 169     # TODO refactor this fix into extractToFileNamed()
 170     $member->{'compressedSize'} = $originalSize;
 171     return $rc;
 172 }
 173
 174 sub extractMemberWithoutPaths {
 175     my $self   = shift;
 176     my $member = shift;
 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();
 181     my $name = shift;
 182     unless ($name) {
 183         $name = $member->fileName();
 184         $name =~ s{.*/}{};    # strip off directories, if any
 185         $name = Archive::Zip::_asLocalName($name);
 186     }
 187     my $rc = $member->extractToFileNamed( $name, @_ );
 188     $member->{'compressedSize'} = $originalSize;
 189     return $rc;
 190 }
 191
 192 sub addMember {
 193     my ( $self, $newMember ) = @_;
 194     push( @{ $self->{'members'} }, $newMember ) if $newMember;
 195     return $newMember;
 196 }
 197
 198 sub addFile {
 199     my $self      = shift;
 200     my $fileName  = shift;
 201     my $newName   = shift;
 202     my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
 203     $self->addMember($newMember) if defined($newMember);
 204     return $newMember;
 205 }
 206
 207 sub addString {
 208     my $self      = shift;
 209     my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
 210     return $self->addMember($newMember);
 211 }
 212
 213 sub addDirectory {
 214     my ( $self, $name, $newName ) = @_;
 215     my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
 216     $self->addMember($newMember);
 217     return $newMember;
 218 }
 219
 220 # add either a file or a directory.
 221
 222 sub addFileOrDirectory {
 223     my ( $self, $name, $newName ) = @_;
 224     if ( -f $name ) {
 225         ( $newName =~ s{/$}{} ) if $newName;
 226         return $self->addFile( $name, $newName );
 227     }
 228     elsif ( -d $name ) {
 229         ( $newName =~ s{[^/]$}{&/} ) if $newName;
 230         return $self->addDirectory( $name, $newName );
 231     }
 232     else {
 233         return _error("$name is neither a file nor a directory");
 234     }
 235 }
 236
 237 sub contents {
 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);
 243 }
 244
 245 sub writeToFileNamed {
 246     my $self     = shift;
 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." );
 253         }
 254     }
 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 );
 258     $fh->close();
 259     $fh = undef;
 260
 261     return $retval;
 262 }
 263
 264 # It is possible to write data to the FH before calling this,
 265 # perhaps to make a self-extracting archive.
 266 sub writeToFileHandle {
 267     my $self = shift;
 268     my $fh   = shift;
 269     return _error('No filehandle given')   unless $fh;
 270     return _ioError('filehandle not open') unless $fh->opened();
 271
 272     my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
 273     _binmode($fh);
 274
 275     # Find out where the current position is.
 276     my $offset = $fhIsSeekable ? $fh->tell() : 0;
 277     $offset = 0 if $offset < 0;
 278
 279     foreach my $member ( $self->members() ) {
 280         my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
 281         $member->endRead();
 282         return $retval if $retval != AZ_OK;
 283         $offset += $member->_localHeaderSize() + $member->_writeOffset();
 284         $offset +=
 285           $member->hasDataDescriptor()
 286           ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
 287           : 0;
 288
 289         # changed this so it reflects the last successful position
 290         $self->{'writeCentralDirectoryOffset'} = $offset;
 291     }
 292     return $self->writeCentralDirectory($fh);
 293 }
 294
 295 # Write zip back to the original file,
 296 # as safely as possible.
 297 # Returns AZ_OK if successful.
 298 sub overwrite {
 299     my $self = shift;
 300     return $self->overwriteAs( $self->{'fileName'} );
 301 }
 302
 303 # Write zip to the specified file,
 304 # as safely as possible.
 305 # Returns AZ_OK if successful.
 306 sub overwriteAs {
 307     my $self    = shift;
 308     my $zipName = shift;
 309     return _error("no filename in overwriteAs()") unless defined($zipName);
 310
 311     my ( $fh, $tempName ) = Archive::Zip::tempFile();
 312     return _error( "Can't open temp file", $! ) unless $fh;
 313
 314     ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
 315
 316     my $status = $self->writeToFileHandle($fh);
 317     $fh->close();
 318     $fh = undef;
 319
 320     if ( $status != AZ_OK ) {
 321         unlink($tempName);
 322         _printError("Can't write to $tempName");
 323         return $status;
 324     }
 325
 326     my $err;
 327
 328     # rename the zip
 329     if ( -f $zipName && !rename( $zipName, $backupName ) ) {
 330         $err = $!;
 331         unlink($tempName);
 332         return _error( "Can't rename $zipName as $backupName", $err );
 333     }
 334
 335     # move the temp to the original name (possibly copying)
 336     unless ( File::Copy::move( $tempName, $zipName ) ) {
 337         $err = $!;
 338         rename( $backupName, $zipName );
 339         unlink($tempName);
 340         return _error( "Can't move $tempName to $zipName", $err );
 341     }
 342
 343     # unlink the backup
 344     if ( -f $backupName && !unlink($backupName) ) {
 345         $err = $!;
 346         return _error( "Can't unlink $backupName", $err );
 347     }
 348
 349     return AZ_OK;
 350 }
 351
 352 # Used only during writing
 353 sub _writeCentralDirectoryOffset {
 354     shift->{'writeCentralDirectoryOffset'};
 355 }
 356
 357 sub _writeEOCDOffset {
 358     shift->{'writeEOCDOffset'};
 359 }
 360
 361 # Expects to have _writeEOCDOffset() set
 362 sub _writeEndOfCentralDirectory {
 363     my ( $self, $fh ) = @_;
 364
 365     $fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
 366       or return _ioError('writing EOCD Signature');
 367     my $zipfileCommentLength = length( $self->zipfileComment() );
 368
 369     my $header = pack(
 370         END_OF_CENTRAL_DIRECTORY_FORMAT,
 371         0,                          # {'diskNumber'},
 372         0,                          # {'diskNumberWithStartOfCentralDirectory'},
 373         $self->numberOfMembers(),   # {'numberOfCentralDirectoriesOnThisDisk'},
 374         $self->numberOfMembers(),   # {'numberOfCentralDirectories'},
 375         $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
 376         $self->_writeCentralDirectoryOffset(),
 377         $zipfileCommentLength
 378     );
 379     $fh->print($header)
 380       or return _ioError('writing EOCD header');
 381     if ($zipfileCommentLength) {
 382         $fh->print( $self->zipfileComment() )
 383           or return _ioError('writing zipfile comment');
 384     }
 385     return AZ_OK;
 386 }
 387
 388 # $offset can be specified to truncate a zip file.
 389 sub writeCentralDirectory {
 390     my ( $self, $fh, $offset ) = @_;
 391
 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');
 396     }
 397     else {
 398         $offset = $self->_writeCentralDirectoryOffset();
 399     }
 400
 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;
 406     }
 407     return $self->_writeEndOfCentralDirectory($fh);
 408 }
 409
 410 sub read {
 411     my $self     = shift;
 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;
 416
 417     $status = $self->readFromFileHandle( $fh, $fileName );
 418     return $status if $status != AZ_OK;
 419
 420     $fh->close();
 421     $self->{'fileName'} = $fileName;
 422     return AZ_OK;
 423 }
 424
 425 sub readFromFileHandle {
 426     my $self     = shift;
 427     my $fh       = shift;
 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();
 432
 433     _binmode($fh);
 434     $self->{'fileName'} = "$fh";
 435
 436     # TODO: how to support non-seekable zips?
 437     return _error('file not seekable')
 438       unless _isSeekable($fh);
 439
 440     $fh->seek( 0, 0 );    # rewind the file
 441
 442     my $status = $self->_findEndOfCentralDirectory($fh);
 443     return $status if $status != AZ_OK;
 444
 445     my $eocdPosition = $fh->tell();
 446
 447     $status = $self->_readEndOfCentralDirectory($fh);
 448     return $status if $status != AZ_OK;
 449
 450     $fh->seek( $eocdPosition - $self->centralDirectorySize(),
 451         IO::Seekable::SEEK_SET )
 452       or return _ioError("Can't seek $fileName");
 453
 454     # Try to detect garbage at beginning of archives
 455     # This should be 0
 456     $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
 457       - $self->centralDirectoryOffsetWRTStartingDiskNumber();
 458
 459     for ( ; ; ) {
 460         my $newMember =
 461           $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
 462             $self->eocdOffset() );
 463         my $signature;
 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 );
 473     }
 474
 475     return AZ_OK;
 476 }
 477
 478 # Read EOCD, starting from position before signature.
 479 # Return AZ_OK on success.
 480 sub _readEndOfCentralDirectory {
 481     my $self = shift;
 482     my $fh   = shift;
 483
 484     # Skip past signature
 485     $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
 486       or return _ioError("Can't seek past EOCD signature");
 487
 488     my $header = '';
 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");
 492     }
 493
 494     my $zipfileCommentLength;
 495     (
 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 );
 504
 505     if ($zipfileCommentLength) {
 506         my $zipfileComment = '';
 507         $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
 508         if ( $bytesRead != $zipfileCommentLength ) {
 509             return _ioError("reading zipfile comment");
 510         }
 511         $self->{'zipfileComment'} = $zipfileComment;
 512     }
 513
 514     return AZ_OK;
 515 }
 516
 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 {
 521     my $self = shift;
 522     my $fh   = shift;
 523     my $data = '';
 524     $fh->seek( 0, IO::Seekable::SEEK_END )
 525       or return _ioError("seeking to end");
 526
 527     my $fileLength = $fh->tell();
 528     if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) {
 529         return _formatError("file is too short");
 530     }
 531
 532     my $seekOffset = 0;
 533     my $pos        = -1;
 534     for ( ; ; ) {
 535         $seekOffset += 512;
 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");
 542         }
 543         $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
 544         last
 545           if ( $pos >= 0
 546             or $seekOffset == $fileLength
 547             or $seekOffset >= $Archive::Zip::ChunkSize );
 548     }
 549
 550     if ( $pos >= 0 ) {
 551         $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
 552           or return _ioError("seeking to EOCD");
 553         return AZ_OK;
 554     }
 555     else {
 556         return _formatError("can't find EOCD signature");
 557     }
 558 }
 559
 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.
 564 sub _untaintDir {
 565     my $dir = shift;
 566     $dir =~ m/\A(.+)\z/s;
 567     return $1;
 568 }
 569
 570 sub addTree {
 571     my $self = shift;
 572     my $root = shift or return _error("root arg missing in call to addTree()");
 573     my $dest = shift;
 574     $dest = '' unless defined($dest);
 575     my $pred = shift || sub { -r };
 576     my @files;
 577     my $startDir = _untaintDir( cwd() );
 578
 579     return _error( 'undef returned by _untaintDir on cwd ', cwd() )
 580       unless $startDir;
 581
 582     # This avoids chdir'ing in Find, in a way compatible with older
 583     # versions of File::Find.
 584     my $wanted = sub {
 585         local $main::_ = $File::Find::name;
 586         my $dir = _untaintDir($File::Find::dir);
 587         chdir($startDir);
 588         push( @files, $File::Find::name ) if (&$pred);
 589         chdir($dir);
 590     };
 591
 592     File::Find::find( $wanted, $root );
 593
 594     my $rootZipName = _asZipDirName( $root, 1 );    # with trailing slash
 595     my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
 596
 597     $dest = _asZipDirName( $dest, 1 );              # with trailing slash
 598
 599     foreach my $fileName (@files) {
 600         my $isDir = -d $fileName;
 601
 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
 607         my $member = $isDir
 608           ? $self->addDirectory( $fileName, $archiveName )
 609           : $self->addFile( $fileName, $archiveName );
 610         return _error("add $fileName failed in addTree()") if !$member;
 611     }
 612     return AZ_OK;
 613 }
 614
 615 sub addTreeMatching {
 616     my $self = shift;
 617     my $root = shift
 618       or return _error("root arg missing in call to addTreeMatching()");
 619     my $dest = shift;
 620     $dest = '' unless defined($dest);
 621     my $pattern = shift
 622       or return _error("pattern missing in call to addTreeMatching()");
 623     my $pred = shift;
 624     my $matcher =
 625       $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
 626     return $self->addTree( $root, $dest, $matcher );
 627 }
 628
 629 # $zip->extractTree( $root, $dest [, $volume] );
 630 #
 631 # $root and $dest are Unix-style.
 632 # $volume is in local FS format.
 633 #
 634 sub extractTree {
 635     my $self = shift;
 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);
 643
 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;
 651     }
 652     return AZ_OK;
 653 }
 654
 655 # $zip->updateMember( $memberOrName, $fileName );
 656 # Returns (possibly updated) member, if any; undef on errors.
 657
 658 sub updateMember {
 659     my $self      = shift;
 660     my $oldMember = shift;
 661     my $fileName  = shift;
 662
 663     if ( !defined($fileName) ) {
 664         _error("updateMember(): missing fileName argument");
 665         return undef;
 666     }
 667
 668     my @newStat = stat($fileName);
 669     if ( !@newStat ) {
 670         _ioError("Can't stat $fileName");
 671         return undef;
 672     }
 673
 674     my $isDir = -d _;
 675
 676     my $memberName;
 677
 678     if ( ref($oldMember) ) {
 679         $memberName = $oldMember->fileName();
 680     }
 681     else {
 682         $oldMember = $self->memberNamed( $memberName = $oldMember )
 683           || $self->memberNamed( $memberName =
 684               _asZipDirName( $oldMember, $isDir ) );
 685     }
 686
 687     unless ( defined($oldMember)
 688         && $oldMember->lastModTime() == $newStat[9]
 689         && $oldMember->isDirectory() == $isDir
 690         && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
 691     {
 692
 693         # create the new member
 694         my $newMember = $isDir
 695           ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
 696           : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
 697
 698         unless ( defined($newMember) ) {
 699             _error("creation of member $fileName failed in updateMember()");
 700             return undef;
 701         }
 702
 703         # replace old member or append new one
 704         if ( defined($oldMember) ) {
 705             $self->replaceMember( $oldMember, $newMember );
 706         }
 707         else { $self->addMember($newMember); }
 708
 709         return $newMember;
 710     }
 711
 712     return $oldMember;
 713 }
 714
 715 # $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
 716 #
 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.
 719 #
 720 # If the fourth argument $mirror is true, then delete all my members
 721 # if corresponding files weren't found.
 722
 723 sub updateTree {
 724     my $self = shift;
 725     my $root = shift
 726       or return _error("root arg missing in call to updateTree()");
 727     my $dest = shift;
 728     $dest = '' unless defined($dest);
 729     $dest = _asZipDirName( $dest, 1 );
 730     my $pred = shift || sub { -r };
 731     my $mirror = shift;
 732
 733     my $rootZipName = _asZipDirName( $root, 1 );    # with trailing slash
 734     my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
 735
 736     my @files;
 737     my $startDir = _untaintDir( cwd() );
 738
 739     return _error( 'undef returned by _untaintDir on cwd ', cwd() )
 740       unless $startDir;
 741
 742     # This avoids chdir'ing in Find, in a way compatible with older
 743     # versions of File::Find.
 744     my $wanted = sub {
 745         local $main::_ = $File::Find::name;
 746         my $dir = _untaintDir($File::Find::dir);
 747         chdir($startDir);
 748         push( @files, $File::Find::name ) if (&$pred);
 749         chdir($dir);
 750     };
 751
 752     File::Find::find( $wanted, $root );
 753
 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.
 757     my %done;
 758     foreach my $fileName (@files) {
 759         my @newStat = stat($fileName);
 760         my $isDir   = -d _;
 761
 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
 767
 768         $done{$memberName} = 1;
 769         my $changedMember = $self->updateMember( $memberName, $fileName );
 770         return _error("updateTree failed to update $fileName")
 771           unless ref($changedMember);
 772     }
 773
 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.
 776     if ($mirror) {
 777         foreach my $member ( $self->members() ) {
 778             $self->removeMember($member)
 779               unless $done{ $member->fileName() };
 780         }
 781     }
 782
 783     return AZ_OK;
 784 }
 785
 786 1;