2
# $Revision: 1.104.2.1 $
4
# Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free
5
# software; you can redistribute it and/or modify it under the same terms as
8
# ----------------------------------------------------------------------
10
# Note that the package Archive::Zip exists only for exporting and
11
# sharing constants. Everything else is in another package
13
# Creation of a new Archive::Zip object actually creates a new object
14
# of class Archive::Zip::Archive.
15
# ----------------------------------------------------------------------
25
use File::Spec 0.8 ();
28
# use sigtrap qw(die normal-signals); # is this needed?
30
use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS $VERSION $ChunkSize $ErrorHandler );
32
# This is the size we'll try to read, write, and (de)compress.
33
# You could set it to something different if you had lots of memory
34
# and needed more speed.
37
$ErrorHandler = \&Carp::carp;
39
# BEGIN block is necessary here so that other modules can use the constants.
45
@ISA = qw( Exporter );
47
my @ConstantNames = qw( FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
48
GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
49
COMPRESSION_STORED COMPRESSION_DEFLATED COMPRESSION_LEVEL_NONE
50
COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST
51
COMPRESSION_LEVEL_BEST_COMPRESSION IFA_TEXT_FILE_MASK IFA_TEXT_FILE
54
my @MiscConstantNames = qw( FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST
55
FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_TOPS20
56
FA_WINDOWS_NTFS FA_QDOS FA_ACORN FA_VFAT FA_MVS FA_BEOS FA_TANDEM
57
FA_THEOS GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
58
GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
59
GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
60
DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
61
DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
62
COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
63
COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
64
COMPRESSION_DEFLATED_ENHANCED
65
COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED );
67
my @ErrorCodeNames = qw( AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR
70
my @PKZipConstantNames = qw( SIGNATURE_FORMAT SIGNATURE_LENGTH
71
LOCAL_FILE_HEADER_SIGNATURE LOCAL_FILE_HEADER_FORMAT
72
LOCAL_FILE_HEADER_LENGTH CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
73
DATA_DESCRIPTOR_FORMAT DATA_DESCRIPTOR_LENGTH DATA_DESCRIPTOR_SIGNATURE
74
DATA_DESCRIPTOR_FORMAT_NO_SIG DATA_DESCRIPTOR_LENGTH_NO_SIG
75
CENTRAL_DIRECTORY_FILE_HEADER_FORMAT CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
76
END_OF_CENTRAL_DIRECTORY_SIGNATURE END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING
77
END_OF_CENTRAL_DIRECTORY_FORMAT END_OF_CENTRAL_DIRECTORY_LENGTH );
79
my @UtilityMethodNames = qw( _error _printError _ioError _formatError
80
_subclassResponsibility _binmode _isSeekable _newFileHandle _readSignature
83
@EXPORT_OK = ('computeCRC32');
85
'CONSTANTS' => \@ConstantNames,
86
'MISC_CONSTANTS' => \@MiscConstantNames,
87
'ERROR_CODES' => \@ErrorCodeNames,
89
# The following two sets are for internal use only
90
'PKZIP_CONSTANTS' => \@PKZipConstantNames,
91
'UTILITY_METHODS' => \@UtilityMethodNames
94
# Add all the constant names and error code names to @EXPORT_OK
95
Exporter::export_ok_tags(
96
'CONSTANTS', 'ERROR_CODES',
97
'PKZIP_CONSTANTS', 'UTILITY_METHODS',
102
# ------------------------- begin exportable error codes -------------------
104
use constant AZ_OK => 0;
105
use constant AZ_STREAM_END => 1;
106
use constant AZ_ERROR => 2;
107
use constant AZ_FORMAT_ERROR => 3;
108
use constant AZ_IO_ERROR => 4;
110
# ------------------------- end exportable error codes ---------------------
111
# ------------------------- begin exportable constants ---------------------
114
# Values of Archive::Zip::Member->fileAttributeFormat()
116
use constant FA_MSDOS => 0;
117
use constant FA_AMIGA => 1;
118
use constant FA_VAX_VMS => 2;
119
use constant FA_UNIX => 3;
120
use constant FA_VM_CMS => 4;
121
use constant FA_ATARI_ST => 5;
122
use constant FA_OS2_HPFS => 6;
123
use constant FA_MACINTOSH => 7;
124
use constant FA_Z_SYSTEM => 8;
125
use constant FA_CPM => 9;
126
use constant FA_TOPS20 => 10;
127
use constant FA_WINDOWS_NTFS => 11;
128
use constant FA_QDOS => 12;
129
use constant FA_ACORN => 13;
130
use constant FA_VFAT => 14;
131
use constant FA_MVS => 15;
132
use constant FA_BEOS => 16;
133
use constant FA_TANDEM => 17;
134
use constant FA_THEOS => 18;
136
# general-purpose bit flag masks
137
# Found in Archive::Zip::Member->bitFlag()
139
use constant GPBF_ENCRYPTED_MASK => 1 << 0;
140
use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1;
141
use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3;
143
# deflating compression types, if compressionMethod == COMPRESSION_DEFLATED
144
# ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK )
146
use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1;
147
use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1;
148
use constant DEFLATING_COMPRESSION_FAST => 2 << 1;
149
use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1;
153
# these two are the only ones supported in this module
154
use constant COMPRESSION_STORED => 0; # file is stored (no compression)
155
use constant COMPRESSION_DEFLATED => 8; # file is Deflated
157
use constant COMPRESSION_LEVEL_NONE => 0;
158
use constant COMPRESSION_LEVEL_DEFAULT => -1;
159
use constant COMPRESSION_LEVEL_FASTEST => 1;
160
use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9;
162
# internal file attribute bits
163
# Found in Archive::Zip::Member::internalFileAttributes()
165
use constant IFA_TEXT_FILE_MASK => 1;
166
use constant IFA_TEXT_FILE => 1; # file is apparently text
167
use constant IFA_BINARY_FILE => 0;
169
# PKZIP file format miscellaneous constants (for internal use only)
170
use constant SIGNATURE_FORMAT => "V";
171
use constant SIGNATURE_LENGTH => 4;
173
# these lengths are without the signature.
174
use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50;
175
use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2";
176
use constant LOCAL_FILE_HEADER_LENGTH => 26;
178
# PKZIP docs don't mention the signature, but Info-Zip writes it.
179
use constant DATA_DESCRIPTOR_SIGNATURE => 0x08074b50;
180
use constant DATA_DESCRIPTOR_FORMAT => "V3";
181
use constant DATA_DESCRIPTOR_LENGTH => 12;
183
# but the signature is apparently optional.
184
use constant DATA_DESCRIPTOR_FORMAT_NO_SIG => "V2";
185
use constant DATA_DESCRIPTOR_LENGTH_NO_SIG => 8;
187
use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50;
188
use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2";
189
use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42;
191
use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50;
192
use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING =>
193
pack( "V", END_OF_CENTRAL_DIRECTORY_SIGNATURE );
194
use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v";
195
use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18;
197
use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1;
198
use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2;
199
use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5;
201
# the rest of these are not supported in this module
202
use constant COMPRESSION_SHRUNK => 1; # file is Shrunk
203
use constant COMPRESSION_REDUCED_1 => 2; # file is Reduced CF=1
204
use constant COMPRESSION_REDUCED_2 => 3; # file is Reduced CF=2
205
use constant COMPRESSION_REDUCED_3 => 4; # file is Reduced CF=3
206
use constant COMPRESSION_REDUCED_4 => 5; # file is Reduced CF=4
207
use constant COMPRESSION_IMPLODED => 6; # file is Imploded
208
use constant COMPRESSION_TOKENIZED => 7; # reserved for Tokenizing compr.
209
use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating
210
use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10;
212
# ------------------------- end of exportable constants ---------------------
214
use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive';
215
use constant ZIPMEMBERCLASS => 'Archive::Zip::Member';
217
sub new # Archive::Zip
220
return $class->ZIPARCHIVECLASS->new(@_);
223
sub computeCRC32 # Archive::Zip
226
$data = shift if ref($data); # allow calling as an obj method
228
return Compress::Zlib::crc32( $data, $crc );
231
# Report or change chunk size used for reading and writing.
232
# Also sets Zlib's default buffer size (eventually).
233
sub setChunkSize # Archive::Zip
235
my $chunkSize = shift;
236
$chunkSize = shift if ref($chunkSize); # object method on zip?
237
my $oldChunkSize = $Archive::Zip::ChunkSize;
238
$Archive::Zip::ChunkSize = $chunkSize if ($chunkSize);
239
return $oldChunkSize;
242
sub chunkSize # Archive::Zip
244
return $Archive::Zip::ChunkSize;
247
sub setErrorHandler (&) # Archive::Zip
249
my $errorHandler = shift;
250
$errorHandler = \&Carp::carp unless defined($errorHandler);
251
my $oldErrorHandler = $Archive::Zip::ErrorHandler;
252
$Archive::Zip::ErrorHandler = $errorHandler;
253
return $oldErrorHandler;
256
# ----------------------------------------------------------------------
257
# Private utility functions (not methods).
258
# ----------------------------------------------------------------------
260
sub _printError # Archive::Zip
262
my $string = join ( ' ', @_, "\n" );
263
my $oldCarpLevel = $Carp::CarpLevel;
264
$Carp::CarpLevel += 2;
265
&{$ErrorHandler} ($string);
266
$Carp::CarpLevel = $oldCarpLevel;
269
# This is called on format errors.
270
sub _formatError # Archive::Zip
272
shift if ref( $_[0] );
273
_printError( 'format error:', @_ );
274
return AZ_FORMAT_ERROR;
277
# This is called on IO errors.
278
sub _ioError # Archive::Zip
280
shift if ref( $_[0] );
281
_printError( 'IO error:', @_, ':', $! );
285
# This is called on generic errors.
286
sub _error # Archive::Zip
288
shift if ref( $_[0] );
289
_printError( 'error:', @_ );
293
# Called when a subclass should have implemented
294
# something but didn't
295
sub _subclassResponsibility # Archive::Zip
297
Carp::croak("subclass Responsibility\n");
300
# Try to set the given file handle or object into binary mode.
301
sub _binmode # Archive::Zip
304
return UNIVERSAL::can( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh);
307
# Attempt to guess whether file handle is seekable.
308
# Because of problems with Windoze, this only returns true when
309
# the file handle is a real file.
310
sub _isSeekable # Archive::Zip
314
if ( UNIVERSAL::isa( $fh, 'IO::Scalar' ) )
318
elsif ( UNIVERSAL::isa( $fh, 'IO::String' ) )
322
elsif ( UNIVERSAL::can( $fh, 'stat' ) )
326
return UNIVERSAL::can( $fh, 'seek' );
329
# Return an opened IO::Handle
330
# my ( $status, fh ) = _newFileHandle( 'fileName', 'w' );
331
# Can take a filename, file handle, or ref to GLOB
332
# Or, if given something that is a ref but not an IO::Handle,
333
# passes back the same thing.
334
sub _newFileHandle # Archive::Zip
342
if ( UNIVERSAL::isa( $fd, 'IO::Scalar' )
343
or UNIVERSAL::isa( $fd, 'IO::String' ) )
347
elsif ( UNIVERSAL::isa( $fd, 'IO::Handle' )
348
or UNIVERSAL::isa( $fd, 'GLOB' ) )
350
$handle = IO::File->new();
351
$status = $handle->fdopen( $fd, @_ );
360
$handle = IO::File->new();
361
$status = $handle->open( $fd, @_ );
364
return ( $status, $handle );
367
# Returns next signature from given file handle, leaves
368
# file handle positioned afterwards.
369
# In list context, returns ($status, $signature)
370
# ( $status, $signature) = _readSignature( $fh, $fileName );
372
sub _readSignature # Archive::Zip
375
my $fileName = shift;
376
my $expectedSignature = shift; # optional
379
my $bytesRead = $fh->read( $signatureData, SIGNATURE_LENGTH );
380
return _ioError("reading header signature")
381
if $bytesRead != SIGNATURE_LENGTH;
382
my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
385
# compare with expected signature, if any, or any known signature.
386
if ( ( defined($expectedSignature) && $signature != $expectedSignature )
387
|| ( !defined($expectedSignature)
388
&& $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
389
&& $signature != LOCAL_FILE_HEADER_SIGNATURE
390
&& $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE
391
&& $signature != DATA_DESCRIPTOR_SIGNATURE ) )
393
my $errmsg = sprintf( "bad signature: 0x%08x", $signature );
394
if ( _isSeekable($fh) )
397
sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH );
400
$status = _formatError("$errmsg in file $fileName");
403
return ( $status, $signature );
406
# Utility method to make and open a temp file.
407
# Will create $temp_dir if it doesn't exist.
408
# Returns file handle and name:
410
# my ($fh, $name) = Archive::Zip::tempFile();
411
# my ($fh, $name) = Archive::Zip::tempFile('mytempdir');
414
sub tempFile # Archive::Zip
417
my ( $fh, $filename ) = File::Temp::tempfile(
419
UNLINK => 0, # we will delete it!
420
$dir ? ( DIR => $dir ) : ()
422
return ( undef, undef ) unless $fh;
423
my ( $status, $newfh ) = _newFileHandle( $fh, 'w+' );
424
return ( $newfh, $filename );
427
# Return the normalized directory name as used in a zip file (path
428
# separators become slashes, etc.).
429
# Will translate internal slashes in path components (i.e. on Macs) to
430
# underscores. Discards volume names.
431
# When $forceDir is set, returns paths with trailing slashes (or arrays
432
# with trailing blank members).
434
# If third argument is a reference, returns volume information there.
439
# ./a/b ('a','b') a/b
440
# ./a/b/ ('a','b') a/b
442
# /a/b/ ('','a','b') /a/b
443
# c:\a\b\c.doc ('','a','b','c.doc') /a/b/c.doc # on Windoze
444
# "i/o maps:whatever" ('i_o maps', 'whatever') "i_o maps/whatever" # on Macs
445
sub _asZipDirName # Archive::Zip
448
my $forceDir = shift;
449
my $volReturn = shift;
450
my ( $volume, $directories, $file ) =
451
File::Spec->splitpath( File::Spec->canonpath($name), $forceDir );
452
$$volReturn = $volume if ( ref($volReturn) );
453
my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories);
454
if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component
455
push ( @dirs, $file || '' );
456
#return wantarray ? @dirs : join ( '/', @dirs );
457
return join ( '/', @dirs );
460
# Return an absolute local name for a zip name.
461
# Assume a directory if zip name has trailing slash.
462
# Takes an optional volume name in FS format (like 'a:').
464
sub _asLocalName # Archive::Zip
466
my $name = shift; # zip format
468
$volume = '' unless defined($volume); # local FS format
470
my @paths = split ( /\//, $name );
471
my $filename = pop (@paths);
472
$filename = '' unless defined($filename);
473
my $localDirs = File::Spec->catdir(@paths);
474
my $localName = File::Spec->catpath( $volume, $localDirs, $filename );
475
$localName = File::Spec->rel2abs($localName) unless $volume;
479
# ----------------------------------------------------------------------
480
# class Archive::Zip::Archive (concrete)
481
# Generic ZIP archive.
482
# ----------------------------------------------------------------------
483
package Archive::Zip::Archive;
492
@ISA = qw( Archive::Zip );
496
use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
500
# Note that this returns undef on read errors, else new zip object.
502
sub new # Archive::Zip::Archive
507
'diskNumberWithStartOfCentralDirectory' => 0,
508
'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
509
'numberOfCentralDirectories' => 0, # shld be # of members
510
'centralDirectorySize' => 0, # must re-compute on write
511
'centralDirectoryOffsetWRTStartingDiskNumber' => 0, # must re-compute
512
'writeEOCDOffset' => 0,
513
'writeCentralDirectoryOffset' => 0,
514
'zipfileComment' => '',
520
$self->{'members'} = [];
523
my $status = $self->read(@_);
524
return $status == AZ_OK ? $self : undef;
529
sub members # Archive::Zip::Archive
531
@{ shift->{'members'} };
534
sub numberOfMembers # Archive::Zip::Archive
536
scalar( shift->members() );
539
sub memberNames # Archive::Zip::Archive
542
return map { $_->fileName() } $self->members();
545
# return ref to member with given name or undef
546
sub memberNamed # Archive::Zip::Archive
548
my ( $self, $fileName ) = @_;
549
foreach my $member ( $self->members() )
551
return $member if $member->fileName() eq $fileName;
556
sub membersMatching # Archive::Zip::Archive
558
my ( $self, $pattern ) = @_;
559
return grep { $_->fileName() =~ /$pattern/ } $self->members();
562
sub diskNumber # Archive::Zip::Archive
564
shift->{'diskNumber'};
567
sub diskNumberWithStartOfCentralDirectory # Archive::Zip::Archive
569
shift->{'diskNumberWithStartOfCentralDirectory'};
572
sub numberOfCentralDirectoriesOnThisDisk # Archive::Zip::Archive
574
shift->{'numberOfCentralDirectoriesOnThisDisk'};
577
sub numberOfCentralDirectories # Archive::Zip::Archive
579
shift->{'numberOfCentralDirectories'};
582
sub centralDirectorySize # Archive::Zip::Archive
584
shift->{'centralDirectorySize'};
587
sub centralDirectoryOffsetWRTStartingDiskNumber # Archive::Zip::Archive
589
shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
592
sub zipfileComment # Archive::Zip::Archive
595
my $comment = $self->{'zipfileComment'};
598
$self->{'zipfileComment'} = pack( 'C0a*', shift () ); # avoid unicode
603
sub eocdOffset # Archive::Zip::Archive
605
shift->{'eocdOffset'};
608
# Return the name of the file last read.
609
sub fileName # Archive::Zip::Archive
614
sub removeMember # Archive::Zip::Archive
616
my ( $self, $member ) = @_;
617
$member = $self->memberNamed($member) unless ref($member);
618
return undef unless $member;
619
my @newMembers = grep { $_ != $member } $self->members();
620
$self->{'members'} = \@newMembers;
624
sub replaceMember # Archive::Zip::Archive
626
my ( $self, $oldMember, $newMember ) = @_;
627
$oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
628
return undef unless $oldMember;
629
return undef unless $newMember;
631
map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
632
$self->{'members'} = \@newMembers;
636
sub extractMember # Archive::Zip::Archive
640
$member = $self->memberNamed($member) unless ref($member);
641
return _error('member not found') unless $member;
642
my $originalSize = $member->compressedSize();
643
my $name = shift; # local FS name if given
644
my ( $volumeName, $dirName, $fileName );
645
if ( defined($name) )
647
( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
648
$dirName = File::Spec->catpath( $volumeName, $dirName, '' );
652
$name = $member->fileName();
653
( $dirName = $name ) =~ s{[^/]*$}{};
654
$dirName = Archive::Zip::_asLocalName($dirName);
655
$name = Archive::Zip::_asLocalName($name);
657
if ( $dirName && !-d $dirName )
660
return _ioError("can't create dir $dirName") if ( !-d $dirName );
662
my $rc = $member->extractToFileNamed( $name, @_ );
663
# TODO refactor this fix into extractToFileNamed()
664
$member->{'compressedSize'} = $originalSize;
668
sub extractMemberWithoutPaths # Archive::Zip::Archive
672
$member = $self->memberNamed($member) unless ref($member);
673
return _error('member not found') unless $member;
674
my $originalSize = $member->compressedSize();
675
return AZ_OK if $member->isDirectory();
679
$name = $member->fileName();
680
$name =~ s{.*/}{}; # strip off directories, if any
681
$name = Archive::Zip::_asLocalName($name);
683
my $rc = $member->extractToFileNamed( $name, @_ );
684
$member->{'compressedSize'} = $originalSize;
688
sub addMember # Archive::Zip::Archive
690
my ( $self, $newMember ) = @_;
691
push ( @{ $self->{'members'} }, $newMember ) if $newMember;
695
sub addFile # Archive::Zip::Archive
698
my $fileName = shift;
700
my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
701
$self->addMember($newMember) if defined($newMember);
705
sub addString # Archive::Zip::Archive
708
my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
709
return $self->addMember($newMember);
712
sub addDirectory # Archive::Zip::Archive
714
my ( $self, $name, $newName ) = @_;
715
my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
716
$self->addMember($newMember);
720
# add either a file or a directory.
722
sub addFileOrDirectory
724
my ( $self, $name, $newName ) = @_;
727
( $newName =~ s{/$}{} ) if $newName;
728
return $self->addFile( $name, $newName );
732
( $newName =~ s{[^/]$}{&/} ) if $newName;
733
return $self->addDirectory( $name, $newName );
737
return _error("$name is neither a file nor a directory");
741
sub contents # Archive::Zip::Archive
743
my ( $self, $member, $newContents ) = @_;
744
$member = $self->memberNamed($member) unless ref($member);
745
return undef unless $member;
746
return $member->contents($newContents);
749
sub writeToFileNamed # Archive::Zip::Archive
752
my $fileName = shift; # local FS format
753
foreach my $member ( $self->members() )
755
if ( $member->_usesFileNamed($fileName) )
757
return _error( "$fileName is needed by member "
758
. $member->fileName()
759
. "; consider using overwrite() or overwriteAs() instead." );
762
my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
763
return _ioError("Can't open $fileName for write") unless $status;
764
my $retval = $self->writeToFileHandle( $fh, 1 );
771
# It is possible to write data to the FH before calling this,
772
# perhaps to make a self-extracting archive.
773
sub writeToFileHandle # Archive::Zip::Archive
777
return _error('No filehandle given') unless $fh;
778
return _ioError('filehandle not open') unless $fh->opened();
780
my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
783
# Find out where the current position is.
784
my $offset = $fhIsSeekable ? $fh->tell() : 0;
785
$offset = 0 if $offset < 0;
787
foreach my $member ( $self->members() )
789
my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
791
return $retval if $retval != AZ_OK;
792
$offset += $member->_localHeaderSize() + $member->_writeOffset();
793
$offset += $member->hasDataDescriptor()
794
? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
797
# changed this so it reflects the last successful position
798
$self->{'writeCentralDirectoryOffset'} = $offset;
800
return $self->writeCentralDirectory($fh);
803
# Write zip back to the original file,
804
# as safely as possible.
805
# Returns AZ_OK if successful.
806
sub overwrite # Archive::Zip::Archive
809
return $self->overwriteAs( $self->{'fileName'} );
812
# Write zip to the specified file,
813
# as safely as possible.
814
# Returns AZ_OK if successful.
815
sub overwriteAs # Archive::Zip::Archive
819
return _error("no filename in overwriteAs()") unless defined($zipName);
821
my ( $fh, $tempName ) = Archive::Zip::tempFile();
822
return _error( "Can't open temp file", $! ) unless $fh;
824
( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
826
my $status = $self->writeToFileHandle($fh);
830
if ( $status != AZ_OK )
833
_printError("Can't write to $tempName");
840
if ( -f $zipName && !rename( $zipName, $backupName ) )
844
return _error( "Can't rename $zipName as $backupName", $err );
847
# move the temp to the original name (possibly copying)
848
unless ( File::Copy::move( $tempName, $zipName ) )
851
rename( $backupName, $zipName );
853
return _error( "Can't move $tempName to $zipName", $err );
857
if ( -f $backupName && !unlink($backupName) )
860
return _error( "Can't unlink $backupName", $err );
866
# Used only during writing
867
sub _writeCentralDirectoryOffset # Archive::Zip::Archive
869
shift->{'writeCentralDirectoryOffset'};
872
sub _writeEOCDOffset # Archive::Zip::Archive
874
shift->{'writeEOCDOffset'};
877
# Expects to have _writeEOCDOffset() set
878
sub _writeEndOfCentralDirectory # Archive::Zip::Archive
880
my ( $self, $fh ) = @_;
882
$fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
883
or return _ioError('writing EOCD Signature');
884
my $zipfileCommentLength = length( $self->zipfileComment() );
887
END_OF_CENTRAL_DIRECTORY_FORMAT,
889
0, # {'diskNumberWithStartOfCentralDirectory'},
890
$self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
891
$self->numberOfMembers(), # {'numberOfCentralDirectories'},
892
$self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
893
$self->_writeCentralDirectoryOffset(),
894
$zipfileCommentLength
897
or return _ioError('writing EOCD header');
898
if ($zipfileCommentLength)
900
$fh->print( $self->zipfileComment() )
901
or return _ioError('writing zipfile comment');
906
# $offset can be specified to truncate a zip file.
907
sub writeCentralDirectory # Archive::Zip::Archive
909
my ( $self, $fh, $offset ) = @_;
911
if ( defined($offset) )
913
$self->{'writeCentralDirectoryOffset'} = $offset;
914
$fh->seek( $offset, IO::Seekable::SEEK_SET )
915
or return _ioError('seeking to write central directory');
919
$offset = $self->_writeCentralDirectoryOffset();
922
foreach my $member ( $self->members() )
924
my $status = $member->_writeCentralDirectoryFileHeader($fh);
925
return $status if $status != AZ_OK;
926
$offset += $member->_centralDirectoryHeaderSize();
927
$self->{'writeEOCDOffset'} = $offset;
929
return $self->_writeEndOfCentralDirectory($fh);
932
sub read # Archive::Zip::Archive
935
my $fileName = shift;
936
return _error('No filename given') unless $fileName;
937
my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
938
return _ioError("opening $fileName for read") unless $status;
940
$status = $self->readFromFileHandle( $fh, $fileName );
941
return $status if $status != AZ_OK;
944
$self->{'fileName'} = $fileName;
948
sub readFromFileHandle # Archive::Zip::Archive
952
my $fileName = shift;
953
$fileName = $fh unless defined($fileName);
954
return _error('No filehandle given') unless $fh;
955
return _ioError('filehandle not open') unless $fh->opened();
958
$self->{'fileName'} = "$fh";
960
# TODO: how to support non-seekable zips?
961
return _error('file not seekable')
962
unless _isSeekable($fh);
964
$fh->seek( 0, 0 ); # rewind the file
966
my $status = $self->_findEndOfCentralDirectory($fh);
967
return $status if $status != AZ_OK;
969
my $eocdPosition = $fh->tell();
971
$status = $self->_readEndOfCentralDirectory($fh);
972
return $status if $status != AZ_OK;
974
$fh->seek( $eocdPosition - $self->centralDirectorySize(),
975
IO::Seekable::SEEK_SET )
976
or return _ioError("Can't seek $fileName");
978
# Try to detect garbage at beginning of archives
980
$self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
981
- $self->centralDirectoryOffsetWRTStartingDiskNumber();
986
$self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
987
$self->eocdOffset() );
989
( $status, $signature ) = _readSignature( $fh, $fileName );
990
return $status if $status != AZ_OK;
991
last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
992
$status = $newMember->_readCentralDirectoryFileHeader();
993
return $status if $status != AZ_OK;
994
$status = $newMember->endRead();
995
return $status if $status != AZ_OK;
996
$newMember->_becomeDirectoryIfNecessary();
997
push ( @{ $self->{'members'} }, $newMember );
1003
# Read EOCD, starting from position before signature.
1004
# Return AZ_OK on success.
1005
sub _readEndOfCentralDirectory # Archive::Zip::Archive
1010
# Skip past signature
1011
$fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
1012
or return _ioError("Can't seek past EOCD signature");
1015
my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
1016
if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH )
1018
return _ioError("reading end of central directory");
1021
my $zipfileCommentLength;
1022
( $self->{'diskNumber'},
1023
$self->{'diskNumberWithStartOfCentralDirectory'},
1024
$self->{'numberOfCentralDirectoriesOnThisDisk'},
1025
$self->{'numberOfCentralDirectories'},
1026
$self->{'centralDirectorySize'},
1027
$self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
1028
$zipfileCommentLength )
1029
= unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
1031
if ($zipfileCommentLength)
1033
my $zipfileComment = '';
1034
$bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
1035
if ( $bytesRead != $zipfileCommentLength )
1037
return _ioError("reading zipfile comment");
1039
$self->{'zipfileComment'} = $zipfileComment;
1045
# Seek in my file to the end, then read backwards until we find the
1046
# signature of the central directory record. Leave the file positioned right
1047
# before the signature. Returns AZ_OK if success.
1048
sub _findEndOfCentralDirectory # Archive::Zip::Archive
1053
$fh->seek( 0, IO::Seekable::SEEK_END )
1054
or return _ioError("seeking to end");
1056
my $fileLength = $fh->tell();
1057
if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 )
1059
return _formatError("file is too short");
1067
$seekOffset = $fileLength if ( $seekOffset > $fileLength );
1068
$fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
1069
or return _ioError("seek failed");
1070
my $bytesRead = $fh->read( $data, $seekOffset );
1071
if ( $bytesRead != $seekOffset )
1073
return _ioError("read failed");
1075
$pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
1078
or $seekOffset == $fileLength
1079
or $seekOffset >= $Archive::Zip::ChunkSize );
1084
$fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
1085
or return _ioError("seeking to EOCD");
1090
return _formatError("can't find EOCD signature");
1094
# Used to avoid taint problems when chdir'ing.
1095
# Not intended to increase security in any way; just intended to shut up the -T
1096
# complaints. If your Cwd module is giving you unreliable returns from cwd()
1097
# you have bigger problems than this.
1101
$dir =~ m/\A(.+)\z/s;
1105
sub addTree # Archive::Zip::Archive
1108
my $root = shift or return _error("root arg missing in call to addTree()");
1110
$dest = '' unless defined($dest);
1111
my $pred = shift || sub { -r };
1113
my $startDir = _untaintDir( cwd() );
1115
return _error( 'undef returned by _untaintDir on cwd ', cwd() )
1118
# This avoids chdir'ing in Find, in a way compatible with older
1119
# versions of File::Find.
1121
local $main::_ = $File::Find::name;
1122
my $dir = _untaintDir($File::Find::dir);
1124
push ( @files, $File::Find::name ) if (&$pred);
1128
File::Find::find( $wanted, $root );
1130
my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
1131
my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1133
$dest = _asZipDirName( $dest, 1 ); # with trailing slash
1135
foreach my $fileName (@files)
1137
my $isDir = -d $fileName;
1139
# normalize, remove leading ./
1140
my $archiveName = _asZipDirName( $fileName, $isDir );
1141
if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
1142
else { $archiveName =~ s{$pattern}{$dest} }
1143
next if $archiveName =~ m{^\.?/?$}; # skip current dir
1146
? $self->addDirectory( $fileName, $archiveName )
1147
: $self->addFile( $fileName, $archiveName );
1148
return _error("add $fileName failed in addTree()") if !$member;
1153
sub addTreeMatching # Archive::Zip::Archive
1157
or return _error("root arg missing in call to addTreeMatching()");
1159
$dest = '' unless defined($dest);
1161
or return _error("pattern missing in call to addTreeMatching()");
1164
$pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
1165
return $self->addTree( $root, $dest, $matcher );
1168
# $zip->extractTree( $root, $dest [, $volume] );
1170
# $root and $dest are Unix-style.
1171
# $volume is in local FS format.
1173
sub extractTree # Archive::Zip::Archive
1176
my $root = shift; # Zip format
1177
$root = '' unless defined($root);
1178
my $dest = shift; # Zip format
1179
$dest = './' unless defined($dest);
1180
my $volume = shift; # optional
1181
my $pattern = "^\Q$root";
1182
my @members = $self->membersMatching($pattern);
1184
foreach my $member (@members)
1186
my $fileName = $member->fileName(); # in Unix format
1187
$fileName =~ s{$pattern}{$dest}; # in Unix format
1188
# convert to platform format:
1189
$fileName = Archive::Zip::_asLocalName( $fileName, $volume );
1190
my $status = $member->extractToFileNamed($fileName);
1191
return $status if $status != AZ_OK;
1196
# $zip->updateMember( $memberOrName, $fileName );
1197
# Returns (possibly updated) member, if any; undef on errors.
1199
sub updateMember # Archive::Zip::Archive
1202
my $oldMember = shift;
1203
my $fileName = shift;
1205
if ( !defined($fileName) )
1207
_error("updateMember(): missing fileName argument");
1211
my @newStat = stat($fileName);
1214
_ioError("Can't stat $fileName");
1222
if ( ref($oldMember) )
1224
$memberName = $oldMember->fileName();
1228
$oldMember = $self->memberNamed( $memberName = $oldMember )
1229
|| $self->memberNamed( $memberName =
1230
_asZipDirName( $oldMember, $isDir ) );
1233
unless ( defined($oldMember)
1234
&& $oldMember->lastModTime() == $newStat[9]
1235
&& $oldMember->isDirectory() == $isDir
1236
&& ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
1239
# create the new member
1240
my $newMember = $isDir
1241
? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
1242
: $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
1244
unless ( defined($newMember) )
1246
_error("creation of member $fileName failed in updateMember()");
1250
# replace old member or append new one
1251
if ( defined($oldMember) )
1253
$self->replaceMember( $oldMember, $newMember );
1255
else { $self->addMember($newMember); }
1263
# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
1265
# This takes the same arguments as addTree, but first checks to see
1266
# whether the file or directory already exists in the zip file.
1268
# If the fourth argument $mirror is true, then delete all my members
1269
# if corresponding files weren't found.
1271
sub updateTree # Archive::Zip::Archive
1275
or return _error("root arg missing in call to updateTree()");
1277
$dest = '' unless defined($dest);
1278
$dest = _asZipDirName( $dest, 1 );
1279
my $pred = shift || sub { -r };
1282
my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
1283
my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1286
my $startDir = _untaintDir( cwd() );
1288
return _error( 'undef returned by _untaintDir on cwd ', cwd() )
1291
# This avoids chdir'ing in Find, in a way compatible with older
1292
# versions of File::Find.
1294
local $main::_ = $File::Find::name;
1295
my $dir = _untaintDir($File::Find::dir);
1297
push ( @files, $File::Find::name ) if (&$pred);
1301
File::Find::find( $wanted, $root );
1303
# Now @files has all the files that I could potentially be adding to
1304
# the zip. Only add the ones that are necessary.
1305
# For each file (updated or not), add its member name to @done.
1307
foreach my $fileName (@files)
1309
my @newStat = stat($fileName);
1312
# normalize, remove leading ./
1313
my $memberName = _asZipDirName( $fileName, $isDir );
1314
if ( $memberName eq $rootZipName ) { $memberName = $dest }
1315
else { $memberName =~ s{$pattern}{$dest} }
1316
next if $memberName =~ m{^\.?/?$}; # skip current dir
1318
$done{$memberName} = 1;
1319
my $changedMember = $self->updateMember( $memberName, $fileName );
1320
return _error("updateTree failed to update $fileName")
1321
unless ref($changedMember);
1324
# @done now has the archive names corresponding to all the found files.
1325
# If we're mirroring, delete all those members that aren't in @done.
1328
foreach my $member ( $self->members() )
1330
$self->removeMember($member)
1331
unless $done{ $member->fileName() };
1338
# ----------------------------------------------------------------------
1339
# class Archive::Zip::Member
1340
# A generic member of an archive ( abstract )
1341
# ----------------------------------------------------------------------
1342
package Archive::Zip::Member;
1343
use vars qw( @ISA );
1344
@ISA = qw ( Archive::Zip );
1348
use Archive::Zip qw( :CONSTANTS :MISC_CONSTANTS :ERROR_CODES
1349
:PKZIP_CONSTANTS :UTILITY_METHODS );
1353
use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
1357
use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
1358
use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
1359
use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
1360
use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
1362
# Unix perms for default creation of files/dirs.
1363
use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
1364
use constant DEFAULT_FILE_PERMISSIONS => 0100666;
1365
use constant DIRECTORY_ATTRIB => 040000;
1366
use constant FILE_ATTRIB => 0100000;
1368
# Returns self if successful, else undef
1369
# Assumes that fh is positioned at beginning of central directory file header.
1370
# Leaves fh positioned immediately after file header or EOCD signature.
1371
sub _newFromZipFile # Archive::Zip::Member
1374
my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
1378
sub newFromString # Archive::Zip::Member
1381
my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
1385
sub newFromFile # Archive::Zip::Member
1388
my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
1392
sub newDirectoryNamed # Archive::Zip::Member
1395
my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
1399
sub new # Archive::Zip::Member
1403
'lastModFileDateTime' => 0,
1404
'fileAttributeFormat' => FA_UNIX,
1405
'versionMadeBy' => 20,
1406
'versionNeededToExtract' => 20,
1408
'compressionMethod' => COMPRESSION_STORED,
1409
'desiredCompressionMethod' => COMPRESSION_STORED,
1410
'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
1411
'internalFileAttributes' => 0,
1412
'externalFileAttributes' => 0, # set later
1414
'cdExtraField' => '',
1415
'localExtraField' => '',
1416
'fileComment' => '',
1418
'compressedSize' => 0,
1419
'uncompressedSize' => 0,
1422
bless( $self, $class );
1423
$self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
1427
sub _becomeDirectoryIfNecessary # Archive::Zip::Member
1430
$self->_become(DIRECTORYMEMBERCLASS)
1431
if $self->isDirectory();
1435
# Morph into given class (do whatever cleanup I need to do)
1436
sub _become # Archive::Zip::Member
1438
return bless( $_[0], $_[1] );
1441
sub versionMadeBy # Archive::Zip::Member
1443
shift->{'versionMadeBy'};
1446
sub fileAttributeFormat # Archive::Zip::Member
1449
? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
1450
: $_[0]->{'fileAttributeFormat'};
1453
sub versionNeededToExtract # Archive::Zip::Member
1455
shift->{'versionNeededToExtract'};
1458
sub bitFlag # Archive::Zip::Member
1463
sub compressionMethod # Archive::Zip::Member
1465
shift->{'compressionMethod'};
1468
sub desiredCompressionMethod # Archive::Zip::Member
1471
my $newDesiredCompressionMethod = shift;
1472
my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
1473
if ( defined($newDesiredCompressionMethod) )
1475
$self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
1476
if ( $newDesiredCompressionMethod == COMPRESSION_STORED )
1478
$self->{'desiredCompressionLevel'} = 0;
1480
elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED )
1482
$self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
1485
return $oldDesiredCompressionMethod;
1488
sub desiredCompressionLevel # Archive::Zip::Member
1491
my $newDesiredCompressionLevel = shift;
1492
my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
1493
if ( defined($newDesiredCompressionLevel) )
1495
$self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
1496
$self->{'desiredCompressionMethod'} =
1497
( $newDesiredCompressionLevel
1498
? COMPRESSION_DEFLATED
1499
: COMPRESSION_STORED );
1501
return $oldDesiredCompressionLevel;
1504
sub fileName # Archive::Zip::Member
1507
my $newName = shift;
1510
$newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
1511
$self->{'fileName'} = $newName;
1513
return $self->{'fileName'};
1516
sub lastModFileDateTime # Archive::Zip::Member
1518
my $modTime = shift->{'lastModFileDateTime'};
1519
$modTime =~ m/^(\d+)$/; # untaint
1523
sub lastModTime # Archive::Zip::Member
1526
return _dosToUnixTime( $self->lastModFileDateTime() );
1529
sub setLastModFileDateTimeFromUnix # Archive::Zip::Member
1533
$self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
1536
# DOS date/time format
1537
# 0-4 (5) Second divided by 2
1538
# 5-10 (6) Minute (0-59)
1539
# 11-15 (5) Hour (0-23 on a 24-hour clock)
1540
# 16-20 (5) Day of the month (1-31)
1541
# 21-24 (4) Month (1 = January, 2 = February, etc.)
1542
# 25-31 (7) Year offset from 1980 (add 1980 to get actual year)
1544
# Convert DOS date/time format to unix time_t format
1545
# NOT AN OBJECT METHOD!
1546
sub _dosToUnixTime # Archive::Zip::Member
1549
return time() unless defined($dt);
1551
my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
1552
my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
1553
my $mday = ( ( $dt >> 16 ) & 0x1f );
1555
my $hour = ( ( $dt >> 11 ) & 0x1f );
1556
my $min = ( ( $dt >> 5 ) & 0x3f );
1557
my $sec = ( ( $dt << 1 ) & 0x3e );
1561
eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
1562
return time() if ($@);
1566
sub internalFileAttributes # Archive::Zip::Member
1568
shift->{'internalFileAttributes'};
1571
sub externalFileAttributes # Archive::Zip::Member
1573
shift->{'externalFileAttributes'};
1576
# Convert UNIX permissions into proper value for zip file
1578
sub _mapPermissionsFromUnix # Archive::Zip::Member
1581
return $perms << 16;
1583
# TODO: map MS-DOS perms too (RHSA?)
1586
# Convert ZIP permissions into Unix ones
1588
# This was taken from Info-ZIP group's portable UnZip
1589
# zipfile-extraction program, version 5.50.
1590
# http://www.info-zip.org/pub/infozip/
1592
# See the mapattr() function in unix/unix.c
1593
# See the attribute format constants in unzpriv.h
1595
# XXX Note that there's one situation that isn't implemented
1596
# yet that depends on the "extra field."
1597
sub _mapPermissionsToUnix # Archive::Zip::Member
1601
my $format = $self->{'fileAttributeFormat'};
1602
my $attribs = $self->{'externalFileAttributes'};
1606
if ( $format == FA_AMIGA )
1608
$attribs = $attribs >> 17 & 7; # Amiga RWE bits
1609
$mode = $attribs << 6 | $attribs << 3 | $attribs;
1613
if ( $format == FA_THEOS )
1615
$attribs &= 0xF1FFFFFF;
1616
if ( ( $attribs & 0xF0000000 ) != 0x40000000 )
1618
$attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
1622
$attribs &= 0x41FFFFFF; # leave directory bit as set
1626
if ( $format == FA_UNIX
1627
|| $format == FA_VAX_VMS
1628
|| $format == FA_ACORN
1629
|| $format == FA_ATARI_ST
1630
|| $format == FA_BEOS
1631
|| $format == FA_QDOS
1632
|| $format == FA_TANDEM )
1634
$mode = $attribs >> 16;
1635
return $mode if $mode != 0 or not $self->localExtraField;
1637
# warn("local extra field is: ", $self->localExtraField, "\n");
1639
# XXX This condition is not implemented
1640
# I'm just including the comments from the info-zip section for now.
1642
# Some (non-Info-ZIP) implementations of Zip for Unix and
1643
# VMS (and probably others ??) leave 0 in the upper 16-bit
1644
# part of the external_file_attributes field. Instead, they
1645
# store file permission attributes in some extra field.
1646
# As a work-around, we search for the presence of one of
1647
# these extra fields and fall back to the MSDOS compatible
1648
# part of external_file_attributes if one of the known
1649
# e.f. types has been detected.
1650
# Later, we might implement extraction of the permission
1651
# bits from the VMS extra field. But for now, the work-around
1652
# should be sufficient to provide "readable" extracted files.
1653
# (For ASI Unix e.f., an experimental remap from the e.f.
1654
# mode value IS already provided!)
1657
# PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
1658
# Unix attributes in the upper 16 bits of the external attributes
1659
# field, just like Info-ZIP's Zip for Unix. We try to use that
1660
# value, after a check for consistency with the MSDOS attribute
1662
if ( $format == FA_MSDOS )
1664
$mode = $attribs >> 16;
1667
# FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
1668
$attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
1670
# keep previous $mode setting when its "owner"
1671
# part appears to be consistent with DOS attribute flags!
1672
return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
1673
$mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
1677
sub unixFileAttributes # Archive::Zip::Member
1680
my $oldPerms = $self->_mapPermissionsToUnix();
1684
if ( $self->isDirectory() )
1686
$perms &= ~FILE_ATTRIB;
1687
$perms |= DIRECTORY_ATTRIB;
1691
$perms &= ~DIRECTORY_ATTRIB;
1692
$perms |= FILE_ATTRIB;
1694
$self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
1699
sub localExtraField # Archive::Zip::Member
1702
? ( $_[0]->{'localExtraField'} = $_[1] )
1703
: $_[0]->{'localExtraField'};
1706
sub cdExtraField # Archive::Zip::Member
1708
( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
1711
sub extraFields # Archive::Zip::Member
1714
return $self->localExtraField() . $self->cdExtraField();
1717
sub fileComment # Archive::Zip::Member
1720
? ( $_[0]->{'fileComment'} = pack( 'C0a*', $_[1] ) )
1721
: $_[0]->{'fileComment'};
1724
sub hasDataDescriptor # Archive::Zip::Member
1729
my $shouldHave = shift;
1732
$self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
1736
$self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
1739
return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
1742
sub crc32 # Archive::Zip::Member
1747
sub crc32String # Archive::Zip::Member
1749
sprintf( "%08x", shift->{'crc32'} );
1752
sub compressedSize # Archive::Zip::Member
1754
shift->{'compressedSize'};
1757
sub uncompressedSize # Archive::Zip::Member
1759
shift->{'uncompressedSize'};
1762
sub isEncrypted # Archive::Zip::Member
1764
shift->bitFlag() & GPBF_ENCRYPTED_MASK;
1767
sub isTextFile # Archive::Zip::Member
1770
my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
1774
$self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
1775
$self->{'internalFileAttributes'} |=
1776
( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
1778
return $bit == IFA_TEXT_FILE;
1781
sub isBinaryFile # Archive::Zip::Member
1784
my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
1788
$self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
1789
$self->{'internalFileAttributes'} |=
1790
( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
1792
return $bit == IFA_BINARY_FILE;
1795
sub extractToFileNamed # Archive::Zip::Member
1798
my $name = shift; # local FS name
1799
return _error("encryption unsupported") if $self->isEncrypted();
1800
mkpath( dirname($name) ); # croaks on error
1801
my ( $status, $fh ) = _newFileHandle( $name, 'w' );
1802
return _ioError("Can't open file $name for write") unless $status;
1803
my $retval = $self->extractToFileHandle($fh);
1805
utime( $self->lastModTime(), $self->lastModTime(), $name );
1809
sub isDirectory # Archive::Zip::Member
1814
sub externalFileName # Archive::Zip::Member
1819
# The following are used when copying data
1820
sub _writeOffset # Archive::Zip::Member
1822
shift->{'writeOffset'};
1825
sub _readOffset # Archive::Zip::Member
1827
shift->{'readOffset'};
1830
sub writeLocalHeaderRelativeOffset # Archive::Zip::Member
1832
shift->{'writeLocalHeaderRelativeOffset'};
1835
sub wasWritten { shift->{'wasWritten'} }
1837
sub _dataEnded # Archive::Zip::Member
1839
shift->{'dataEnded'};
1842
sub _readDataRemaining # Archive::Zip::Member
1844
shift->{'readDataRemaining'};
1847
sub _inflater # Archive::Zip::Member
1849
shift->{'inflater'};
1852
sub _deflater # Archive::Zip::Member
1854
shift->{'deflater'};
1857
# Return the total size of my local header
1858
sub _localHeaderSize # Archive::Zip::Member
1861
return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
1862
length( $self->fileName() ) + length( $self->localExtraField() );
1865
# Return the total size of my CD header
1866
sub _centralDirectoryHeaderSize # Archive::Zip::Member
1869
return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
1870
length( $self->fileName() ) + length( $self->cdExtraField() ) +
1871
length( $self->fileComment() );
1874
# convert a unix time to DOS date/time
1875
# NOT AN OBJECT METHOD!
1876
sub _unixToDosTime # Archive::Zip::Member
1879
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
1881
$dt += ( $sec >> 1 );
1882
$dt += ( $min << 5 );
1883
$dt += ( $hour << 11 );
1884
$dt += ( $mday << 16 );
1885
$dt += ( ( $mon + 1 ) << 21 );
1886
$dt += ( ( $year - 80 ) << 25 );
1890
# Write my local header to a file handle.
1891
# Stores the offset to the start of the header in my
1892
# writeLocalHeaderRelativeOffset member.
1893
# Returns AZ_OK on success.
1894
sub _writeLocalFileHeader # Archive::Zip::Member
1899
my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
1900
$fh->print($signatureData)
1901
or return _ioError("writing local header signature");
1904
LOCAL_FILE_HEADER_FORMAT,
1905
$self->versionNeededToExtract(),
1907
$self->desiredCompressionMethod(),
1908
$self->lastModFileDateTime(),
1910
$self->compressedSize(), # may need to be re-written later
1911
$self->uncompressedSize(),
1912
length( $self->fileName() ),
1913
length( $self->localExtraField() )
1916
$fh->print($header) or return _ioError("writing local header");
1917
if ( $self->fileName() )
1919
$fh->print( $self->fileName() )
1920
or return _ioError("writing local header filename");
1922
if ( $self->localExtraField() )
1924
$fh->print( $self->localExtraField() )
1925
or return _ioError("writing local extra field");
1931
sub _writeCentralDirectoryFileHeader # Archive::Zip::Member
1937
pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
1938
$fh->print($sigData)
1939
or return _ioError("writing central directory header signature");
1941
my $fileNameLength = length( $self->fileName() );
1942
my $extraFieldLength = length( $self->cdExtraField() );
1943
my $fileCommentLength = length( $self->fileComment() );
1946
CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
1947
$self->versionMadeBy(),
1948
$self->fileAttributeFormat(),
1949
$self->versionNeededToExtract(),
1951
$self->desiredCompressionMethod(),
1952
$self->lastModFileDateTime(),
1953
$self->crc32(), # these three fields should have been updated
1954
$self->_writeOffset(), # by writing the data stream out
1955
$self->uncompressedSize(), #
1959
0, # {'diskNumberStart'},
1960
$self->internalFileAttributes(),
1961
$self->externalFileAttributes(),
1962
$self->writeLocalHeaderRelativeOffset()
1966
or return _ioError("writing central directory header");
1967
if ($fileNameLength)
1969
$fh->print( $self->fileName() )
1970
or return _ioError("writing central directory header signature");
1972
if ($extraFieldLength)
1974
$fh->print( $self->cdExtraField() )
1975
or return _ioError("writing central directory extra field");
1977
if ($fileCommentLength)
1979
$fh->print( $self->fileComment() )
1980
or return _ioError("writing central directory file comment");
1986
# This writes a data descriptor to the given file handle.
1987
# Assumes that crc32, writeOffset, and uncompressedSize are
1988
# set correctly (they should be after a write).
1989
# Further, the local file header should have the
1990
# GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
1991
sub _writeDataDescriptor # Archive::Zip::Member
1996
SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
1997
DATA_DESCRIPTOR_SIGNATURE,
1999
$self->_writeOffset(), # compressed size
2000
$self->uncompressedSize()
2004
or return _ioError("writing data descriptor");
2008
# Re-writes the local file header with new crc32 and compressedSize fields.
2009
# To be called after writing the data stream.
2010
# Assumes that filename and extraField sizes didn't change since last written.
2011
sub _refreshLocalFileHeader # Archive::Zip::Member
2016
my $here = $fh->tell();
2017
$fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
2018
IO::Seekable::SEEK_SET )
2019
or return _ioError("seeking to rewrite local header");
2022
LOCAL_FILE_HEADER_FORMAT,
2023
$self->versionNeededToExtract(),
2025
$self->desiredCompressionMethod(),
2026
$self->lastModFileDateTime(),
2028
$self->_writeOffset(), # compressed size
2029
$self->uncompressedSize(),
2030
length( $self->fileName() ),
2031
length( $self->localExtraField() )
2035
or return _ioError("re-writing local header");
2036
$fh->seek( $here, IO::Seekable::SEEK_SET )
2037
or return _ioError("seeking after rewrite of local header");
2042
sub readChunk # Archive::Zip::Member
2044
my ( $self, $chunkSize ) = @_;
2046
if ( $self->readIsDone() )
2050
return ( \$dummy, AZ_STREAM_END );
2053
$chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
2054
$chunkSize = $self->_readDataRemaining()
2055
if $chunkSize > $self->_readDataRemaining();
2059
my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
2060
return ( \$buffer, $status ) unless $status == AZ_OK;
2062
$self->{'readDataRemaining'} -= $bytesRead;
2063
$self->{'readOffset'} += $bytesRead;
2065
if ( $self->compressionMethod() == COMPRESSION_STORED )
2067
$self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
2070
( $outputRef, $status ) = &{ $self->{'chunkHandler'} } ( $self, \$buffer );
2071
$self->{'writeOffset'} += length($$outputRef);
2074
if $self->readIsDone();
2076
return ( $outputRef, $status );
2079
# Read the next raw chunk of my data. Subclasses MUST implement.
2080
# my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
2081
sub _readRawChunk # Archive::Zip::Member
2084
return $self->_subclassResponsibility();
2087
# A place holder to catch rewindData errors if someone ignores
2089
sub _noChunk # Archive::Zip::Member
2092
return ( \undef, _error("trying to copy chunk when init failed") );
2095
# Basically a no-op so that I can have a consistent interface.
2096
# ( $outputRef, $status) = $self->_copyChunk( \$buffer );
2097
sub _copyChunk # Archive::Zip::Member
2099
my ( $self, $dataRef ) = @_;
2100
return ( $dataRef, AZ_OK );
2103
# ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
2104
sub _deflateChunk # Archive::Zip::Member
2106
my ( $self, $buffer ) = @_;
2107
my ( $out, $status ) = $self->_deflater()->deflate($buffer);
2109
if ( $self->_readDataRemaining() == 0 )
2112
( $extraOutput, $status ) = $self->_deflater()->flush();
2113
$out .= $extraOutput;
2115
return ( \$out, AZ_STREAM_END );
2117
elsif ( $status == Z_OK )
2119
return ( \$out, AZ_OK );
2124
my $retval = _error( 'deflate error', $status );
2126
return ( \$dummy, $retval );
2130
# ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
2131
sub _inflateChunk # Archive::Zip::Member
2133
my ( $self, $buffer ) = @_;
2134
my ( $out, $status ) = $self->_inflater()->inflate($buffer);
2136
$self->endRead() unless $status == Z_OK;
2137
if ( $status == Z_OK || $status == Z_STREAM_END )
2139
$retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
2140
return ( \$out, $retval );
2144
$retval = _error( 'inflate error', $status );
2146
return ( \$dummy, $retval );
2150
sub rewindData # Archive::Zip::Member
2155
# set to trap init errors
2156
$self->{'chunkHandler'} = $self->can('_noChunk');
2158
# Work around WinZip bug with 0-length DEFLATED files
2159
$self->desiredCompressionMethod(COMPRESSION_STORED)
2160
if $self->uncompressedSize() == 0;
2162
# assume that we're going to read the whole file, and compute the CRC anew.
2163
$self->{'crc32'} = 0
2164
if ( $self->compressionMethod() == COMPRESSION_STORED );
2166
# These are the only combinations of methods we deal with right now.
2167
if ( $self->compressionMethod() == COMPRESSION_STORED
2168
and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
2170
( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
2171
'-Level' => $self->desiredCompressionLevel(),
2172
'-WindowBits' => -MAX_WBITS(), # necessary magic
2173
'-Bufsize' => $Archive::Zip::ChunkSize,
2175
); # pass additional options
2176
return _error( 'deflateInit error:', $status )
2177
unless $status == Z_OK;
2178
$self->{'chunkHandler'} = $self->can('_deflateChunk');
2180
elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
2181
and $self->desiredCompressionMethod() == COMPRESSION_STORED )
2183
( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
2184
'-WindowBits' => -MAX_WBITS(), # necessary magic
2185
'-Bufsize' => $Archive::Zip::ChunkSize,
2187
); # pass additional options
2188
return _error( 'inflateInit error:', $status )
2189
unless $status == Z_OK;
2190
$self->{'chunkHandler'} = $self->can('_inflateChunk');
2192
elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() )
2194
$self->{'chunkHandler'} = $self->can('_copyChunk');
2200
"Unsupported compression combination: read %d, write %d",
2201
$self->compressionMethod(),
2202
$self->desiredCompressionMethod()
2207
$self->{'readDataRemaining'} =
2208
( $self->compressionMethod() == COMPRESSION_STORED )
2209
? $self->uncompressedSize()
2210
: $self->compressedSize();
2211
$self->{'dataEnded'} = 0;
2212
$self->{'readOffset'} = 0;
2217
sub endRead # Archive::Zip::Member
2220
delete $self->{'inflater'};
2221
delete $self->{'deflater'};
2222
$self->{'dataEnded'} = 1;
2223
$self->{'readDataRemaining'} = 0;
2227
sub readIsDone # Archive::Zip::Member
2230
return ( $self->_dataEnded() or !$self->_readDataRemaining() );
2233
sub contents # Archive::Zip::Member
2236
my $newContents = shift;
2238
if ( defined($newContents) )
2241
# change our type and call the subclass contents method.
2242
$self->_become(STRINGMEMBERCLASS);
2243
return $self->contents( pack( 'C0a*', $newContents ) )
2244
; # in case of Unicode
2248
my $oldCompression =
2249
$self->desiredCompressionMethod(COMPRESSION_STORED);
2250
my $status = $self->rewindData(@_);
2251
if ( $status != AZ_OK )
2257
while ( $status == AZ_OK )
2260
( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
2262
# did we get it in one chunk?
2263
if ( length($$ref) == $self->uncompressedSize() )
2267
else { $retval .= $$ref }
2269
$self->desiredCompressionMethod($oldCompression);
2271
$status = AZ_OK if $status == AZ_STREAM_END;
2272
$retval = undef unless $status == AZ_OK;
2273
return wantarray ? ( $retval, $status ) : $retval;
2277
sub extractToFileHandle # Archive::Zip::Member
2280
return _error("encryption unsupported") if $self->isEncrypted();
2283
my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
2284
my $status = $self->rewindData(@_);
2285
$status = $self->_writeData($fh) if $status == AZ_OK;
2286
$self->desiredCompressionMethod($oldCompression);
2291
# write local header and data stream to file handle
2292
sub _writeToFileHandle # Archive::Zip::Member
2296
my $fhIsSeekable = shift;
2299
return _error("no member name given for $self")
2300
unless $self->fileName();
2302
$self->{'writeLocalHeaderRelativeOffset'} = $offset;
2303
$self->{'wasWritten'} = 0;
2305
# Determine if I need to write a data descriptor
2306
# I need to do this if I can't refresh the header
2307
# and I don't know compressed size or crc32 fields.
2308
my $headerFieldsUnknown =
2309
( ( $self->uncompressedSize() > 0 )
2310
and ( $self->compressionMethod() == COMPRESSION_STORED
2311
or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) );
2313
my $shouldWriteDataDescriptor =
2314
( $headerFieldsUnknown and not $fhIsSeekable );
2316
$self->hasDataDescriptor(1)
2317
if ($shouldWriteDataDescriptor);
2319
$self->{'writeOffset'} = 0;
2321
my $status = $self->rewindData();
2322
( $status = $self->_writeLocalFileHeader($fh) )
2323
if $status == AZ_OK;
2324
( $status = $self->_writeData($fh) )
2325
if $status == AZ_OK;
2326
if ( $status == AZ_OK )
2328
$self->{'wasWritten'} = 1;
2329
if ( $self->hasDataDescriptor() )
2331
$status = $self->_writeDataDescriptor($fh);
2333
elsif ($headerFieldsUnknown)
2335
$status = $self->_refreshLocalFileHeader($fh);
2342
# Copy my (possibly compressed) data to given file handle.
2343
# Returns C<AZ_OK> on success
2344
sub _writeData # Archive::Zip::Member
2347
my $writeFh = shift;
2349
return AZ_OK if ( $self->uncompressedSize() == 0 );
2351
my $chunkSize = $Archive::Zip::ChunkSize;
2352
while ( $self->_readDataRemaining() > 0 )
2355
( $outRef, $status ) = $self->readChunk($chunkSize);
2356
return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
2358
if ( length($$outRef) > 0 )
2360
$writeFh->print($$outRef)
2361
or return _ioError("write error during copy");
2364
last if $status == AZ_STREAM_END;
2366
$self->{'compressedSize'} = $self->_writeOffset();
2370
# Return true if I depend on the named file
2376
# ----------------------------------------------------------------------
2377
# class Archive::Zip::DirectoryMember
2378
# ----------------------------------------------------------------------
2380
package Archive::Zip::DirectoryMember;
2383
use vars qw( @ISA );
2384
@ISA = qw ( Archive::Zip::Member );
2385
BEGIN { use Archive::Zip qw( :ERROR_CODES :UTILITY_METHODS ) }
2387
sub _newNamed # Archive::Zip::DirectoryMember
2390
my $fileName = shift; # FS name
2391
my $newName = shift; # Zip name
2392
$newName = _asZipDirName($fileName) unless $newName;
2393
my $self = $class->new(@_);
2394
$self->{'externalFileName'} = $fileName;
2395
$self->fileName($newName);
2402
$self->unixFileAttributes( $stat[2] );
2403
$self->setLastModFileDateTimeFromUnix( $stat[9] );
2405
else # hmm.. trying to add a non-directory?
2407
_error( $fileName, ' exists but is not a directory' );
2413
$self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
2414
$self->setLastModFileDateTimeFromUnix( time() );
2419
sub externalFileName # Archive::Zip::DirectoryMember
2421
shift->{'externalFileName'};
2424
sub isDirectory # Archive::Zip::DirectoryMember
2429
sub extractToFileNamed # Archive::Zip::DirectoryMember
2432
my $name = shift; # local FS name
2433
my $attribs = $self->unixFileAttributes() & 07777;
2434
mkpath( $name, 0, $attribs ); # croaks on error
2435
utime( $self->lastModTime(), $self->lastModTime(), $name );
2439
sub fileName # Archive::Zip::DirectoryMember
2442
my $newName = shift;
2443
$newName =~ s{/?$}{/} if defined($newName);
2444
return $self->SUPER::fileName($newName);
2447
# So people don't get too confused. This way it looks like the problem
2448
# is in their code...
2451
return wantarray ? ( undef, AZ_OK ) : undef;
2454
# ----------------------------------------------------------------------
2455
# class Archive::Zip::FileMember
2456
# Base class for classes that have file handles
2458
# ----------------------------------------------------------------------
2460
package Archive::Zip::FileMember;
2461
use vars qw( @ISA );
2462
@ISA = qw ( Archive::Zip::Member );
2463
BEGIN { use Archive::Zip qw( :UTILITY_METHODS ) }
2465
sub externalFileName # Archive::Zip::FileMember
2467
shift->{'externalFileName'};
2470
# Return true if I depend on the named file
2471
sub _usesFileNamed # Archive::Zip::FileMember
2474
my $fileName = shift;
2475
my $xfn = $self->externalFileName();
2476
return undef if ref($xfn);
2477
return $xfn eq $fileName;
2480
sub fh # Archive::Zip::FileMember
2484
if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened();
2485
return $self->{'fh'};
2488
# opens my file handle from my file name
2489
sub _openFile # Archive::Zip::FileMember
2492
my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
2495
_ioError( "Can't open", $self->externalFileName() );
2498
$self->{'fh'} = $fh;
2503
# Make sure I close my file handle
2504
sub endRead # Archive::Zip::FileMember
2507
undef $self->{'fh'}; # _closeFile();
2508
return $self->SUPER::endRead(@_);
2511
sub _become # Archive::Zip::FileMember
2514
my $newClass = shift;
2515
return $self if ref($self) eq $newClass;
2516
delete( $self->{'externalFileName'} );
2517
delete( $self->{'fh'} );
2518
return $self->SUPER::_become($newClass);
2521
# ----------------------------------------------------------------------
2522
# class Archive::Zip::NewFileMember
2523
# Used when adding a pre-existing file to an archive
2524
# ----------------------------------------------------------------------
2526
package Archive::Zip::NewFileMember;
2527
use vars qw( @ISA );
2528
@ISA = qw ( Archive::Zip::FileMember );
2530
BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :UTILITY_METHODS ) }
2532
# Given a file name, set up for eventual writing.
2533
sub _newFromFileNamed # Archive::Zip::NewFileMember
2536
my $fileName = shift; # local FS format
2537
my $newName = shift;
2538
$newName = _asZipDirName($fileName) unless defined($newName);
2539
return undef unless ( stat($fileName) && -r _ && !-d _ );
2540
my $self = $class->new(@_);
2541
$self->fileName($newName);
2542
$self->{'externalFileName'} = $fileName;
2543
$self->{'compressionMethod'} = COMPRESSION_STORED;
2545
$self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
2546
$self->desiredCompressionMethod( ( $self->compressedSize() > 0 )
2547
? COMPRESSION_DEFLATED
2548
: COMPRESSION_STORED );
2549
$self->unixFileAttributes( $stat[2] );
2550
$self->setLastModFileDateTimeFromUnix( $stat[9] );
2551
$self->isTextFile( -T _ );
2555
sub rewindData # Archive::Zip::NewFileMember
2559
my $status = $self->SUPER::rewindData(@_);
2560
return $status unless $status == AZ_OK;
2562
return AZ_IO_ERROR unless $self->fh();
2563
$self->fh()->clearerr();
2564
$self->fh()->seek( 0, IO::Seekable::SEEK_SET )
2565
or return _ioError( "rewinding", $self->externalFileName() );
2569
# Return bytes read. Note that first parameter is a ref to a buffer.
2571
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
2572
sub _readRawChunk # Archive::Zip::NewFileMember
2574
my ( $self, $dataRef, $chunkSize ) = @_;
2575
return ( 0, AZ_OK ) unless $chunkSize;
2576
my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
2577
or return ( 0, _ioError("reading data") );
2578
return ( $bytesRead, AZ_OK );
2581
# If I already exist, extraction is a no-op.
2582
sub extractToFileNamed # Archive::Zip::NewFileMember
2585
my $name = shift; # local FS name
2586
if ( File::Spec->rel2abs($name) eq
2587
File::Spec->rel2abs( $self->externalFileName() ) and -r $name )
2593
return $self->SUPER::extractToFileNamed( $name, @_ );
2597
# ----------------------------------------------------------------------
2598
# class Archive::Zip::ZipFileMember
2599
# This represents a member in an existing zip file on disk.
2600
# ----------------------------------------------------------------------
2602
package Archive::Zip::ZipFileMember;
2603
use vars qw( @ISA );
2604
@ISA = qw ( Archive::Zip::FileMember );
2608
use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
2612
# Create a new Archive::Zip::ZipFileMember
2613
# given a filename and optional open file handle
2615
sub _newFromZipFile # Archive::Zip::ZipFileMember
2619
my $externalFileName = shift;
2620
my $possibleEocdOffset = shift; # normally 0
2622
my $self = $class->new(
2624
'diskNumberStart' => 0,
2625
'localHeaderRelativeOffset' => 0,
2626
'dataOffset' => 0, # localHeaderRelativeOffset + header length
2629
$self->{'externalFileName'} = $externalFileName;
2630
$self->{'fh'} = $fh;
2631
$self->{'possibleEocdOffset'} = $possibleEocdOffset;
2635
sub isDirectory # Archive::Zip::ZipFileMember
2638
return ( substr( $self->fileName(), -1, 1 ) eq '/'
2639
and $self->uncompressedSize() == 0 );
2642
# Seek to the beginning of the local header, just past the signature.
2643
# Verify that the local header signature is in fact correct.
2644
# Update the localHeaderRelativeOffset if necessary by adding the possibleEocdOffset.
2647
sub _seekToLocalHeader # Archive::Zip::ZipFileMember
2650
my $where = shift; # optional
2651
my $previousWhere = shift; # optional
2653
$where = $self->localHeaderRelativeOffset() unless defined($where);
2655
# avoid loop on certain corrupt files (from Julian Field)
2656
return _formatError("corrupt zip file")
2657
if defined($previousWhere) && $where == $previousWhere;
2662
$status = $self->fh()->seek( $where, IO::Seekable::SEEK_SET );
2663
return _ioError("seeking to local header") unless $status;
2665
( $status, $signature ) =
2666
_readSignature( $self->fh(), $self->externalFileName(),
2667
LOCAL_FILE_HEADER_SIGNATURE );
2668
return $status if $status == AZ_IO_ERROR;
2670
# retry with EOCD offset if any was given.
2671
if ( $status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'} )
2674
$self->_seekToLocalHeader(
2675
$self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'},
2677
if ( $status == AZ_OK )
2679
$self->{'localHeaderRelativeOffset'} +=
2680
$self->{'possibleEocdOffset'};
2681
$self->{'possibleEocdOffset'} = 0;
2688
# Because I'm going to delete the file handle, read the local file
2689
# header if the file handle is seekable. If it isn't, I assume that
2690
# I've already read the local header.
2691
# Return ( $status, $self )
2693
sub _become # Archive::Zip::ZipFileMember
2696
my $newClass = shift;
2697
return $self if ref($self) eq $newClass;
2701
if ( _isSeekable( $self->fh() ) )
2703
my $here = $self->fh()->tell();
2704
$status = $self->_seekToLocalHeader();
2705
$status = $self->_readLocalFileHeader() if $status == AZ_OK;
2706
$self->fh()->seek( $here, IO::Seekable::SEEK_SET );
2707
return $status unless $status == AZ_OK;
2710
delete( $self->{'eocdCrc32'} );
2711
delete( $self->{'diskNumberStart'} );
2712
delete( $self->{'localHeaderRelativeOffset'} );
2713
delete( $self->{'dataOffset'} );
2715
return $self->SUPER::_become($newClass);
2718
sub diskNumberStart # Archive::Zip::ZipFileMember
2720
shift->{'diskNumberStart'};
2723
sub localHeaderRelativeOffset # Archive::Zip::ZipFileMember
2725
shift->{'localHeaderRelativeOffset'};
2728
sub dataOffset # Archive::Zip::ZipFileMember
2730
shift->{'dataOffset'};
2733
# Skip local file header, updating only extra field stuff.
2734
# Assumes that fh is positioned before signature.
2735
sub _skipLocalFileHeader # Archive::Zip::ZipFileMember
2739
my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
2740
if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
2742
return _ioError("reading local file header");
2745
my $extraFieldLength;
2747
( undef, # $self->{'versionNeededToExtract'},
2749
undef, # $self->{'compressionMethod'},
2750
undef, # $self->{'lastModFileDateTime'},
2752
undef, # $compressedSize,
2753
undef, # $uncompressedSize,
2756
= unpack( LOCAL_FILE_HEADER_FORMAT, $header );
2758
if ($fileNameLength)
2760
$self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
2761
or return _ioError("skipping local file name");
2764
if ($extraFieldLength)
2767
$self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
2768
if ( $bytesRead != $extraFieldLength )
2770
return _ioError("reading local extra field");
2774
$self->{'dataOffset'} = $self->fh()->tell();
2776
if ( $bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK )
2779
# Read the crc32, compressedSize, and uncompressedSize from the
2780
# extended data descriptor, which directly follows the compressed data.
2782
# Skip over the compressed file data (assumes that EOCD compressedSize
2784
$self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
2785
or return _ioError("seeking to extended local header");
2787
# these values should be set correctly from before.
2788
my $oldCrc32 = $self->{'eocdCrc32'};
2789
my $oldCompressedSize = $self->{'compressedSize'};
2790
my $oldUncompressedSize = $self->{'uncompressedSize'};
2792
my $status = $self->_readDataDescriptor();
2793
return $status unless $status == AZ_OK;
2795
return _formatError(
2796
"CRC or size mismatch while skipping data descriptor")
2797
if ( $oldCrc32 != $self->{'crc32'}
2798
|| $oldUncompressedSize != $self->{'uncompressedSize'} );
2804
# Read from a local file header into myself. Returns AZ_OK if successful.
2805
# Assumes that fh is positioned after signature.
2806
# Note that crc32, compressedSize, and uncompressedSize will be 0 if
2807
# GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag.
2809
sub _readLocalFileHeader # Archive::Zip::ZipFileMember
2813
my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
2814
if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
2816
return _ioError("reading local file header");
2821
my $uncompressedSize;
2822
my $extraFieldLength;
2823
( $self->{'versionNeededToExtract'}, $self->{'bitFlag'},
2824
$self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
2825
$crc32, $compressedSize,
2826
$uncompressedSize, $fileNameLength,
2828
= unpack( LOCAL_FILE_HEADER_FORMAT, $header );
2830
if ($fileNameLength)
2833
$bytesRead = $self->fh()->read( $fileName, $fileNameLength );
2834
if ( $bytesRead != $fileNameLength )
2836
return _ioError("reading local file name");
2838
$self->fileName($fileName);
2841
if ($extraFieldLength)
2844
$self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
2845
if ( $bytesRead != $extraFieldLength )
2847
return _ioError("reading local extra field");
2851
$self->{'dataOffset'} = $self->fh()->tell();
2853
if ( $self->hasDataDescriptor() )
2856
# Read the crc32, compressedSize, and uncompressedSize from the
2857
# extended data descriptor.
2858
# Skip over the compressed file data (assumes that EOCD compressedSize
2860
$self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
2861
or return _ioError("seeking to extended local header");
2863
my $status = $self->_readDataDescriptor();
2864
return $status unless $status == AZ_OK;
2868
return _formatError(
2869
"CRC or size mismatch after reading data descriptor")
2870
if ( $self->{'crc32'} != $crc32
2871
|| $self->{'uncompressedSize'} != $uncompressedSize );
2877
# This will read the data descriptor, which is after the end of compressed file
2878
# data in members that that have GPBF_HAS_DATA_DESCRIPTOR_MASK set in their
2880
# The only reliable way to find these is to rely on the EOCD compressedSize.
2881
# Assumes that file is positioned immediately after the compressed data.
2882
# Returns status; sets crc32, compressedSize, and uncompressedSize.
2883
sub _readDataDescriptor
2890
my $uncompressedSize;
2892
my $bytesRead = $self->fh()->read( $signatureData, SIGNATURE_LENGTH );
2893
return _ioError("reading header signature")
2894
if $bytesRead != SIGNATURE_LENGTH;
2895
my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
2897
# unfortunately, the signature appears to be optional.
2898
if ( $signature == DATA_DESCRIPTOR_SIGNATURE
2899
&& ( $signature != $self->{'crc32'} ) )
2901
$bytesRead = $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH );
2902
return _ioError("reading data descriptor")
2903
if $bytesRead != DATA_DESCRIPTOR_LENGTH;
2905
( $crc32, $compressedSize, $uncompressedSize ) =
2906
unpack( DATA_DESCRIPTOR_FORMAT, $header );
2911
$self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH_NO_SIG );
2912
return _ioError("reading data descriptor")
2913
if $bytesRead != DATA_DESCRIPTOR_LENGTH_NO_SIG;
2915
$crc32 = $signature;
2916
( $compressedSize, $uncompressedSize ) =
2917
unpack( DATA_DESCRIPTOR_FORMAT_NO_SIG, $header );
2920
$self->{'eocdCrc32'} = $self->{'crc32'}
2921
unless defined( $self->{'eocdCrc32'} );
2922
$self->{'crc32'} = $crc32;
2923
$self->{'compressedSize'} = $compressedSize;
2924
$self->{'uncompressedSize'} = $uncompressedSize;
2929
# Read a Central Directory header. Return AZ_OK on success.
2930
# Assumes that fh is positioned right after the signature.
2932
sub _readCentralDirectoryFileHeader # Archive::Zip::ZipFileMember
2935
my $fh = $self->fh();
2937
my $bytesRead = $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH );
2938
if ( $bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH )
2940
return _ioError("reading central dir header");
2942
my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
2944
$self->{'versionMadeBy'}, $self->{'fileAttributeFormat'},
2945
$self->{'versionNeededToExtract'}, $self->{'bitFlag'},
2946
$self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
2947
$self->{'crc32'}, $self->{'compressedSize'},
2948
$self->{'uncompressedSize'}, $fileNameLength,
2949
$extraFieldLength, $fileCommentLength,
2950
$self->{'diskNumberStart'}, $self->{'internalFileAttributes'},
2951
$self->{'externalFileAttributes'}, $self->{'localHeaderRelativeOffset'}
2953
= unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
2955
$self->{'eocdCrc32'} = $self->{'crc32'};
2957
if ($fileNameLength)
2959
$bytesRead = $fh->read( $self->{'fileName'}, $fileNameLength );
2960
if ( $bytesRead != $fileNameLength )
2962
_ioError("reading central dir filename");
2965
if ($extraFieldLength)
2967
$bytesRead = $fh->read( $self->{'cdExtraField'}, $extraFieldLength );
2968
if ( $bytesRead != $extraFieldLength )
2970
return _ioError("reading central dir extra field");
2973
if ($fileCommentLength)
2975
$bytesRead = $fh->read( $self->{'fileComment'}, $fileCommentLength );
2976
if ( $bytesRead != $fileCommentLength )
2978
return _ioError("reading central dir file comment");
2982
# NK 10/21/04: added to avoid problems with manipulated headers
2983
if ( $self->{'uncompressedSize'} != $self->{'compressedSize'}
2984
and $self->{'compressionMethod'} == COMPRESSION_STORED )
2986
$self->{'uncompressedSize'} = $self->{'compressedSize'};
2989
$self->desiredCompressionMethod( $self->compressionMethod() );
2994
sub rewindData # Archive::Zip::ZipFileMember
2998
my $status = $self->SUPER::rewindData(@_);
2999
return $status unless $status == AZ_OK;
3001
return AZ_IO_ERROR unless $self->fh();
3003
$self->fh()->clearerr();
3005
# Seek to local file header.
3006
# The only reason that I'm doing this this way is that the extraField
3007
# length seems to be different between the CD header and the LF header.
3008
$status = $self->_seekToLocalHeader();
3009
return $status unless $status == AZ_OK;
3011
# skip local file header
3012
$status = $self->_skipLocalFileHeader();
3013
return $status unless $status == AZ_OK;
3015
# Seek to beginning of file data
3016
$self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET )
3017
or return _ioError("seeking to beginning of file data");
3022
# Return bytes read. Note that first parameter is a ref to a buffer.
3024
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
3025
sub _readRawChunk # Archive::Zip::ZipFileMember
3027
my ( $self, $dataRef, $chunkSize ) = @_;
3028
return ( 0, AZ_OK ) unless $chunkSize;
3029
my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
3030
or return ( 0, _ioError("reading data") );
3031
return ( $bytesRead, AZ_OK );
3034
# ----------------------------------------------------------------------
3035
# class Archive::Zip::StringMember ( concrete )
3036
# A Zip member whose data lives in a string
3037
# ----------------------------------------------------------------------
3039
package Archive::Zip::StringMember;
3040
use vars qw( @ISA );
3041
@ISA = qw ( Archive::Zip::Member );
3043
BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES ) }
3045
# Create a new string member. Default is COMPRESSION_STORED.
3046
# Can take a ref to a string as well.
3047
sub _newFromString # Archive::Zip::StringMember
3052
my $self = $class->new(@_);
3053
$self->contents($string);
3054
$self->fileName($name) if defined($name);
3056
# Set the file date to now
3057
$self->setLastModFileDateTimeFromUnix( time() );
3058
$self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
3062
sub _become # Archive::Zip::StringMember
3065
my $newClass = shift;
3066
return $self if ref($self) eq $newClass;
3067
delete( $self->{'contents'} );
3068
return $self->SUPER::_become($newClass);
3071
# Get or set my contents. Note that we do not call the superclass
3072
# version of this, because it calls us.
3073
sub contents # Archive::Zip::StringMember
3077
if ( defined($string) )
3079
$self->{'contents'} =
3080
pack( 'C0a*', ( ref($string) eq 'SCALAR' ) ? $$string : $string );
3081
$self->{'uncompressedSize'} = $self->{'compressedSize'} =
3082
length( $self->{'contents'} );
3083
$self->{'compressionMethod'} = COMPRESSION_STORED;
3085
return $self->{'contents'};
3088
# Return bytes read. Note that first parameter is a ref to a buffer.
3090
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
3091
sub _readRawChunk # Archive::Zip::StringMember
3093
my ( $self, $dataRef, $chunkSize ) = @_;
3094
$$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
3095
return ( length($$dataRef), AZ_OK );
3102
# vim: ts=4 sw=4 tw=80 wrap
added
removed
0CPAN/Archive-Zip-1.16/lib/Archive/Zip.pm
