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