?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Importing Archive::Zip 1.16
[archive-zip.git] / lib / Archive / Zip.pm
blob11bde9a89ac3f8db901a2dc411aa2d4aab383771
1 #! perl -w
2 # $Revision: 1.104.2.1 $
3
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
6 # Perl itself.
7
8 # ----------------------------------------------------------------------
9 # class Archive::Zip
10 # Note that the package Archive::Zip exists only for exporting and
11 # sharing constants. Everything else is in another package
12 # in this file.
13 # Creation of a new Archive::Zip object actually creates a new object
14 # of class Archive::Zip::Archive.
15 # ----------------------------------------------------------------------
16
17 package Archive::Zip;
18 require 5.003_96;
19 use strict;
20
21 use Carp();
22 use IO::File();
23 use IO::Seekable();
24 use Compress::Zlib();
25 use File::Spec 0.8 ();
26 use File::Temp();
27
28 # use sigtrap qw(die normal-signals); # is this needed?
29
30 use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS $VERSION $ChunkSize $ErrorHandler );
31
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.
35 $ChunkSize = 32768;
36
37 $ErrorHandler = \&Carp::carp;
38
39 # BEGIN block is necessary here so that other modules can use the constants.
40 BEGIN
41 {
42 require Exporter;
43
44 $VERSION = "1.16";
45 @ISA = qw( Exporter );
46
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
52 IFA_BINARY_FILE );
53
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 );
66
67 my @ErrorCodeNames = qw( AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR
68 AZ_IO_ERROR );
69
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 );
78
79 my @UtilityMethodNames = qw( _error _printError _ioError _formatError
80 _subclassResponsibility _binmode _isSeekable _newFileHandle _readSignature
81 _asZipDirName);
82
83 @EXPORT_OK = ('computeCRC32');
84 %EXPORT_TAGS = (
85 'CONSTANTS' => \@ConstantNames,
86 'MISC_CONSTANTS' => \@MiscConstantNames,
87 'ERROR_CODES' => \@ErrorCodeNames,
88
89 # The following two sets are for internal use only
90 'PKZIP_CONSTANTS' => \@PKZipConstantNames,
91 'UTILITY_METHODS' => \@UtilityMethodNames
92 );
93
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',
98 'MISC_CONSTANTS'
99 );
100 }
101
102 # ------------------------- begin exportable error codes -------------------
103
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;
109
110 # ------------------------- end exportable error codes ---------------------
111 # ------------------------- begin exportable constants ---------------------
112
113 # File types
114 # Values of Archive::Zip::Member->fileAttributeFormat()
115
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;
135
136 # general-purpose bit flag masks
137 # Found in Archive::Zip::Member->bitFlag()
138
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;
142
143 # deflating compression types, if compressionMethod == COMPRESSION_DEFLATED
144 # ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK )
145
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;
150
151 # compression method
152
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
156
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;
161
162 # internal file attribute bits
163 # Found in Archive::Zip::Member::internalFileAttributes()
164
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;
168
169 # PKZIP file format miscellaneous constants (for internal use only)
170 use constant SIGNATURE_FORMAT => "V";
171 use constant SIGNATURE_LENGTH => 4;
172
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;
177
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;
182
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;
186
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;
190
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;
196
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;
200
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;
211
212 # ------------------------- end of exportable constants ---------------------
213
214 use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive';
215 use constant ZIPMEMBERCLASS => 'Archive::Zip::Member';
216
217 sub new # Archive::Zip
218 {
219 my $class = shift;
220 return $class->ZIPARCHIVECLASS->new(@_);
221 }
222
223 sub computeCRC32 # Archive::Zip
224 {
225 my $data = shift;
226 $data = shift if ref($data); # allow calling as an obj method
227 my $crc = shift;
228 return Compress::Zlib::crc32( $data, $crc );
229 }
230
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
234 {
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;
240 }
241
242 sub chunkSize # Archive::Zip
243 {
244 return $Archive::Zip::ChunkSize;
245 }
246
247 sub setErrorHandler (&) # Archive::Zip
248 {
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;
254 }
255
256 # ----------------------------------------------------------------------
257 # Private utility functions (not methods).
258 # ----------------------------------------------------------------------
259
260 sub _printError # Archive::Zip
261 {
262 my $string = join ( ' ', @_, "\n" );
263 my $oldCarpLevel = $Carp::CarpLevel;
264 $Carp::CarpLevel += 2;
265 &{$ErrorHandler} ($string);
266 $Carp::CarpLevel = $oldCarpLevel;
267 }
268
269 # This is called on format errors.
270 sub _formatError # Archive::Zip
271 {
272 shift if ref( $_[0] );
273 _printError( 'format error:', @_ );
274 return AZ_FORMAT_ERROR;
275 }
276
277 # This is called on IO errors.
278 sub _ioError # Archive::Zip
279 {
280 shift if ref( $_[0] );
281 _printError( 'IO error:', @_, ':', $! );
282 return AZ_IO_ERROR;
283 }
284
285 # This is called on generic errors.
286 sub _error # Archive::Zip
287 {
288 shift if ref( $_[0] );
289 _printError( 'error:', @_ );
290 return AZ_ERROR;
291 }
292
293 # Called when a subclass should have implemented
294 # something but didn't
295 sub _subclassResponsibility # Archive::Zip
296 {
297 Carp::croak("subclass Responsibility\n");
298 }
299
300 # Try to set the given file handle or object into binary mode.
301 sub _binmode # Archive::Zip
302 {
303 my $fh = shift;
304 return UNIVERSAL::can( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh);
305 }
306
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
311 {
312 my $fh = shift;
313
314 if ( UNIVERSAL::isa( $fh, 'IO::Scalar' ) )
315 {
316 return 0;
317 }
318 elsif ( UNIVERSAL::isa( $fh, 'IO::String' ) )
319 {
320 return 1;
321 }
322 elsif ( UNIVERSAL::can( $fh, 'stat' ) )
323 {
324 return -f $fh;
325 }
326 return UNIVERSAL::can( $fh, 'seek' );
327 }
328
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
335 {
336 my $fd = shift;
337 my $status = 1;
338 my $handle;
339
340 if ( ref($fd) )
341 {
342 if ( UNIVERSAL::isa( $fd, 'IO::Scalar' )
343 or UNIVERSAL::isa( $fd, 'IO::String' ) )
344 {
345 $handle = $fd;
346 }
347 elsif ( UNIVERSAL::isa( $fd, 'IO::Handle' )
348 or UNIVERSAL::isa( $fd, 'GLOB' ) )
349 {
350 $handle = IO::File->new();
351 $status = $handle->fdopen( $fd, @_ );
352 }
353 else
354 {
355 $handle = $fd;
356 }
357 }
358 else
359 {
360 $handle = IO::File->new();
361 $status = $handle->open( $fd, @_ );
362 }
363
364 return ( $status, $handle );
365 }
366
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 );
371
372 sub _readSignature # Archive::Zip
373 {
374 my $fh = shift;
375 my $fileName = shift;
376 my $expectedSignature = shift; # optional
377
378 my $signatureData;
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 );
383 my $status = AZ_OK;
384
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 ) )
392 {
393 my $errmsg = sprintf( "bad signature: 0x%08x", $signature );
394 if ( _isSeekable($fh) )
395 {
396 $errmsg .=
397 sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH );
398 }
399
400 $status = _formatError("$errmsg in file $fileName");
401 }
402
403 return ( $status, $signature );
404 }
405
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:
409 #
410 # my ($fh, $name) = Archive::Zip::tempFile();
411 # my ($fh, $name) = Archive::Zip::tempFile('mytempdir');
412 #
413
414 sub tempFile # Archive::Zip
415 {
416 my $dir = shift;
417 my ( $fh, $filename ) = File::Temp::tempfile(
418 SUFFIX => '.zip',
419 UNLINK => 0, # we will delete it!
420 $dir ? ( DIR => $dir ) : ()
421 );
422 return ( undef, undef ) unless $fh;
423 my ( $status, $newfh ) = _newFileHandle( $fh, 'w+' );
424 return ( $newfh, $filename );
425 }
426
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).
433 #
434 # If third argument is a reference, returns volume information there.
435 #
436 # input output
437 # . ('.') '.'
438 # ./a ('a') a
439 # ./a/b ('a','b') a/b
440 # ./a/b/ ('a','b') a/b
441 # 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
446 {
447 my $name = shift;
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 );
458 }
459
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:').
463 #
464 sub _asLocalName # Archive::Zip
465 {
466 my $name = shift; # zip format
467 my $volume = shift;
468 $volume = '' unless defined($volume); # local FS format
469
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;
476 return $localName;
477 }
478
479 # ----------------------------------------------------------------------
480 # class Archive::Zip::Archive (concrete)
481 # Generic ZIP archive.
482 # ----------------------------------------------------------------------
483 package Archive::Zip::Archive;
484 use File::Path;
485 use File::Find();
486 use File::Spec();
487 use File::Copy();
488 use File::Basename;
489 use Cwd;
490
491 use vars qw( @ISA );
492 @ISA = qw( Archive::Zip );
493
494 BEGIN
495 {
496 use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
497 :UTILITY_METHODS );
498 }
499
500 # Note that this returns undef on read errors, else new zip object.
501
502 sub new # Archive::Zip::Archive
503 {
504 my $class = shift;
505 my $self = bless( {
506 'diskNumber' => 0,
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' => '',
515 'eocdOffset' => 0,
516 'fileName' => ''
517 },
518 $class
519 );
520 $self->{'members'} = [];
521 if (@_)
522 {
523 my $status = $self->read(@_);
524 return $status == AZ_OK ? $self : undef;
525 }
526 return $self;
527 }
528
529 sub members # Archive::Zip::Archive
530 {
531 @{ shift->{'members'} };
532 }
533
534 sub numberOfMembers # Archive::Zip::Archive
535 {
536 scalar( shift->members() );
537 }
538
539 sub memberNames # Archive::Zip::Archive
540 {
541 my $self = shift;
542 return map { $_->fileName() } $self->members();
543 }
544
545 # return ref to member with given name or undef
546 sub memberNamed # Archive::Zip::Archive
547 {
548 my ( $self, $fileName ) = @_;
549 foreach my $member ( $self->members() )
550 {
551 return $member if $member->fileName() eq $fileName;
552 }
553 return undef;
554 }
555
556 sub membersMatching # Archive::Zip::Archive
557 {
558 my ( $self, $pattern ) = @_;
559 return grep { $_->fileName() =~ /$pattern/ } $self->members();
560 }
561
562 sub diskNumber # Archive::Zip::Archive
563 {
564 shift->{'diskNumber'};
565 }
566
567 sub diskNumberWithStartOfCentralDirectory # Archive::Zip::Archive
568 {
569 shift->{'diskNumberWithStartOfCentralDirectory'};
570 }
571
572 sub numberOfCentralDirectoriesOnThisDisk # Archive::Zip::Archive
573 {
574 shift->{'numberOfCentralDirectoriesOnThisDisk'};
575 }
576
577 sub numberOfCentralDirectories # Archive::Zip::Archive
578 {
579 shift->{'numberOfCentralDirectories'};
580 }
581
582 sub centralDirectorySize # Archive::Zip::Archive
583 {
584 shift->{'centralDirectorySize'};
585 }
586
587 sub centralDirectoryOffsetWRTStartingDiskNumber # Archive::Zip::Archive
588 {
589 shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
590 }
591
592 sub zipfileComment # Archive::Zip::Archive
593 {
594 my $self = shift;
595 my $comment = $self->{'zipfileComment'};
596 if (@_)
597 {
598 $self->{'zipfileComment'} = pack( 'C0a*', shift () ); # avoid unicode
599 }
600 return $comment;
601 }
602
603 sub eocdOffset # Archive::Zip::Archive
604 {
605 shift->{'eocdOffset'};
606 }
607
608 # Return the name of the file last read.
609 sub fileName # Archive::Zip::Archive
610 {
611 shift->{'fileName'};
612 }
613
614 sub removeMember # Archive::Zip::Archive
615 {
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;
621 return $member;
622 }
623
624 sub replaceMember # Archive::Zip::Archive
625 {
626 my ( $self, $oldMember, $newMember ) = @_;
627 $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
628 return undef unless $oldMember;
629 return undef unless $newMember;
630 my @newMembers =
631 map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
632 $self->{'members'} = \@newMembers;
633 return $oldMember;
634 }
635
636 sub extractMember # Archive::Zip::Archive
637 {
638 my $self = shift;
639 my $member = shift;
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) )
646 {
647 ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
648 $dirName = File::Spec->catpath( $volumeName, $dirName, '' );
649 }
650 else
651 {
652 $name = $member->fileName();
653 ( $dirName = $name ) =~ s{[^/]*$}{};
654 $dirName = Archive::Zip::_asLocalName($dirName);
655 $name = Archive::Zip::_asLocalName($name);
656 }
657 if ( $dirName && !-d $dirName )
658 {
659 mkpath($dirName);
660 return _ioError("can't create dir $dirName") if ( !-d $dirName );
661 }
662 my $rc = $member->extractToFileNamed( $name, @_ );
663 # TODO refactor this fix into extractToFileNamed()
664 $member->{'compressedSize'} = $originalSize;
665 return $rc;
666 }
667
668 sub extractMemberWithoutPaths # Archive::Zip::Archive
669 {
670 my $self = shift;
671 my $member = shift;
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();
676 my $name = shift;
677 unless ($name)
678 {
679 $name = $member->fileName();
680 $name =~ s{.*/}{}; # strip off directories, if any
681 $name = Archive::Zip::_asLocalName($name);
682 }
683 my $rc = $member->extractToFileNamed( $name, @_ );
684 $member->{'compressedSize'} = $originalSize;
685 return $rc;
686 }
687
688 sub addMember # Archive::Zip::Archive
689 {
690 my ( $self, $newMember ) = @_;
691 push ( @{ $self->{'members'} }, $newMember ) if $newMember;
692 return $newMember;
693 }
694
695 sub addFile # Archive::Zip::Archive
696 {
697 my $self = shift;
698 my $fileName = shift;
699 my $newName = shift;
700 my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
701 $self->addMember($newMember) if defined($newMember);
702 return $newMember;
703 }
704
705 sub addString # Archive::Zip::Archive
706 {
707 my $self = shift;
708 my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
709 return $self->addMember($newMember);
710 }
711
712 sub addDirectory # Archive::Zip::Archive
713 {
714 my ( $self, $name, $newName ) = @_;
715 my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
716 $self->addMember($newMember);
717 return $newMember;
718 }
719
720 # add either a file or a directory.
721
722 sub addFileOrDirectory
723 {
724 my ( $self, $name, $newName ) = @_;
725 if ( -f $name )
726 {
727 ( $newName =~ s{/$}{} ) if $newName;
728 return $self->addFile( $name, $newName );
729 }
730 elsif ( -d $name )
731 {
732 ( $newName =~ s{[^/]$}{&/} ) if $newName;
733 return $self->addDirectory( $name, $newName );
734 }
735 else
736 {
737 return _error("$name is neither a file nor a directory");
738 }
739 }
740
741 sub contents # Archive::Zip::Archive
742 {
743 my ( $self, $member, $newContents ) = @_;
744 $member = $self->memberNamed($member) unless ref($member);
745 return undef unless $member;
746 return $member->contents($newContents);
747 }
748
749 sub writeToFileNamed # Archive::Zip::Archive
750 {
751 my $self = shift;
752 my $fileName = shift; # local FS format
753 foreach my $member ( $self->members() )
754 {
755 if ( $member->_usesFileNamed($fileName) )
756 {
757 return _error( "$fileName is needed by member "
758 . $member->fileName()
759 . "; consider using overwrite() or overwriteAs() instead." );
760 }
761 }
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 );
765 $fh->close();
766 $fh = undef;
767
768 return $retval;
769 }
770
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
774 {
775 my $self = shift;
776 my $fh = shift;
777 return _error('No filehandle given') unless $fh;
778 return _ioError('filehandle not open') unless $fh->opened();
779
780 my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
781 _binmode($fh);
782
783 # Find out where the current position is.
784 my $offset = $fhIsSeekable ? $fh->tell() : 0;
785 $offset = 0 if $offset < 0;
786
787 foreach my $member ( $self->members() )
788 {
789 my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
790 $member->endRead();
791 return $retval if $retval != AZ_OK;
792 $offset += $member->_localHeaderSize() + $member->_writeOffset();
793 $offset += $member->hasDataDescriptor()
794 ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
795 : 0;
796
797 # changed this so it reflects the last successful position
798 $self->{'writeCentralDirectoryOffset'} = $offset;
799 }
800 return $self->writeCentralDirectory($fh);
801 }
802
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
807 {
808 my $self = shift;
809 return $self->overwriteAs( $self->{'fileName'} );
810 }
811
812 # Write zip to the specified file,
813 # as safely as possible.
814 # Returns AZ_OK if successful.
815 sub overwriteAs # Archive::Zip::Archive
816 {
817 my $self = shift;
818 my $zipName = shift;
819 return _error("no filename in overwriteAs()") unless defined($zipName);
820
821 my ( $fh, $tempName ) = Archive::Zip::tempFile();
822 return _error( "Can't open temp file", $! ) unless $fh;
823
824 ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
825
826 my $status = $self->writeToFileHandle($fh);
827 $fh->close();
828 $fh = undef;
829
830 if ( $status != AZ_OK )
831 {
832 unlink($tempName);
833 _printError("Can't write to $tempName");
834 return $status;
835 }
836
837 my $err;
838
839 # rename the zip
840 if ( -f $zipName && !rename( $zipName, $backupName ) )
841 {
842 $err = $!;
843 unlink($tempName);
844 return _error( "Can't rename $zipName as $backupName", $err );
845 }
846
847 # move the temp to the original name (possibly copying)
848 unless ( File::Copy::move( $tempName, $zipName ) )
849 {
850 $err = $!;
851 rename( $backupName, $zipName );
852 unlink($tempName);
853 return _error( "Can't move $tempName to $zipName", $err );
854 }
855
856 # unlink the backup
857 if ( -f $backupName && !unlink($backupName) )
858 {
859 $err = $!;
860 return _error( "Can't unlink $backupName", $err );
861 }
862
863 return AZ_OK;
864 }
865
866 # Used only during writing
867 sub _writeCentralDirectoryOffset # Archive::Zip::Archive
868 {
869 shift->{'writeCentralDirectoryOffset'};
870 }
871
872 sub _writeEOCDOffset # Archive::Zip::Archive
873 {
874 shift->{'writeEOCDOffset'};
875 }
876
877 # Expects to have _writeEOCDOffset() set
878 sub _writeEndOfCentralDirectory # Archive::Zip::Archive
879 {
880 my ( $self, $fh ) = @_;
881
882 $fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
883 or return _ioError('writing EOCD Signature');
884 my $zipfileCommentLength = length( $self->zipfileComment() );
885
886 my $header = pack(
887 END_OF_CENTRAL_DIRECTORY_FORMAT,
888 0, # {'diskNumber'},
889 0, # {'diskNumberWithStartOfCentralDirectory'},
890 $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
891 $self->numberOfMembers(), # {'numberOfCentralDirectories'},
892 $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
893 $self->_writeCentralDirectoryOffset(),
894 $zipfileCommentLength
895 );
896 $fh->print($header)
897 or return _ioError('writing EOCD header');
898 if ($zipfileCommentLength)
899 {
900 $fh->print( $self->zipfileComment() )
901 or return _ioError('writing zipfile comment');
902 }
903 return AZ_OK;
904 }
905
906 # $offset can be specified to truncate a zip file.
907 sub writeCentralDirectory # Archive::Zip::Archive
908 {
909 my ( $self, $fh, $offset ) = @_;
910
911 if ( defined($offset) )
912 {
913 $self->{'writeCentralDirectoryOffset'} = $offset;
914 $fh->seek( $offset, IO::Seekable::SEEK_SET )
915 or return _ioError('seeking to write central directory');
916 }
917 else
918 {
919 $offset = $self->_writeCentralDirectoryOffset();
920 }
921
922 foreach my $member ( $self->members() )
923 {
924 my $status = $member->_writeCentralDirectoryFileHeader($fh);
925 return $status if $status != AZ_OK;
926 $offset += $member->_centralDirectoryHeaderSize();
927 $self->{'writeEOCDOffset'} = $offset;
928 }
929 return $self->_writeEndOfCentralDirectory($fh);
930 }
931
932 sub read # Archive::Zip::Archive
933 {
934 my $self = shift;
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;
939
940 $status = $self->readFromFileHandle( $fh, $fileName );
941 return $status if $status != AZ_OK;
942
943 $fh->close();
944 $self->{'fileName'} = $fileName;
945 return AZ_OK;
946 }
947
948 sub readFromFileHandle # Archive::Zip::Archive
949 {
950 my $self = shift;
951 my $fh = shift;
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();
956
957 _binmode($fh);
958 $self->{'fileName'} = "$fh";
959
960 # TODO: how to support non-seekable zips?
961 return _error('file not seekable')
962 unless _isSeekable($fh);
963
964 $fh->seek( 0, 0 ); # rewind the file
965
966 my $status = $self->_findEndOfCentralDirectory($fh);
967 return $status if $status != AZ_OK;
968
969 my $eocdPosition = $fh->tell();
970
971 $status = $self->_readEndOfCentralDirectory($fh);
972 return $status if $status != AZ_OK;
973
974 $fh->seek( $eocdPosition - $self->centralDirectorySize(),
975 IO::Seekable::SEEK_SET )
976 or return _ioError("Can't seek $fileName");
977
978 # Try to detect garbage at beginning of archives
979 # This should be 0
980 $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
981 - $self->centralDirectoryOffsetWRTStartingDiskNumber();
982
983 for ( ; ; )
984 {
985 my $newMember =
986 $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
987 $self->eocdOffset() );
988 my $signature;
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 );
998 }
999
1000 return AZ_OK;
1001 }
1002
1003 # Read EOCD, starting from position before signature.
1004 # Return AZ_OK on success.
1005 sub _readEndOfCentralDirectory # Archive::Zip::Archive
1006 {
1007 my $self = shift;
1008 my $fh = shift;
1009
1010 # Skip past signature
1011 $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
1012 or return _ioError("Can't seek past EOCD signature");
1013
1014 my $header = '';
1015 my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
1016 if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH )
1017 {
1018 return _ioError("reading end of central directory");
1019 }
1020
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 );
1030
1031 if ($zipfileCommentLength)
1032 {
1033 my $zipfileComment = '';
1034 $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
1035 if ( $bytesRead != $zipfileCommentLength )
1036 {
1037 return _ioError("reading zipfile comment");
1038 }
1039 $self->{'zipfileComment'} = $zipfileComment;
1040 }
1041
1042 return AZ_OK;
1043 }
1044
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
1049 {
1050 my $self = shift;
1051 my $fh = shift;
1052 my $data = '';
1053 $fh->seek( 0, IO::Seekable::SEEK_END )
1054 or return _ioError("seeking to end");
1055
1056 my $fileLength = $fh->tell();
1057 if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 )
1058 {
1059 return _formatError("file is too short");
1060 }
1061
1062 my $seekOffset = 0;
1063 my $pos = -1;
1064 for ( ; ; )
1065 {
1066 $seekOffset += 512;
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 )
1072 {
1073 return _ioError("read failed");
1074 }
1075 $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
1076 last
1077 if ( $pos >= 0
1078 or $seekOffset == $fileLength
1079 or $seekOffset >= $Archive::Zip::ChunkSize );
1080 }
1081
1082 if ( $pos >= 0 )
1083 {
1084 $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
1085 or return _ioError("seeking to EOCD");
1086 return AZ_OK;
1087 }
1088 else
1089 {
1090 return _formatError("can't find EOCD signature");
1091 }
1092 }
1093
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.
1098 sub _untaintDir
1099 {
1100 my $dir = shift;
1101 $dir =~ m/\A(.+)\z/s;
1102 return $1;
1103 }
1104
1105 sub addTree # Archive::Zip::Archive
1106 {
1107 my $self = shift;
1108 my $root = shift or return _error("root arg missing in call to addTree()");
1109 my $dest = shift;
1110 $dest = '' unless defined($dest);
1111 my $pred = shift || sub { -r };
1112 my @files;
1113 my $startDir = _untaintDir( cwd() );
1114
1115 return _error( 'undef returned by _untaintDir on cwd ', cwd() )
1116 unless $startDir;
1117
1118 # This avoids chdir'ing in Find, in a way compatible with older
1119 # versions of File::Find.
1120 my $wanted = sub {
1121 local $main::_ = $File::Find::name;
1122 my $dir = _untaintDir($File::Find::dir);
1123 chdir($startDir);
1124 push ( @files, $File::Find::name ) if (&$pred);
1125 chdir($dir);
1126 };
1127
1128 File::Find::find( $wanted, $root );
1129
1130 my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
1131 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1132
1133 $dest = _asZipDirName( $dest, 1 ); # with trailing slash
1134
1135 foreach my $fileName (@files)
1136 {
1137 my $isDir = -d $fileName;
1138
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
1144 my $member =
1145 $isDir
1146 ? $self->addDirectory( $fileName, $archiveName )
1147 : $self->addFile( $fileName, $archiveName );
1148 return _error("add $fileName failed in addTree()") if !$member;
1149 }
1150 return AZ_OK;
1151 }
1152
1153 sub addTreeMatching # Archive::Zip::Archive
1154 {
1155 my $self = shift;
1156 my $root = shift
1157 or return _error("root arg missing in call to addTreeMatching()");
1158 my $dest = shift;
1159 $dest = '' unless defined($dest);
1160 my $pattern = shift
1161 or return _error("pattern missing in call to addTreeMatching()");
1162 my $pred = shift;
1163 my $matcher =
1164 $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
1165 return $self->addTree( $root, $dest, $matcher );
1166 }
1167
1168 # $zip->extractTree( $root, $dest [, $volume] );
1169 #
1170 # $root and $dest are Unix-style.
1171 # $volume is in local FS format.
1172 #
1173 sub extractTree # Archive::Zip::Archive
1174 {
1175 my $self = shift;
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);
1183
1184 foreach my $member (@members)
1185 {
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;
1192 }
1193 return AZ_OK;
1194 }
1195
1196 # $zip->updateMember( $memberOrName, $fileName );
1197 # Returns (possibly updated) member, if any; undef on errors.
1198
1199 sub updateMember # Archive::Zip::Archive
1200 {
1201 my $self = shift;
1202 my $oldMember = shift;
1203 my $fileName = shift;
1204
1205 if ( !defined($fileName) )
1206 {
1207 _error("updateMember(): missing fileName argument");
1208 return undef;
1209 }
1210
1211 my @newStat = stat($fileName);
1212 if ( !@newStat )
1213 {
1214 _ioError("Can't stat $fileName");
1215 return undef;
1216 }
1217
1218 my $isDir = -d _;
1219
1220 my $memberName;
1221
1222 if ( ref($oldMember) )
1223 {
1224 $memberName = $oldMember->fileName();
1225 }
1226 else
1227 {
1228 $oldMember = $self->memberNamed( $memberName = $oldMember )
1229 || $self->memberNamed( $memberName =
1230 _asZipDirName( $oldMember, $isDir ) );
1231 }
1232
1233 unless ( defined($oldMember)
1234 && $oldMember->lastModTime() == $newStat[9]
1235 && $oldMember->isDirectory() == $isDir
1236 && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
1237 {
1238
1239 # create the new member
1240 my $newMember = $isDir
1241 ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
1242 : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
1243
1244 unless ( defined($newMember) )
1245 {
1246 _error("creation of member $fileName failed in updateMember()");
1247 return undef;
1248 }
1249
1250 # replace old member or append new one
1251 if ( defined($oldMember) )
1252 {
1253 $self->replaceMember( $oldMember, $newMember );
1254 }
1255 else { $self->addMember($newMember); }
1256
1257 return $newMember;
1258 }
1259
1260 return $oldMember;
1261 }
1262
1263 # $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
1264 #
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.
1267 #
1268 # If the fourth argument $mirror is true, then delete all my members
1269 # if corresponding files weren't found.
1270
1271 sub updateTree # Archive::Zip::Archive
1272 {
1273 my $self = shift;
1274 my $root = shift
1275 or return _error("root arg missing in call to updateTree()");
1276 my $dest = shift;
1277 $dest = '' unless defined($dest);
1278 $dest = _asZipDirName( $dest, 1 );
1279 my $pred = shift || sub { -r };
1280 my $mirror = shift;
1281
1282 my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
1283 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1284
1285 my @files;
1286 my $startDir = _untaintDir( cwd() );
1287
1288 return _error( 'undef returned by _untaintDir on cwd ', cwd() )
1289 unless $startDir;
1290
1291 # This avoids chdir'ing in Find, in a way compatible with older
1292 # versions of File::Find.
1293 my $wanted = sub {
1294 local $main::_ = $File::Find::name;
1295 my $dir = _untaintDir($File::Find::dir);
1296 chdir($startDir);
1297 push ( @files, $File::Find::name ) if (&$pred);
1298 chdir($dir);
1299 };
1300
1301 File::Find::find( $wanted, $root );
1302
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.
1306 my %done;
1307 foreach my $fileName (@files)
1308 {
1309 my @newStat = stat($fileName);
1310 my $isDir = -d _;
1311
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
1317
1318 $done{$memberName} = 1;
1319 my $changedMember = $self->updateMember( $memberName, $fileName );
1320 return _error("updateTree failed to update $fileName")
1321 unless ref($changedMember);
1322 }
1323
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.
1326 if ($mirror)
1327 {
1328 foreach my $member ( $self->members() )
1329 {
1330 $self->removeMember($member)
1331 unless $done{ $member->fileName() };
1332 }
1333 }
1334
1335 return AZ_OK;
1336 }
1337
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 );
1345
1346 BEGIN
1347 {
1348 use Archive::Zip qw( :CONSTANTS :MISC_CONSTANTS :ERROR_CODES
1349 :PKZIP_CONSTANTS :UTILITY_METHODS );
1350 }
1351
1352 use Time::Local();
1353 use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
1354 use File::Path;
1355 use File::Basename;
1356
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';
1361
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;
1367
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
1372 {
1373 my $class = shift;
1374 my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
1375 return $self;
1376 }
1377
1378 sub newFromString # Archive::Zip::Member
1379 {
1380 my $class = shift;
1381 my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
1382 return $self;
1383 }
1384
1385 sub newFromFile # Archive::Zip::Member
1386 {
1387 my $class = shift;
1388 my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
1389 return $self;
1390 }
1391
1392 sub newDirectoryNamed # Archive::Zip::Member
1393 {
1394 my $class = shift;
1395 my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
1396 return $self;
1397 }
1398
1399 sub new # Archive::Zip::Member
1400 {
1401 my $class = shift;
1402 my $self = {
1403 'lastModFileDateTime' => 0,
1404 'fileAttributeFormat' => FA_UNIX,
1405 'versionMadeBy' => 20,
1406 'versionNeededToExtract' => 20,
1407 'bitFlag' => 0,
1408 'compressionMethod' => COMPRESSION_STORED,
1409 'desiredCompressionMethod' => COMPRESSION_STORED,
1410 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
1411 'internalFileAttributes' => 0,
1412 'externalFileAttributes' => 0, # set later
1413 'fileName' => '',
1414 'cdExtraField' => '',
1415 'localExtraField' => '',
1416 'fileComment' => '',
1417 'crc32' => 0,
1418 'compressedSize' => 0,
1419 'uncompressedSize' => 0,
1420 @_
1421 };
1422 bless( $self, $class );
1423 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
1424 return $self;
1425 }
1426
1427 sub _becomeDirectoryIfNecessary # Archive::Zip::Member
1428 {
1429 my $self = shift;
1430 $self->_become(DIRECTORYMEMBERCLASS)
1431 if $self->isDirectory();
1432 return $self;
1433 }
1434
1435 # Morph into given class (do whatever cleanup I need to do)
1436 sub _become # Archive::Zip::Member
1437 {
1438 return bless( $_[0], $_[1] );
1439 }
1440
1441 sub versionMadeBy # Archive::Zip::Member
1442 {
1443 shift->{'versionMadeBy'};
1444 }
1445
1446 sub fileAttributeFormat # Archive::Zip::Member
1447 {
1448 ( $#_ > 0 )
1449 ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
1450 : $_[0]->{'fileAttributeFormat'};
1451 }
1452
1453 sub versionNeededToExtract # Archive::Zip::Member
1454 {
1455 shift->{'versionNeededToExtract'};
1456 }
1457
1458 sub bitFlag # Archive::Zip::Member
1459 {
1460 shift->{'bitFlag'};
1461 }
1462
1463 sub compressionMethod # Archive::Zip::Member
1464 {
1465 shift->{'compressionMethod'};
1466 }
1467
1468 sub desiredCompressionMethod # Archive::Zip::Member
1469 {
1470 my $self = shift;
1471 my $newDesiredCompressionMethod = shift;
1472 my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
1473 if ( defined($newDesiredCompressionMethod) )
1474 {
1475 $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
1476 if ( $newDesiredCompressionMethod == COMPRESSION_STORED )
1477 {
1478 $self->{'desiredCompressionLevel'} = 0;
1479 }
1480 elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED )
1481 {
1482 $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
1483 }
1484 }
1485 return $oldDesiredCompressionMethod;
1486 }
1487
1488 sub desiredCompressionLevel # Archive::Zip::Member
1489 {
1490 my $self = shift;
1491 my $newDesiredCompressionLevel = shift;
1492 my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
1493 if ( defined($newDesiredCompressionLevel) )
1494 {
1495 $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
1496 $self->{'desiredCompressionMethod'} =
1497 ( $newDesiredCompressionLevel
1498 ? COMPRESSION_DEFLATED
1499 : COMPRESSION_STORED );
1500 }
1501 return $oldDesiredCompressionLevel;
1502 }
1503
1504 sub fileName # Archive::Zip::Member
1505 {
1506 my $self = shift;
1507 my $newName = shift;
1508 if ($newName)
1509 {
1510 $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
1511 $self->{'fileName'} = $newName;
1512 }
1513 return $self->{'fileName'};
1514 }
1515
1516 sub lastModFileDateTime # Archive::Zip::Member
1517 {
1518 my $modTime = shift->{'lastModFileDateTime'};
1519 $modTime =~ m/^(\d+)$/; # untaint
1520 return $1;
1521 }
1522
1523 sub lastModTime # Archive::Zip::Member
1524 {
1525 my $self = shift;
1526 return _dosToUnixTime( $self->lastModFileDateTime() );
1527 }
1528
1529 sub setLastModFileDateTimeFromUnix # Archive::Zip::Member
1530 {
1531 my $self = shift;
1532 my $time_t = shift;
1533 $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
1534 }
1535
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)
1543
1544 # Convert DOS date/time format to unix time_t format
1545 # NOT AN OBJECT METHOD!
1546 sub _dosToUnixTime # Archive::Zip::Member
1547 {
1548 my $dt = shift;
1549 return time() unless defined($dt);
1550
1551 my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
1552 my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
1553 my $mday = ( ( $dt >> 16 ) & 0x1f );
1554
1555 my $hour = ( ( $dt >> 11 ) & 0x1f );
1556 my $min = ( ( $dt >> 5 ) & 0x3f );
1557 my $sec = ( ( $dt << 1 ) & 0x3e );
1558
1559 # catch errors
1560 my $time_t =
1561 eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
1562 return time() if ($@);
1563 return $time_t;
1564 }
1565
1566 sub internalFileAttributes # Archive::Zip::Member
1567 {
1568 shift->{'internalFileAttributes'};
1569 }
1570
1571 sub externalFileAttributes # Archive::Zip::Member
1572 {
1573 shift->{'externalFileAttributes'};
1574 }
1575
1576 # Convert UNIX permissions into proper value for zip file
1577 # NOT A METHOD!
1578 sub _mapPermissionsFromUnix # Archive::Zip::Member
1579 {
1580 my $perms = shift;
1581 return $perms << 16;
1582
1583 # TODO: map MS-DOS perms too (RHSA?)
1584 }
1585
1586 # Convert ZIP permissions into Unix ones
1587 #
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/
1591 #
1592 # See the mapattr() function in unix/unix.c
1593 # See the attribute format constants in unzpriv.h
1594 #
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
1598 {
1599 my $self = shift;
1600
1601 my $format = $self->{'fileAttributeFormat'};
1602 my $attribs = $self->{'externalFileAttributes'};
1603
1604 my $mode = 0;
1605
1606 if ( $format == FA_AMIGA )
1607 {
1608 $attribs = $attribs >> 17 & 7; # Amiga RWE bits
1609 $mode = $attribs << 6 | $attribs << 3 | $attribs;
1610 return $mode;
1611 }
1612
1613 if ( $format == FA_THEOS )
1614 {
1615 $attribs &= 0xF1FFFFFF;
1616 if ( ( $attribs & 0xF0000000 ) != 0x40000000 )
1617 {
1618 $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
1619 }
1620 else
1621 {
1622 $attribs &= 0x41FFFFFF; # leave directory bit as set
1623 }
1624 }
1625
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 )
1633 {
1634 $mode = $attribs >> 16;
1635 return $mode if $mode != 0 or not $self->localExtraField;
1636
1637 # warn("local extra field is: ", $self->localExtraField, "\n");
1638
1639 # XXX This condition is not implemented
1640 # I'm just including the comments from the info-zip section for now.
1641
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!)
1655 }
1656
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
1661 # bits (see below).
1662 if ( $format == FA_MSDOS )
1663 {
1664 $mode = $attribs >> 16;
1665 }
1666
1667 # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
1668 $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
1669
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;
1674 return $mode;
1675 }
1676
1677 sub unixFileAttributes # Archive::Zip::Member
1678 {
1679 my $self = shift;
1680 my $oldPerms = $self->_mapPermissionsToUnix();
1681 if (@_)
1682 {
1683 my $perms = shift;
1684 if ( $self->isDirectory() )
1685 {
1686 $perms &= ~FILE_ATTRIB;
1687 $perms |= DIRECTORY_ATTRIB;
1688 }
1689 else
1690 {
1691 $perms &= ~DIRECTORY_ATTRIB;
1692 $perms |= FILE_ATTRIB;
1693 }
1694 $self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
1695 }
1696 return $oldPerms;
1697 }
1698
1699 sub localExtraField # Archive::Zip::Member
1700 {
1701 ( $#_ > 0 )
1702 ? ( $_[0]->{'localExtraField'} = $_[1] )
1703 : $_[0]->{'localExtraField'};
1704 }
1705
1706 sub cdExtraField # Archive::Zip::Member
1707 {
1708 ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
1709 }
1710
1711 sub extraFields # Archive::Zip::Member
1712 {
1713 my $self = shift;
1714 return $self->localExtraField() . $self->cdExtraField();
1715 }
1716
1717 sub fileComment # Archive::Zip::Member
1718 {
1719 ( $#_ > 0 )
1720 ? ( $_[0]->{'fileComment'} = pack( 'C0a*', $_[1] ) )
1721 : $_[0]->{'fileComment'};
1722 }
1723
1724 sub hasDataDescriptor # Archive::Zip::Member
1725 {
1726 my $self = shift;
1727 if (@_)
1728 {
1729 my $shouldHave = shift;
1730 if ($shouldHave)
1731 {
1732 $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
1733 }
1734 else
1735 {
1736 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
1737 }
1738 }
1739 return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
1740 }
1741
1742 sub crc32 # Archive::Zip::Member
1743 {
1744 shift->{'crc32'};
1745 }
1746
1747 sub crc32String # Archive::Zip::Member
1748 {
1749 sprintf( "%08x", shift->{'crc32'} );
1750 }
1751
1752 sub compressedSize # Archive::Zip::Member
1753 {
1754 shift->{'compressedSize'};
1755 }
1756
1757 sub uncompressedSize # Archive::Zip::Member
1758 {
1759 shift->{'uncompressedSize'};
1760 }
1761
1762 sub isEncrypted # Archive::Zip::Member
1763 {
1764 shift->bitFlag() & GPBF_ENCRYPTED_MASK;
1765 }
1766
1767 sub isTextFile # Archive::Zip::Member
1768 {
1769 my $self = shift;
1770 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
1771 if (@_)
1772 {
1773 my $flag = shift;
1774 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
1775 $self->{'internalFileAttributes'} |=
1776 ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
1777 }
1778 return $bit == IFA_TEXT_FILE;
1779 }
1780
1781 sub isBinaryFile # Archive::Zip::Member
1782 {
1783 my $self = shift;
1784 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
1785 if (@_)
1786 {
1787 my $flag = shift;
1788 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
1789 $self->{'internalFileAttributes'} |=
1790 ( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
1791 }
1792 return $bit == IFA_BINARY_FILE;
1793 }
1794
1795 sub extractToFileNamed # Archive::Zip::Member
1796 {
1797 my $self = shift;
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);
1804 $fh->close();
1805 utime( $self->lastModTime(), $self->lastModTime(), $name );
1806 return $retval;
1807 }
1808
1809 sub isDirectory # Archive::Zip::Member
1810 {
1811 return 0;
1812 }
1813
1814 sub externalFileName # Archive::Zip::Member
1815 {
1816 return undef;
1817 }
1818
1819 # The following are used when copying data
1820 sub _writeOffset # Archive::Zip::Member
1821 {
1822 shift->{'writeOffset'};
1823 }
1824
1825 sub _readOffset # Archive::Zip::Member
1826 {
1827 shift->{'readOffset'};
1828 }
1829
1830 sub writeLocalHeaderRelativeOffset # Archive::Zip::Member
1831 {
1832 shift->{'writeLocalHeaderRelativeOffset'};
1833 }
1834
1835 sub wasWritten { shift->{'wasWritten'} }
1836
1837 sub _dataEnded # Archive::Zip::Member
1838 {
1839 shift->{'dataEnded'};
1840 }
1841
1842 sub _readDataRemaining # Archive::Zip::Member
1843 {
1844 shift->{'readDataRemaining'};
1845 }
1846
1847 sub _inflater # Archive::Zip::Member
1848 {
1849 shift->{'inflater'};
1850 }
1851
1852 sub _deflater # Archive::Zip::Member
1853 {
1854 shift->{'deflater'};
1855 }
1856
1857 # Return the total size of my local header
1858 sub _localHeaderSize # Archive::Zip::Member
1859 {
1860 my $self = shift;
1861 return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
1862 length( $self->fileName() ) + length( $self->localExtraField() );
1863 }
1864
1865 # Return the total size of my CD header
1866 sub _centralDirectoryHeaderSize # Archive::Zip::Member
1867 {
1868 my $self = shift;
1869 return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
1870 length( $self->fileName() ) + length( $self->cdExtraField() ) +
1871 length( $self->fileComment() );
1872 }
1873
1874 # convert a unix time to DOS date/time
1875 # NOT AN OBJECT METHOD!
1876 sub _unixToDosTime # Archive::Zip::Member
1877 {
1878 my $time_t = shift;
1879 my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
1880 my $dt = 0;
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 );
1887 return $dt;
1888 }
1889
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
1895 {
1896 my $self = shift;
1897 my $fh = shift;
1898
1899 my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
1900 $fh->print($signatureData)
1901 or return _ioError("writing local header signature");
1902
1903 my $header = pack(
1904 LOCAL_FILE_HEADER_FORMAT,
1905 $self->versionNeededToExtract(),
1906 $self->bitFlag(),
1907 $self->desiredCompressionMethod(),
1908 $self->lastModFileDateTime(),
1909 $self->crc32(),
1910 $self->compressedSize(), # may need to be re-written later
1911 $self->uncompressedSize(),
1912 length( $self->fileName() ),
1913 length( $self->localExtraField() )
1914 );
1915
1916 $fh->print($header) or return _ioError("writing local header");
1917 if ( $self->fileName() )
1918 {
1919 $fh->print( $self->fileName() )
1920 or return _ioError("writing local header filename");
1921 }
1922 if ( $self->localExtraField() )
1923 {
1924 $fh->print( $self->localExtraField() )
1925 or return _ioError("writing local extra field");
1926 }
1927
1928 return AZ_OK;
1929 }
1930
1931 sub _writeCentralDirectoryFileHeader # Archive::Zip::Member
1932 {
1933 my $self = shift;
1934 my $fh = shift;
1935
1936 my $sigData =
1937 pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
1938 $fh->print($sigData)
1939 or return _ioError("writing central directory header signature");
1940
1941 my $fileNameLength = length( $self->fileName() );
1942 my $extraFieldLength = length( $self->cdExtraField() );
1943 my $fileCommentLength = length( $self->fileComment() );
1944
1945 my $header = pack(
1946 CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
1947 $self->versionMadeBy(),
1948 $self->fileAttributeFormat(),
1949 $self->versionNeededToExtract(),
1950 $self->bitFlag(),
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(), #
1956 $fileNameLength,
1957 $extraFieldLength,
1958 $fileCommentLength,
1959 0, # {'diskNumberStart'},
1960 $self->internalFileAttributes(),
1961 $self->externalFileAttributes(),
1962 $self->writeLocalHeaderRelativeOffset()
1963 );
1964
1965 $fh->print($header)
1966 or return _ioError("writing central directory header");
1967 if ($fileNameLength)
1968 {
1969 $fh->print( $self->fileName() )
1970 or return _ioError("writing central directory header signature");
1971 }
1972 if ($extraFieldLength)
1973 {
1974 $fh->print( $self->cdExtraField() )
1975 or return _ioError("writing central directory extra field");
1976 }
1977 if ($fileCommentLength)
1978 {
1979 $fh->print( $self->fileComment() )
1980 or return _ioError("writing central directory file comment");
1981 }
1982
1983 return AZ_OK;
1984 }
1985
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
1992 {
1993 my $self = shift;
1994 my $fh = shift;
1995 my $header = pack(
1996 SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
1997 DATA_DESCRIPTOR_SIGNATURE,
1998 $self->crc32(),
1999 $self->_writeOffset(), # compressed size
2000 $self->uncompressedSize()
2001 );
2002
2003 $fh->print($header)
2004 or return _ioError("writing data descriptor");
2005 return AZ_OK;
2006 }
2007
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
2012 {
2013 my $self = shift;
2014 my $fh = shift;
2015
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");
2020
2021 my $header = pack(
2022 LOCAL_FILE_HEADER_FORMAT,
2023 $self->versionNeededToExtract(),
2024 $self->bitFlag(),
2025 $self->desiredCompressionMethod(),
2026 $self->lastModFileDateTime(),
2027 $self->crc32(),
2028 $self->_writeOffset(), # compressed size
2029 $self->uncompressedSize(),
2030 length( $self->fileName() ),
2031 length( $self->localExtraField() )
2032 );
2033
2034 $fh->print($header)
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");
2038
2039 return AZ_OK;
2040 }
2041
2042 sub readChunk # Archive::Zip::Member
2043 {
2044 my ( $self, $chunkSize ) = @_;
2045
2046 if ( $self->readIsDone() )
2047 {
2048 $self->endRead();
2049 my $dummy = '';
2050 return ( \$dummy, AZ_STREAM_END );
2051 }
2052
2053 $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
2054 $chunkSize = $self->_readDataRemaining()
2055 if $chunkSize > $self->_readDataRemaining();
2056
2057 my $buffer = '';
2058 my $outputRef;
2059 my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
2060 return ( \$buffer, $status ) unless $status == AZ_OK;
2061
2062 $self->{'readDataRemaining'} -= $bytesRead;
2063 $self->{'readOffset'} += $bytesRead;
2064
2065 if ( $self->compressionMethod() == COMPRESSION_STORED )
2066 {
2067 $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
2068 }
2069
2070 ( $outputRef, $status ) = &{ $self->{'chunkHandler'} } ( $self, \$buffer );
2071 $self->{'writeOffset'} += length($$outputRef);
2072
2073 $self->endRead()
2074 if $self->readIsDone();
2075
2076 return ( $outputRef, $status );
2077 }
2078
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
2082 {
2083 my $self = shift;
2084 return $self->_subclassResponsibility();
2085 }
2086
2087 # A place holder to catch rewindData errors if someone ignores
2088 # the error code.
2089 sub _noChunk # Archive::Zip::Member
2090 {
2091 my $self = shift;
2092 return ( \undef, _error("trying to copy chunk when init failed") );
2093 }
2094
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
2098 {
2099 my ( $self, $dataRef ) = @_;
2100 return ( $dataRef, AZ_OK );
2101 }
2102
2103 # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
2104 sub _deflateChunk # Archive::Zip::Member
2105 {
2106 my ( $self, $buffer ) = @_;
2107 my ( $out, $status ) = $self->_deflater()->deflate($buffer);
2108
2109 if ( $self->_readDataRemaining() == 0 )
2110 {
2111 my $extraOutput;
2112 ( $extraOutput, $status ) = $self->_deflater()->flush();
2113 $out .= $extraOutput;
2114 $self->endRead();
2115 return ( \$out, AZ_STREAM_END );
2116 }
2117 elsif ( $status == Z_OK )
2118 {
2119 return ( \$out, AZ_OK );
2120 }
2121 else
2122 {
2123 $self->endRead();
2124 my $retval = _error( 'deflate error', $status );
2125 my $dummy = '';
2126 return ( \$dummy, $retval );
2127 }
2128 }
2129
2130 # ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
2131 sub _inflateChunk # Archive::Zip::Member
2132 {
2133 my ( $self, $buffer ) = @_;
2134 my ( $out, $status ) = $self->_inflater()->inflate($buffer);
2135 my $retval;
2136 $self->endRead() unless $status == Z_OK;
2137 if ( $status == Z_OK || $status == Z_STREAM_END )
2138 {
2139 $retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
2140 return ( \$out, $retval );
2141 }
2142 else
2143 {
2144 $retval = _error( 'inflate error', $status );
2145 my $dummy = '';
2146 return ( \$dummy, $retval );
2147 }
2148 }
2149
2150 sub rewindData # Archive::Zip::Member
2151 {
2152 my $self = shift;
2153 my $status;
2154
2155 # set to trap init errors
2156 $self->{'chunkHandler'} = $self->can('_noChunk');
2157
2158 # Work around WinZip bug with 0-length DEFLATED files
2159 $self->desiredCompressionMethod(COMPRESSION_STORED)
2160 if $self->uncompressedSize() == 0;
2161
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 );
2165
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 )
2169 {
2170 ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
2171 '-Level' => $self->desiredCompressionLevel(),
2172 '-WindowBits' => -MAX_WBITS(), # necessary magic
2173 '-Bufsize' => $Archive::Zip::ChunkSize,
2174 @_
2175 ); # pass additional options
2176 return _error( 'deflateInit error:', $status )
2177 unless $status == Z_OK;
2178 $self->{'chunkHandler'} = $self->can('_deflateChunk');
2179 }
2180 elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
2181 and $self->desiredCompressionMethod() == COMPRESSION_STORED )
2182 {
2183 ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
2184 '-WindowBits' => -MAX_WBITS(), # necessary magic
2185 '-Bufsize' => $Archive::Zip::ChunkSize,
2186 @_
2187 ); # pass additional options
2188 return _error( 'inflateInit error:', $status )
2189 unless $status == Z_OK;
2190 $self->{'chunkHandler'} = $self->can('_inflateChunk');
2191 }
2192 elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() )
2193 {
2194 $self->{'chunkHandler'} = $self->can('_copyChunk');
2195 }
2196 else
2197 {
2198 return _error(
2199 sprintf(
2200 "Unsupported compression combination: read %d, write %d",
2201 $self->compressionMethod(),
2202 $self->desiredCompressionMethod()
2203 )
2204 );
2205 }
2206
2207 $self->{'readDataRemaining'} =
2208 ( $self->compressionMethod() == COMPRESSION_STORED )
2209 ? $self->uncompressedSize()
2210 : $self->compressedSize();
2211 $self->{'dataEnded'} = 0;
2212 $self->{'readOffset'} = 0;
2213
2214 return AZ_OK;
2215 }
2216
2217 sub endRead # Archive::Zip::Member
2218 {
2219 my $self = shift;
2220 delete $self->{'inflater'};
2221 delete $self->{'deflater'};
2222 $self->{'dataEnded'} = 1;
2223 $self->{'readDataRemaining'} = 0;
2224 return AZ_OK;
2225 }
2226
2227 sub readIsDone # Archive::Zip::Member
2228 {
2229 my $self = shift;
2230 return ( $self->_dataEnded() or !$self->_readDataRemaining() );
2231 }
2232
2233 sub contents # Archive::Zip::Member
2234 {
2235 my $self = shift;
2236 my $newContents = shift;
2237
2238 if ( defined($newContents) )
2239 {
2240
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
2245 }
2246 else
2247 {
2248 my $oldCompression =
2249 $self->desiredCompressionMethod(COMPRESSION_STORED);
2250 my $status = $self->rewindData(@_);
2251 if ( $status != AZ_OK )
2252 {
2253 $self->endRead();
2254 return $status;
2255 }
2256 my $retval = '';
2257 while ( $status == AZ_OK )
2258 {
2259 my $ref;
2260 ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
2261
2262 # did we get it in one chunk?
2263 if ( length($$ref) == $self->uncompressedSize() )
2264 {
2265 $retval = $$ref;
2266 }
2267 else { $retval .= $$ref }
2268 }
2269 $self->desiredCompressionMethod($oldCompression);
2270 $self->endRead();
2271 $status = AZ_OK if $status == AZ_STREAM_END;
2272 $retval = undef unless $status == AZ_OK;
2273 return wantarray ? ( $retval, $status ) : $retval;
2274 }
2275 }
2276
2277 sub extractToFileHandle # Archive::Zip::Member
2278 {
2279 my $self = shift;
2280 return _error("encryption unsupported") if $self->isEncrypted();
2281 my $fh = shift;
2282 _binmode($fh);
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);
2287 $self->endRead();
2288 return $status;
2289 }
2290
2291 # write local header and data stream to file handle
2292 sub _writeToFileHandle # Archive::Zip::Member
2293 {
2294 my $self = shift;
2295 my $fh = shift;
2296 my $fhIsSeekable = shift;
2297 my $offset = shift;
2298
2299 return _error("no member name given for $self")
2300 unless $self->fileName();
2301
2302 $self->{'writeLocalHeaderRelativeOffset'} = $offset;
2303 $self->{'wasWritten'} = 0;
2304
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 ) );
2312
2313 my $shouldWriteDataDescriptor =
2314 ( $headerFieldsUnknown and not $fhIsSeekable );
2315
2316 $self->hasDataDescriptor(1)
2317 if ($shouldWriteDataDescriptor);
2318
2319 $self->{'writeOffset'} = 0;
2320
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 )
2327 {
2328 $self->{'wasWritten'} = 1;
2329 if ( $self->hasDataDescriptor() )
2330 {
2331 $status = $self->_writeDataDescriptor($fh);
2332 }
2333 elsif ($headerFieldsUnknown)
2334 {
2335 $status = $self->_refreshLocalFileHeader($fh);
2336 }
2337 }
2338
2339 return $status;
2340 }
2341
2342 # Copy my (possibly compressed) data to given file handle.
2343 # Returns C<AZ_OK> on success
2344 sub _writeData # Archive::Zip::Member
2345 {
2346 my $self = shift;
2347 my $writeFh = shift;
2348
2349 return AZ_OK if ( $self->uncompressedSize() == 0 );
2350 my $status;
2351 my $chunkSize = $Archive::Zip::ChunkSize;
2352 while ( $self->_readDataRemaining() > 0 )
2353 {
2354 my $outRef;
2355 ( $outRef, $status ) = $self->readChunk($chunkSize);
2356 return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
2357
2358 if ( length($$outRef) > 0 )
2359 {
2360 $writeFh->print($$outRef)
2361 or return _ioError("write error during copy");
2362 }
2363
2364 last if $status == AZ_STREAM_END;
2365 }
2366 $self->{'compressedSize'} = $self->_writeOffset();
2367 return AZ_OK;
2368 }
2369
2370 # Return true if I depend on the named file
2371 sub _usesFileNamed
2372 {
2373 return 0;
2374 }
2375
2376 # ----------------------------------------------------------------------
2377 # class Archive::Zip::DirectoryMember
2378 # ----------------------------------------------------------------------
2379
2380 package Archive::Zip::DirectoryMember;
2381 use File::Path;
2382
2383 use vars qw( @ISA );
2384 @ISA = qw ( Archive::Zip::Member );
2385 BEGIN { use Archive::Zip qw( :ERROR_CODES :UTILITY_METHODS ) }
2386
2387 sub _newNamed # Archive::Zip::DirectoryMember
2388 {
2389 my $class = shift;
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);
2396 if ( -e $fileName )
2397 {
2398
2399 if ( -d _ )
2400 {
2401 my @stat = stat(_);
2402 $self->unixFileAttributes( $stat[2] );
2403 $self->setLastModFileDateTimeFromUnix( $stat[9] );
2404 }
2405 else # hmm.. trying to add a non-directory?
2406 {
2407 _error( $fileName, ' exists but is not a directory' );
2408 return undef;
2409 }
2410 }
2411 else
2412 {
2413 $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
2414 $self->setLastModFileDateTimeFromUnix( time() );
2415 }
2416 return $self;
2417 }
2418
2419 sub externalFileName # Archive::Zip::DirectoryMember
2420 {
2421 shift->{'externalFileName'};
2422 }
2423
2424 sub isDirectory # Archive::Zip::DirectoryMember
2425 {
2426 return 1;
2427 }
2428
2429 sub extractToFileNamed # Archive::Zip::DirectoryMember
2430 {
2431 my $self = shift;
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 );
2436 return AZ_OK;
2437 }
2438
2439 sub fileName # Archive::Zip::DirectoryMember
2440 {
2441 my $self = shift;
2442 my $newName = shift;
2443 $newName =~ s{/?$}{/} if defined($newName);
2444 return $self->SUPER::fileName($newName);
2445 }
2446
2447 # So people don't get too confused. This way it looks like the problem
2448 # is in their code...
2449 sub contents
2450 {
2451 return wantarray ? ( undef, AZ_OK ) : undef;
2452 }
2453
2454 # ----------------------------------------------------------------------
2455 # class Archive::Zip::FileMember
2456 # Base class for classes that have file handles
2457 # to external files
2458 # ----------------------------------------------------------------------
2459
2460 package Archive::Zip::FileMember;
2461 use vars qw( @ISA );
2462 @ISA = qw ( Archive::Zip::Member );
2463 BEGIN { use Archive::Zip qw( :UTILITY_METHODS ) }
2464
2465 sub externalFileName # Archive::Zip::FileMember
2466 {
2467 shift->{'externalFileName'};
2468 }
2469
2470 # Return true if I depend on the named file
2471 sub _usesFileNamed # Archive::Zip::FileMember
2472 {
2473 my $self = shift;
2474 my $fileName = shift;
2475 my $xfn = $self->externalFileName();
2476 return undef if ref($xfn);
2477 return $xfn eq $fileName;
2478 }
2479
2480 sub fh # Archive::Zip::FileMember
2481 {
2482 my $self = shift;
2483 $self->_openFile()
2484 if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened();
2485 return $self->{'fh'};
2486 }
2487
2488 # opens my file handle from my file name
2489 sub _openFile # Archive::Zip::FileMember
2490 {
2491 my $self = shift;
2492 my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
2493 if ( !$status )
2494 {
2495 _ioError( "Can't open", $self->externalFileName() );
2496 return undef;
2497 }
2498 $self->{'fh'} = $fh;
2499 _binmode($fh);
2500 return $fh;
2501 }
2502
2503 # Make sure I close my file handle
2504 sub endRead # Archive::Zip::FileMember
2505 {
2506 my $self = shift;
2507 undef $self->{'fh'}; # _closeFile();
2508 return $self->SUPER::endRead(@_);
2509 }
2510
2511 sub _become # Archive::Zip::FileMember
2512 {
2513 my $self = shift;
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);
2519 }
2520
2521 # ----------------------------------------------------------------------
2522 # class Archive::Zip::NewFileMember
2523 # Used when adding a pre-existing file to an archive
2524 # ----------------------------------------------------------------------
2525
2526 package Archive::Zip::NewFileMember;
2527 use vars qw( @ISA );
2528 @ISA = qw ( Archive::Zip::FileMember );
2529
2530 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :UTILITY_METHODS ) }
2531
2532 # Given a file name, set up for eventual writing.
2533 sub _newFromFileNamed # Archive::Zip::NewFileMember
2534 {
2535 my $class = shift;
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;
2544 my @stat = stat(_);
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 _ );
2552 return $self;
2553 }
2554
2555 sub rewindData # Archive::Zip::NewFileMember
2556 {
2557 my $self = shift;
2558
2559 my $status = $self->SUPER::rewindData(@_);
2560 return $status unless $status == AZ_OK;
2561
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() );
2566 return AZ_OK;
2567 }
2568
2569 # Return bytes read. Note that first parameter is a ref to a buffer.
2570 # my $data;
2571 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
2572 sub _readRawChunk # Archive::Zip::NewFileMember
2573 {
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 );
2579 }
2580
2581 # If I already exist, extraction is a no-op.
2582 sub extractToFileNamed # Archive::Zip::NewFileMember
2583 {
2584 my $self = shift;
2585 my $name = shift; # local FS name
2586 if ( File::Spec->rel2abs($name) eq
2587 File::Spec->rel2abs( $self->externalFileName() ) and -r $name )
2588 {
2589 return AZ_OK;
2590 }
2591 else
2592 {
2593 return $self->SUPER::extractToFileNamed( $name, @_ );
2594 }
2595 }
2596
2597 # ----------------------------------------------------------------------
2598 # class Archive::Zip::ZipFileMember
2599 # This represents a member in an existing zip file on disk.
2600 # ----------------------------------------------------------------------
2601
2602 package Archive::Zip::ZipFileMember;
2603 use vars qw( @ISA );
2604 @ISA = qw ( Archive::Zip::FileMember );
2605
2606 BEGIN
2607 {
2608 use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
2609 :UTILITY_METHODS );
2610 }
2611
2612 # Create a new Archive::Zip::ZipFileMember
2613 # given a filename and optional open file handle
2614 #
2615 sub _newFromZipFile # Archive::Zip::ZipFileMember
2616 {
2617 my $class = shift;
2618 my $fh = shift;
2619 my $externalFileName = shift;
2620 my $possibleEocdOffset = shift; # normally 0
2621
2622 my $self = $class->new(
2623 'crc32' => 0,
2624 'diskNumberStart' => 0,
2625 'localHeaderRelativeOffset' => 0,
2626 'dataOffset' => 0, # localHeaderRelativeOffset + header length
2627 @_
2628 );
2629 $self->{'externalFileName'} = $externalFileName;
2630 $self->{'fh'} = $fh;
2631 $self->{'possibleEocdOffset'} = $possibleEocdOffset;
2632 return $self;
2633 }
2634
2635 sub isDirectory # Archive::Zip::ZipFileMember
2636 {
2637 my $self = shift;
2638 return ( substr( $self->fileName(), -1, 1 ) eq '/'
2639 and $self->uncompressedSize() == 0 );
2640 }
2641
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.
2645 # Returns status.
2646
2647 sub _seekToLocalHeader # Archive::Zip::ZipFileMember
2648 {
2649 my $self = shift;
2650 my $where = shift; # optional
2651 my $previousWhere = shift; # optional
2652
2653 $where = $self->localHeaderRelativeOffset() unless defined($where);
2654
2655 # avoid loop on certain corrupt files (from Julian Field)
2656 return _formatError("corrupt zip file")
2657 if defined($previousWhere) && $where == $previousWhere;
2658
2659 my $status;
2660 my $signature;
2661
2662 $status = $self->fh()->seek( $where, IO::Seekable::SEEK_SET );
2663 return _ioError("seeking to local header") unless $status;
2664
2665 ( $status, $signature ) =
2666 _readSignature( $self->fh(), $self->externalFileName(),
2667 LOCAL_FILE_HEADER_SIGNATURE );
2668 return $status if $status == AZ_IO_ERROR;
2669
2670 # retry with EOCD offset if any was given.
2671 if ( $status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'} )
2672 {
2673 $status =
2674 $self->_seekToLocalHeader(
2675 $self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'},
2676 $where );
2677 if ( $status == AZ_OK )
2678 {
2679 $self->{'localHeaderRelativeOffset'} +=
2680 $self->{'possibleEocdOffset'};
2681 $self->{'possibleEocdOffset'} = 0;
2682 }
2683 }
2684
2685 return $status;
2686 }
2687
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 )
2692
2693 sub _become # Archive::Zip::ZipFileMember
2694 {
2695 my $self = shift;
2696 my $newClass = shift;
2697 return $self if ref($self) eq $newClass;
2698
2699 my $status = AZ_OK;
2700
2701 if ( _isSeekable( $self->fh() ) )
2702 {
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;
2708 }
2709
2710 delete( $self->{'eocdCrc32'} );
2711 delete( $self->{'diskNumberStart'} );
2712 delete( $self->{'localHeaderRelativeOffset'} );
2713 delete( $self->{'dataOffset'} );
2714
2715 return $self->SUPER::_become($newClass);
2716 }
2717
2718 sub diskNumberStart # Archive::Zip::ZipFileMember
2719 {
2720 shift->{'diskNumberStart'};
2721 }
2722
2723 sub localHeaderRelativeOffset # Archive::Zip::ZipFileMember
2724 {
2725 shift->{'localHeaderRelativeOffset'};
2726 }
2727
2728 sub dataOffset # Archive::Zip::ZipFileMember
2729 {
2730 shift->{'dataOffset'};
2731 }
2732
2733 # Skip local file header, updating only extra field stuff.
2734 # Assumes that fh is positioned before signature.
2735 sub _skipLocalFileHeader # Archive::Zip::ZipFileMember
2736 {
2737 my $self = shift;
2738 my $header;
2739 my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
2740 if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
2741 {
2742 return _ioError("reading local file header");
2743 }
2744 my $fileNameLength;
2745 my $extraFieldLength;
2746 my $bitFlag;
2747 ( undef, # $self->{'versionNeededToExtract'},
2748 $bitFlag,
2749 undef, # $self->{'compressionMethod'},
2750 undef, # $self->{'lastModFileDateTime'},
2751 undef, # $crc32,
2752 undef, # $compressedSize,
2753 undef, # $uncompressedSize,
2754 $fileNameLength,
2755 $extraFieldLength )
2756 = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
2757
2758 if ($fileNameLength)
2759 {
2760 $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
2761 or return _ioError("skipping local file name");
2762 }
2763
2764 if ($extraFieldLength)
2765 {
2766 $bytesRead =
2767 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
2768 if ( $bytesRead != $extraFieldLength )
2769 {
2770 return _ioError("reading local extra field");
2771 }
2772 }
2773
2774 $self->{'dataOffset'} = $self->fh()->tell();
2775
2776 if ( $bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK )
2777 {
2778
2779 # Read the crc32, compressedSize, and uncompressedSize from the
2780 # extended data descriptor, which directly follows the compressed data.
2781 #
2782 # Skip over the compressed file data (assumes that EOCD compressedSize
2783 # was correct)
2784 $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
2785 or return _ioError("seeking to extended local header");
2786
2787 # these values should be set correctly from before.
2788 my $oldCrc32 = $self->{'eocdCrc32'};
2789 my $oldCompressedSize = $self->{'compressedSize'};
2790 my $oldUncompressedSize = $self->{'uncompressedSize'};
2791
2792 my $status = $self->_readDataDescriptor();
2793 return $status unless $status == AZ_OK;
2794
2795 return _formatError(
2796 "CRC or size mismatch while skipping data descriptor")
2797 if ( $oldCrc32 != $self->{'crc32'}
2798 || $oldUncompressedSize != $self->{'uncompressedSize'} );
2799 }
2800
2801 return AZ_OK;
2802 }
2803
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.
2808
2809 sub _readLocalFileHeader # Archive::Zip::ZipFileMember
2810 {
2811 my $self = shift;
2812 my $header;
2813 my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
2814 if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH )
2815 {
2816 return _ioError("reading local file header");
2817 }
2818 my $fileNameLength;
2819 my $crc32;
2820 my $compressedSize;
2821 my $uncompressedSize;
2822 my $extraFieldLength;
2823 ( $self->{'versionNeededToExtract'}, $self->{'bitFlag'},
2824 $self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
2825 $crc32, $compressedSize,
2826 $uncompressedSize, $fileNameLength,
2827 $extraFieldLength )
2828 = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
2829
2830 if ($fileNameLength)
2831 {
2832 my $fileName;
2833 $bytesRead = $self->fh()->read( $fileName, $fileNameLength );
2834 if ( $bytesRead != $fileNameLength )
2835 {
2836 return _ioError("reading local file name");
2837 }
2838 $self->fileName($fileName);
2839 }
2840
2841 if ($extraFieldLength)
2842 {
2843 $bytesRead =
2844 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
2845 if ( $bytesRead != $extraFieldLength )
2846 {
2847 return _ioError("reading local extra field");
2848 }
2849 }
2850
2851 $self->{'dataOffset'} = $self->fh()->tell();
2852
2853 if ( $self->hasDataDescriptor() )
2854 {
2855
2856 # Read the crc32, compressedSize, and uncompressedSize from the
2857 # extended data descriptor.
2858 # Skip over the compressed file data (assumes that EOCD compressedSize
2859 # was correct)
2860 $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
2861 or return _ioError("seeking to extended local header");
2862
2863 my $status = $self->_readDataDescriptor();
2864 return $status unless $status == AZ_OK;
2865 }
2866 else
2867 {
2868 return _formatError(
2869 "CRC or size mismatch after reading data descriptor")
2870 if ( $self->{'crc32'} != $crc32
2871 || $self->{'uncompressedSize'} != $uncompressedSize );
2872 }
2873
2874 return AZ_OK;
2875 }
2876
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
2879 # bitFlag.
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
2884 {
2885 my $self = shift;
2886 my $signatureData;
2887 my $header;
2888 my $crc32;
2889 my $compressedSize;
2890 my $uncompressedSize;
2891
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 );
2896
2897 # unfortunately, the signature appears to be optional.
2898 if ( $signature == DATA_DESCRIPTOR_SIGNATURE
2899 && ( $signature != $self->{'crc32'} ) )
2900 {
2901 $bytesRead = $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH );
2902 return _ioError("reading data descriptor")
2903 if $bytesRead != DATA_DESCRIPTOR_LENGTH;
2904
2905 ( $crc32, $compressedSize, $uncompressedSize ) =
2906 unpack( DATA_DESCRIPTOR_FORMAT, $header );
2907 }
2908 else
2909 {
2910 $bytesRead =
2911 $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH_NO_SIG );
2912 return _ioError("reading data descriptor")
2913 if $bytesRead != DATA_DESCRIPTOR_LENGTH_NO_SIG;
2914
2915 $crc32 = $signature;
2916 ( $compressedSize, $uncompressedSize ) =
2917 unpack( DATA_DESCRIPTOR_FORMAT_NO_SIG, $header );
2918 }
2919
2920 $self->{'eocdCrc32'} = $self->{'crc32'}
2921 unless defined( $self->{'eocdCrc32'} );
2922 $self->{'crc32'} = $crc32;
2923 $self->{'compressedSize'} = $compressedSize;
2924 $self->{'uncompressedSize'} = $uncompressedSize;
2925
2926 return AZ_OK;
2927 }
2928
2929 # Read a Central Directory header. Return AZ_OK on success.
2930 # Assumes that fh is positioned right after the signature.
2931
2932 sub _readCentralDirectoryFileHeader # Archive::Zip::ZipFileMember
2933 {
2934 my $self = shift;
2935 my $fh = $self->fh();
2936 my $header = '';
2937 my $bytesRead = $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH );
2938 if ( $bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH )
2939 {
2940 return _ioError("reading central dir header");
2941 }
2942 my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
2943 (
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'}
2952 )
2953 = unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
2954
2955 $self->{'eocdCrc32'} = $self->{'crc32'};
2956
2957 if ($fileNameLength)
2958 {
2959 $bytesRead = $fh->read( $self->{'fileName'}, $fileNameLength );
2960 if ( $bytesRead != $fileNameLength )
2961 {
2962 _ioError("reading central dir filename");
2963 }
2964 }
2965 if ($extraFieldLength)
2966 {
2967 $bytesRead = $fh->read( $self->{'cdExtraField'}, $extraFieldLength );
2968 if ( $bytesRead != $extraFieldLength )
2969 {
2970 return _ioError("reading central dir extra field");
2971 }
2972 }
2973 if ($fileCommentLength)
2974 {
2975 $bytesRead = $fh->read( $self->{'fileComment'}, $fileCommentLength );
2976 if ( $bytesRead != $fileCommentLength )
2977 {
2978 return _ioError("reading central dir file comment");
2979 }
2980 }
2981
2982 # NK 10/21/04: added to avoid problems with manipulated headers
2983 if ( $self->{'uncompressedSize'} != $self->{'compressedSize'}
2984 and $self->{'compressionMethod'} == COMPRESSION_STORED )
2985 {
2986 $self->{'uncompressedSize'} = $self->{'compressedSize'};
2987 }
2988
2989 $self->desiredCompressionMethod( $self->compressionMethod() );
2990
2991 return AZ_OK;
2992 }
2993
2994 sub rewindData # Archive::Zip::ZipFileMember
2995 {
2996 my $self = shift;
2997
2998 my $status = $self->SUPER::rewindData(@_);
2999 return $status unless $status == AZ_OK;
3000
3001 return AZ_IO_ERROR unless $self->fh();
3002
3003 $self->fh()->clearerr();
3004
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;
3010
3011 # skip local file header
3012 $status = $self->_skipLocalFileHeader();
3013 return $status unless $status == AZ_OK;
3014
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");
3018
3019 return AZ_OK;
3020 }
3021
3022 # Return bytes read. Note that first parameter is a ref to a buffer.
3023 # my $data;
3024 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
3025 sub _readRawChunk # Archive::Zip::ZipFileMember
3026 {
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 );
3032 }
3033
3034 # ----------------------------------------------------------------------
3035 # class Archive::Zip::StringMember ( concrete )
3036 # A Zip member whose data lives in a string
3037 # ----------------------------------------------------------------------
3038
3039 package Archive::Zip::StringMember;
3040 use vars qw( @ISA );
3041 @ISA = qw ( Archive::Zip::Member );
3042
3043 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES ) }
3044
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
3048 {
3049 my $class = shift;
3050 my $string = shift;
3051 my $name = shift;
3052 my $self = $class->new(@_);
3053 $self->contents($string);
3054 $self->fileName($name) if defined($name);
3055
3056 # Set the file date to now
3057 $self->setLastModFileDateTimeFromUnix( time() );
3058 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
3059 return $self;
3060 }
3061
3062 sub _become # Archive::Zip::StringMember
3063 {
3064 my $self = shift;
3065 my $newClass = shift;
3066 return $self if ref($self) eq $newClass;
3067 delete( $self->{'contents'} );
3068 return $self->SUPER::_become($newClass);
3069 }
3070
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
3074 {
3075 my $self = shift;
3076 my $string = shift;
3077 if ( defined($string) )
3078 {
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;
3084 }
3085 return $self->{'contents'};
3086 }
3087
3088 # Return bytes read. Note that first parameter is a ref to a buffer.
3089 # my $data;
3090 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
3091 sub _readRawChunk # Archive::Zip::StringMember
3092 {
3093 my ( $self, $dataRef, $chunkSize ) = @_;
3094 $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
3095 return ( length($$dataRef), AZ_OK );
3096 }
3097
3098 1;
3099 __END__
3100
3101
3102 # vim: ts=4 sw=4 tw=80 wrap
Provide an interface to ZIP archive files