File Coverage

blib/lib/Archive/Zip/Member.pm
Criterion Covered Total %
statement 590 661 89.2
branch 230 326 70.5
condition 69 109 63.3
subroutine 87 92 94.5
pod 44 47 93.6
total 1020 1235 82.5


line stmt bran cond sub pod time code
1             package Archive::Zip::Member;
2              
3             # A generic member of an archive
4              
5 28     28   176 use strict;
  28         64  
  28         845  
6 28     28   133 use vars qw( $VERSION @ISA );
  28         48  
  28         2158  
7              
8             BEGIN {
9 28     28   94 $VERSION = '1.67';
10 28         426 @ISA = qw( Archive::Zip );
11              
12 28 50       911 if ($^O eq 'MSWin32') {
13 0         0 require Win32;
14 0         0 require Encode;
15 0         0 Encode->import(qw{ decode_utf8 });
16             }
17             }
18              
19 28         10144 use Archive::Zip qw(
20             :CONSTANTS
21             :MISC_CONSTANTS
22             :ERROR_CODES
23             :PKZIP_CONSTANTS
24             :UTILITY_METHODS
25 28     28   162 );
  28         62  
26              
27 28     28   11442 use Time::Local ();
  28         36444  
  28         703  
28 28     28   188 use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
  28         48  
  28         2302  
29 28     28   158 use File::Path;
  28         48  
  28         1174  
30 28     28   143 use File::Basename;
  28         48  
  28         1475  
31              
32             # Unix perms for default creation of files/dirs.
33 28     28   153 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
  28         48  
  28         1264  
34 28     28   150 use constant DEFAULT_FILE_PERMISSIONS => 0100666;
  28         54  
  28         1086  
35 28     28   144 use constant DIRECTORY_ATTRIB => 040000;
  28         61  
  28         1112  
36 28     28   151 use constant FILE_ATTRIB => 0100000;
  28         71  
  28         1776  
37 28         45 use constant OS_SUPPORTS_SYMLINK => do {
38 28         79 local $@;
39 28         64 !!eval { symlink("",""); 1 };
  28         277  
  28         65361  
40 28     28   168 };
  28         76  
41              
42             # Returns self if successful, else undef
43             # Assumes that fh is positioned at beginning of central directory file header.
44             # Leaves fh positioned immediately after file header or EOCD signature.
45             sub _newFromZipFile {
46 120     120   190 my $class = shift;
47 120         525 my $self = Archive::Zip::ZipFileMember->_newFromZipFile(@_);
48 120         219 return $self;
49             }
50              
51             sub newFromString {
52 15     15 1 1991 my $class = shift;
53              
54 15         34 my ($stringOrStringRef, $fileName);
55 15 50       56 if (ref($_[0]) eq 'HASH') {
56 0         0 $stringOrStringRef = $_[0]->{string};
57 0         0 $fileName = $_[0]->{zipName};
58             } else {
59 15         41 ($stringOrStringRef, $fileName) = @_;
60             }
61              
62 15         162 my $self =
63             Archive::Zip::StringMember->_newFromString($stringOrStringRef, $fileName);
64 15         48 return $self;
65             }
66              
67             sub newFromFile {
68 334     334 1 475 my $class = shift;
69              
70 334         509 my ($fileName, $zipName);
71 334 50       658 if (ref($_[0]) eq 'HASH') {
72 0         0 $fileName = $_[0]->{fileName};
73 0         0 $zipName = $_[0]->{zipName};
74             } else {
75 334         511 ($fileName, $zipName) = @_;
76             }
77              
78 334         1053 my $self =
79             Archive::Zip::NewFileMember->_newFromFileNamed($fileName, $zipName);
80 334         713 return $self;
81             }
82              
83             sub newDirectoryNamed {
84 17     17 1 37 my $class = shift;
85              
86 17         37 my ($directoryName, $newName);
87 17 50       45 if (ref($_[0]) eq 'HASH') {
88 0         0 $directoryName = $_[0]->{directoryName};
89 0         0 $newName = $_[0]->{zipName};
90             } else {
91 17         48 ($directoryName, $newName) = @_;
92             }
93              
94 17         164 my $self =
95             Archive::Zip::DirectoryMember->_newNamed($directoryName, $newName);
96 17         41 return $self;
97             }
98              
99             sub new {
100 486     486 1 794 my $class = shift;
101             # Info-Zip 3.0 (I guess) seems to use the following values
102             # for the version fields in local and central directory
103             # headers, regardless of whether the member has an zip64
104             # extended information extra field or not:
105             #
106             # version made by:
107             # 30
108             #
109             # version needed to extract:
110             # 10 for directory and stored entries
111             # 20 for anything else
112 486 100       5523 my $self = {
113             'lastModFileDateTime' => 0,
114             'fileAttributeFormat' => FA_UNIX,
115             'zip64' => 0,
116             'desiredZip64Mode' => ZIP64_AS_NEEDED,
117             'versionMadeBy' => 20,
118             'versionNeededToExtract' => 20,
119             'bitFlag' => ($Archive::Zip::UNICODE ? 0x0800 : 0),
120             'compressionMethod' => COMPRESSION_STORED,
121             'desiredCompressionMethod' => COMPRESSION_STORED,
122             'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
123             'internalFileAttributes' => 0,
124             'externalFileAttributes' => 0, # set later
125             'fileName' => '',
126             'cdExtraField' => '',
127             'localExtraField' => '',
128             'fileComment' => '',
129             'crc32' => 0,
130             'compressedSize' => 0,
131             'uncompressedSize' => 0,
132             'password' => undef, # password for encrypted data
133             'crc32c' => -1, # crc for decrypted data
134             @_
135             };
136 486         883 bless($self, $class);
137 486         2157 $self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS);
138 486         848 return $self;
139             }
140              
141             # Morph into given class (do whatever cleanup I need to do)
142             sub _become {
143 18     18   127 return bless($_[0], $_[1]);
144             }
145              
146             sub fileAttributeFormat {
147 243     243 1 318 my $self = shift;
148              
149 243 50       363 if (@_) {
150             $self->{fileAttributeFormat} =
151 0 0       0 (ref($_[0]) eq 'HASH') ? $_[0]->{format} : $_[0];
152             } else {
153 243         561 return $self->{fileAttributeFormat};
154             }
155             }
156              
157             sub zip64 {
158 624     624 1 4327 shift->{'zip64'};
159             }
160              
161             sub desiredZip64Mode {
162 350     350 1 466 my $self = shift;
163 350         471 my $desiredZip64Mode = $self->{'desiredZip64Mode'};
164 350 100       594 if (@_) {
165             $self->{'desiredZip64Mode'} =
166 1 50       4 ref($_[0]) eq 'HASH' ? shift->{desiredZip64Mode} : shift;
167             }
168 350         1064 return $desiredZip64Mode;
169             }
170              
171             sub versionMadeBy {
172 243     243 1 1038 shift->{'versionMadeBy'};
173             }
174              
175             sub versionNeededToExtract {
176 571     571 1 828 shift->{'versionNeededToExtract'};
177             }
178              
179             sub bitFlag {
180 243     243 1 294 my $self = shift;
181              
182             # Set General Purpose Bit Flags according to the desiredCompressionLevel setting
183 243 50 33     475 if ( $self->desiredCompressionLevel == 1
    50 33        
    50 33        
      33        
      33        
      33        
184             || $self->desiredCompressionLevel == 2) {
185 0         0 $self->{'bitFlag'} |= DEFLATING_COMPRESSION_FAST;
186             } elsif ($self->desiredCompressionLevel == 3
187             || $self->desiredCompressionLevel == 4
188             || $self->desiredCompressionLevel == 5
189             || $self->desiredCompressionLevel == 6
190             || $self->desiredCompressionLevel == 7) {
191 0         0 $self->{'bitFlag'} |= DEFLATING_COMPRESSION_NORMAL;
192             } elsif ($self->desiredCompressionLevel == 8
193             || $self->desiredCompressionLevel == 9) {
194 0         0 $self->{'bitFlag'} |= DEFLATING_COMPRESSION_MAXIMUM;
195             }
196              
197 243 100       435 if ($Archive::Zip::UNICODE) {
198 5         8 $self->{'bitFlag'} |= 0x0800;
199             }
200 243         444 $self->{'bitFlag'};
201             }
202              
203             sub password {
204 8     8 1 15 my $self = shift;
205 8 100       21 $self->{'password'} = shift if @_;
206 8         21 $self->{'password'};
207             }
208              
209             sub compressionMethod {
210 1812     1812 1 4242 shift->{'compressionMethod'};
211             }
212              
213             sub desiredCompressionMethod {
214 1769     1769 1 7108 my $self = shift;
215             my $newDesiredCompressionMethod =
216 1769 50       2879 (ref($_[0]) eq 'HASH') ? shift->{compressionMethod} : shift;
217 1769         2434 my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
218 1769 100       2909 if (defined($newDesiredCompressionMethod)) {
219 635         771 $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
220 635 100       1282 if ($newDesiredCompressionMethod == COMPRESSION_STORED) {
    100          
221 229         336 $self->{'desiredCompressionLevel'} = 0;
222 229 100       440 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK
223             if $self->uncompressedSize() == 0;
224             } elsif ($oldDesiredCompressionMethod == COMPRESSION_STORED) {
225 401         532 $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
226             }
227             }
228 1769         3251 return $oldDesiredCompressionMethod;
229             }
230              
231             sub desiredCompressionLevel {
232 2701     2701 1 3041 my $self = shift;
233             my $newDesiredCompressionLevel =
234 2701 50       3946 (ref($_[0]) eq 'HASH') ? shift->{compressionLevel} : shift;
235 2701         3103 my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
236 2701 50       4187 if (defined($newDesiredCompressionLevel)) {
237 0         0 $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
238 0 0       0 $self->{'desiredCompressionMethod'} = (
239             $newDesiredCompressionLevel
240             ? COMPRESSION_DEFLATED
241             : COMPRESSION_STORED
242             );
243             }
244 2701         6684 return $oldDesiredCompressionLevel;
245             }
246              
247             sub fileName {
248 11013     11013 1 12551 my $self = shift;
249 11013         11183 my $newName = shift;
250 11013 100       14708 if (defined $newName) {
251 60         351 $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
252 60         188 $self->{'fileName'} = $newName;
253             }
254 11013         22721 return $self->{'fileName'};
255             }
256              
257             sub fileNameAsBytes {
258 1082     1082 0 1319 my $self = shift;
259 1082         1483 my $bytes = $self->{'fileName'};
260 1082 100       1950 if($self->{'bitFlag'} & 0x800){
261 35         87 $bytes = Encode::encode_utf8($bytes);
262             }
263 1082         1823 return $bytes;
264             }
265              
266             sub lastModFileDateTime {
267 904     904 1 1400 my $modTime = shift->{'lastModFileDateTime'};
268 904         3686 $modTime =~ m/^(\d+)$/; # untaint
269 904         3554 return $1;
270             }
271              
272             sub lastModTime {
273 327     327 1 498 my $self = shift;
274 327         594 return _dosToUnixTime($self->lastModFileDateTime());
275             }
276              
277             sub setLastModFileDateTimeFromUnix {
278 382     382 1 476 my $self = shift;
279 382         430 my $time_t = shift;
280 382         745 $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
281             }
282              
283             sub internalFileAttributes {
284 631     631 1 1239 shift->{'internalFileAttributes'};
285             }
286              
287             sub externalFileAttributes {
288 244     244 1 910 shift->{'externalFileAttributes'};
289             }
290              
291             # Convert UNIX permissions into proper value for zip file
292             # Usable as a function or a method
293             sub _mapPermissionsFromUnix {
294 852     852   1059 my $self = shift;
295 852         1311 my $mode = shift;
296 852         1019 my $attribs = $mode << 16;
297              
298             # Microsoft Windows Explorer needs this bit set for directories
299 852 100       1317 if ($mode & DIRECTORY_ATTRIB) {
300 34         44 $attribs |= 16;
301             }
302              
303 852         1174 return $attribs;
304              
305             # TODO: map more MS-DOS perms
306             }
307              
308             # Convert ZIP permissions into Unix ones
309             #
310             # This was taken from Info-ZIP group's portable UnZip
311             # zipfile-extraction program, version 5.50.
312             # http://www.info-zip.org/pub/infozip/
313             #
314             # See the mapattr() function in unix/unix.c
315             # See the attribute format constants in unzpriv.h
316             #
317             # XXX Note that there's one situation that is not implemented
318             # yet that depends on the "extra field."
319             sub _mapPermissionsToUnix {
320 913     913   1169 my $self = shift;
321              
322 913         1365 my $format = $self->{'fileAttributeFormat'};
323 913         1068 my $attribs = $self->{'externalFileAttributes'};
324              
325 913         1006 my $mode = 0;
326              
327 913 50       1556 if ($format == FA_AMIGA) {
328 0         0 $attribs = $attribs >> 17 & 7; # Amiga RWE bits
329 0         0 $mode = $attribs << 6 | $attribs << 3 | $attribs;
330 0         0 return $mode;
331             }
332              
333 913 50       1439 if ($format == FA_THEOS) {
334 0         0 $attribs &= 0xF1FFFFFF;
335 0 0       0 if (($attribs & 0xF0000000) != 0x40000000) {
336 0         0 $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
337             } else {
338 0         0 $attribs &= 0x41FFFFFF; # leave directory bit as set
339             }
340             }
341              
342 913 50 66     1665 if ( $format == FA_UNIX
      66        
      33        
      33        
      33        
      33        
343             || $format == FA_VAX_VMS
344             || $format == FA_ACORN
345             || $format == FA_ATARI_ST
346             || $format == FA_BEOS
347             || $format == FA_QDOS
348             || $format == FA_TANDEM) {
349 909         1556 $mode = $attribs >> 16;
350 909 50 66     2514 return $mode if $mode != 0 or not $self->localExtraField;
351              
352             # warn("local extra field is: ", $self->localExtraField, "\n");
353              
354             # XXX This condition is not implemented
355             # I'm just including the comments from the info-zip section for now.
356              
357             # Some (non-Info-ZIP) implementations of Zip for Unix and
358             # VMS (and probably others ??) leave 0 in the upper 16-bit
359             # part of the external_file_attributes field. Instead, they
360             # store file permission attributes in some extra field.
361             # As a work-around, we search for the presence of one of
362             # these extra fields and fall back to the MSDOS compatible
363             # part of external_file_attributes if one of the known
364             # e.f. types has been detected.
365             # Later, we might implement extraction of the permission
366             # bits from the VMS extra field. But for now, the work-around
367             # should be sufficient to provide "readable" extracted files.
368             # (For ASI Unix e.f., an experimental remap from the e.f.
369             # mode value IS already provided!)
370             }
371              
372             # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
373             # Unix attributes in the upper 16 bits of the external attributes
374             # field, just like Info-ZIP's Zip for Unix. We try to use that
375             # value, after a check for consistency with the MSDOS attribute
376             # bits (see below).
377 4 50       8 if ($format == FA_MSDOS) {
378 4         4 $mode = $attribs >> 16;
379             }
380              
381             # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
382 4         10 $attribs = !($attribs & 1) << 1 | ($attribs & 0x10) >> 4;
383              
384             # keep previous $mode setting when its "owner"
385             # part appears to be consistent with DOS attribute flags!
386 4 50       9 return $mode if ($mode & 0700) == (0400 | $attribs << 6);
387 4         5 $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
388 4         4 return $mode;
389             }
390              
391             sub unixFileAttributes {
392 913     913 1 1185 my $self = shift;
393 913         1551 my $oldPerms = $self->_mapPermissionsToUnix;
394              
395 913         1127 my $perms;
396 913 100       1409 if (@_) {
397 852 50       1687 $perms = (ref($_[0]) eq 'HASH') ? $_[0]->{attributes} : $_[0];
398              
399 852 100       1580 if ($self->isDirectory) {
400 34         57 $perms &= ~FILE_ATTRIB;
401 34         46 $perms |= DIRECTORY_ATTRIB;
402             } else {
403 818         1077 $perms &= ~DIRECTORY_ATTRIB;
404 818         983 $perms |= FILE_ATTRIB;
405             }
406             $self->{externalFileAttributes} =
407 852         1520 $self->_mapPermissionsFromUnix($perms);
408             }
409              
410 913         2184 return $oldPerms;
411             }
412              
413             sub localExtraField {
414 832     832 1 2615 my $self = shift;
415              
416 832 100       1476 if (@_) {
417             my $localExtraField =
418 6 50       23 (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0];
419 6         16 my ($status, $zip64) =
420             $self->_extractZip64ExtraField($localExtraField, undef, undef);
421 6 100       15 if ($status != AZ_OK) {
    100          
422 2         9 return $status;
423             }
424             elsif ($zip64) {
425 1         5 return _formatError('invalid extra field (contains zip64 information)');
426             }
427             else {
428 3         6 $self->{localExtraField} = $localExtraField;
429 3         20 return AZ_OK;
430             }
431             } else {
432 826         2525 return $self->{localExtraField};
433             }
434             }
435              
436             sub cdExtraField {
437 261     261 1 580 my $self = shift;
438              
439 261 100       500 if (@_) {
440             my $cdExtraField =
441 6 50       35 (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0];
442 6         37 my ($status, $zip64) =
443             $self->_extractZip64ExtraField($cdExtraField, undef, undef);
444 6 100       25 if ($status != AZ_OK) {
    100          
445 2         17 return $status;
446             }
447             elsif ($zip64) {
448 1         5 return _formatError('invalid extra field (contains zip64 information)');
449             }
450             else {
451 3         12 $self->{cdExtraField} = $cdExtraField;
452 3         17 return AZ_OK;
453             }
454             } else {
455 255         589 return $self->{cdExtraField};
456             }
457             }
458              
459             sub extraFields {
460 6     6 1 15 my $self = shift;
461 6         15 return $self->localExtraField() . $self->cdExtraField();
462             }
463              
464             sub fileComment {
465 243     243 1 284 my $self = shift;
466              
467 243 50       408 if (@_) {
468             $self->{fileComment} =
469             (ref($_[0]) eq 'HASH')
470             ? pack('C0a*', $_[0]->{comment})
471 0 0       0 : pack('C0a*', $_[0]);
472             } else {
473 243         397 return $self->{fileComment};
474             }
475             }
476              
477             sub hasDataDescriptor {
478 610     610 1 767 my $self = shift;
479 610 100       1183 if (@_) {
480 24         45 my $shouldHave = shift;
481 24 50       56 if ($shouldHave) {
482 24         55 $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
483             } else {
484 0         0 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
485             }
486             }
487 610         1319 return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
488             }
489              
490             sub crc32 {
491 583     583 1 15365 shift->{'crc32'};
492             }
493              
494             sub crc32String {
495 3     3 1 19 sprintf("%08x", shift->{'crc32'});
496             }
497              
498             sub compressedSize {
499 449     449 1 1355 shift->{'compressedSize'};
500             }
501              
502             sub uncompressedSize {
503 2328     2328 1 6583 shift->{'uncompressedSize'};
504             }
505              
506             sub isEncrypted {
507 280     280 1 957 shift->{'bitFlag'} & GPBF_ENCRYPTED_MASK;
508             }
509              
510             sub isTextFile {
511 361     361 1 669 my $self = shift;
512 361         597 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
513 361 100       859 if (@_) {
514 334 50       721 my $flag = (ref($_[0]) eq 'HASH') ? shift->{flag} : shift;
515 334         481 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
516 334 100       549 $self->{'internalFileAttributes'} |=
517             ($flag ? IFA_TEXT_FILE : IFA_BINARY_FILE);
518             }
519 361         576 return $bit == IFA_TEXT_FILE;
520             }
521              
522             sub isBinaryFile {
523 27     27 1 2839 my $self = shift;
524 27         42 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
525 27 50       43 if (@_) {
526 0         0 my $flag = shift;
527 0         0 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
528 0 0       0 $self->{'internalFileAttributes'} |=
529             ($flag ? IFA_BINARY_FILE : IFA_TEXT_FILE);
530             }
531 27         58 return $bit == IFA_BINARY_FILE;
532             }
533              
534             sub extractToFileNamed {
535 54     54 1 423 my $self = shift;
536              
537             # local FS name
538 54 50       141 my $name = (ref($_[0]) eq 'HASH') ? $_[0]->{name} : $_[0];
539              
540             # Create directory for regular files as well as for symbolic
541             # links
542 54 50 33     362 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
543 0         0 $name = decode_utf8(Win32::GetFullPathName($name));
544 0         0 mkpath_win32($name);
545             } else {
546 54         3534 mkpath(dirname($name)); # croaks on error
547             }
548              
549             # Check if the file / directory is a symbolic link *and* if
550             # the operating system supports these. Only in that case
551             # call method extractToFileHandle with the name of the
552             # symbolic link. If the operating system does not support
553             # symbolic links, process the member using the usual
554             # extraction routines, which creates a file containing the
555             # link target.
556 54 100 100     301 if ($self->isSymbolicLink() && OS_SUPPORTS_SYMLINK) {
557 5         20 return $self->extractToFileHandle($name);
558             } else {
559 49         103 my ($status, $fh);
560 49 50 33     204 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
561 0         0 Win32::CreateFile($name);
562 0         0 ($status, $fh) = _newFileHandle(Win32::GetANSIPathName($name), 'w');
563             } else {
564 49         174 ($status, $fh) = _newFileHandle($name, 'w');
565             }
566 49 50       163 return _ioError("Can't open file $name for write") unless $status;
567 49         233 $status = $self->extractToFileHandle($fh);
568 49         150 $fh->close();
569 49 50       2305 chmod($self->unixFileAttributes(), $name)
570             or return _error("Can't chmod() ${name}: $!");
571 49         289 utime($self->lastModTime(), $self->lastModTime(), $name);
572 49         325 return $status;
573             }
574             }
575              
576             sub mkpath_win32 {
577 0     0 0 0 my $path = shift;
578 28     28   500 use File::Spec;
  28         56  
  28         98815  
579              
580 0         0 my ($volume, @path) = File::Spec->splitdir($path);
581 0         0 $path = File::Spec->catfile($volume, shift @path);
582 0         0 pop @path;
583 0         0 while (@path) {
584 0         0 $path = File::Spec->catfile($path, shift @path);
585 0         0 Win32::CreateDirectory($path);
586             }
587             }
588              
589             sub isSymbolicLink {
590 353     353 0 1109 return shift->{'externalFileAttributes'} == 0xA1FF0000;
591             }
592              
593             sub isDirectory {
594 719     719 1 1055 return 0;
595             }
596              
597             sub externalFileName {
598 0     0 1 0 return undef;
599             }
600              
601             # Search the given extra field string for a zip64 extended
602             # information extra field and "correct" the header fields given
603             # in the remaining parameters with the information from that
604             # extra field, if required. Writes back the extra field string
605             # sans the zip64 information. The extra field string and all
606             # header fields must be passed as lvalues or the undefined value.
607             #
608             # This method returns a pair ($status, $zip64) in list context,
609             # where the latter flag specifies whether a zip64 extended
610             # information extra field was found.
611             #
612             # This method must be called with two header fields for local
613             # file headers and with four header fields for Central Directory
614             # headers.
615             sub _extractZip64ExtraField
616             {
617 51     51   742 my $classOrSelf = shift;
618              
619 51         99 my $extraField = $_[0];
620              
621 51         102 my ($zip64Data, $newExtraField) = (undef, '');
622 51         144 while (length($extraField) >= 4) {
623 42         118 my ($headerId, $dataSize) = unpack('v v', $extraField);
624 42 100       135 if (length($extraField) < 4 + $dataSize) {
    100          
625 2         13 return _formatError('invalid extra field (bad data)');
626             }
627             elsif ($headerId != 0x0001) {
628 4         22 $newExtraField .= substr($extraField, 0, 4 + $dataSize);
629 4         15 $extraField = substr($extraField, 4 + $dataSize);
630             }
631             else {
632 36         71 $zip64Data = substr($extraField, 4, $dataSize);
633 36         108 $extraField = substr($extraField, 4 + $dataSize);
634             }
635             }
636 49 100       106 if (length($extraField) != 0) {
637 2         13 return _formatError('invalid extra field (bad header ID or data size)');
638             }
639              
640 47         56 my $zip64 = 0;
641 47 100       84 if (defined($zip64Data)) {
642 36         54 return _zip64NotSupported() unless ZIP64_SUPPORTED;
643              
644 36         47 my $dataLength = length($zip64Data);
645              
646             # Try to be tolerant with respect to the fields to be
647             # extracted from the zip64 extended information extra
648             # field and derive that information from the data itself,
649             # if possible. This works around, for example, incorrect
650             # extra fields written by certain versions of package
651             # IO::Compress::Zip. That package provides the disk
652             # number start in the extra field without setting the
653             # corresponding regular field to 0xffff. Plus it
654             # provides the full set of fields even for the local file
655             # header.
656             #
657             # Field zero is the extra field string which we must keep
658             # in @_ for future modification, so account for that.
659 36         49 my @fields;
660 36 100 100     280 if (@_ == 3 && $dataLength == 16) {
    50 66        
    50 66        
    50 66        
    100 100        
661 25         53 @fields = (undef, 0xffffffff, 0xffffffff);
662             }
663             elsif (@_ == 3 && $dataLength == 24) {
664 0         0 push(@_, undef);
665 0         0 @fields = (undef, 0xffffffff, 0xffffffff, 0xffffffff);
666             }
667             elsif (@_ == 3 && $dataLength == 28) {
668 0         0 push(@_, undef, undef);
669 0         0 @fields = (undef, 0xffffffff, 0xffffffff, 0xffffffff, 0xffff);
670             }
671             elsif (@_ == 5 && $dataLength == 24) {
672 0         0 @fields = (undef, 0xffffffff, 0xffffffff, 0xffffffff);
673             }
674             elsif (@_ == 5 && $dataLength == 28) {
675 1         19 @fields = (undef, 0xffffffff, 0xffffffff, 0xffffffff, 0xffff);
676             }
677             else {
678 10 100       22 @fields = map { defined $_ ? $_ : 0 } @_;
  44         93  
679             }
680              
681 36         81 my @fieldIndexes = (0);
682 36         58 my $fieldFormat = '';
683 36         48 my $expDataLength = 0;
684 36 100       69 if ($fields[1] == 0xffffffff) {
685 28         41 push(@fieldIndexes, 1);
686 28         43 $fieldFormat .= 'Q< ';
687 28         37 $expDataLength += 8;
688             }
689 36 100       72 if ($fields[2] == 0xffffffff) {
690 27         33 push(@fieldIndexes, 2);
691 27         33 $fieldFormat .= 'Q< ';
692 27         36 $expDataLength += 8;
693             }
694 36 100 100     116 if (@fields > 3 && $fields[3] == 0xffffffff) {
695 7         19 push(@fieldIndexes, 3);
696 7         17 $fieldFormat .= 'Q< ';
697 7         9 $expDataLength += 8;
698             }
699 36 100 100     89 if (@fields > 3 && $fields[4] == 0xffff) {
700 1         6 push(@fieldIndexes, 4);
701 1         2 $fieldFormat .= 'L< ';
702 1         8 $expDataLength += 4;
703             }
704              
705 36 100       66 if ($dataLength == $expDataLength) {
706 35         111 @_[@fieldIndexes] = ($newExtraField, unpack($fieldFormat, $zip64Data));
707 35         66 $zip64 = 1;
708             }
709             else {
710 1         5 return _formatError('invalid zip64 extended information extra field');
711             }
712             }
713              
714 46         112 return (AZ_OK, $zip64);
715             }
716              
717             # The following are used when copying data
718             sub _writeOffset {
719 1230     1230   2190 shift->{'writeOffset'};
720             }
721              
722             sub _readOffset {
723 88     88   276 shift->{'readOffset'};
724             }
725              
726             sub writeLocalHeaderRelativeOffset {
727 501     501 1 1031 shift->{'writeLocalHeaderRelativeOffset'};
728             }
729              
730             # Maintained in method Archive::Zip::Archive::writeToFileHandle
731             sub wasWritten {
732 0     0 1 0 shift->{'wasWritten'}
733             }
734              
735             sub _dataEnded {
736 534     534   1501 shift->{'dataEnded'};
737             }
738              
739             sub _readDataRemaining {
740 1428     1428   3580 shift->{'readDataRemaining'};
741             }
742              
743             sub _inflater {
744 15     15   820 shift->{'inflater'};
745             }
746              
747             sub _deflater {
748 124     124   6084 shift->{'deflater'};
749             }
750              
751             # DOS date/time format
752             # 0-4 (5) Second divided by 2
753             # 5-10 (6) Minute (0-59)
754             # 11-15 (5) Hour (0-23 on a 24-hour clock)
755             # 16-20 (5) Day of the month (1-31)
756             # 21-24 (4) Month (1 = January, 2 = February, etc.)
757             # 25-31 (7) Year offset from 1980 (add 1980 to get actual year)
758              
759             # Convert DOS date/time format to unix time_t format
760             # NOT AN OBJECT METHOD!
761             sub _dosToUnixTime {
762 343     343   520 my $dt = shift;
763 343 50       691 return time() unless defined($dt);
764              
765 343         766 my $year = (($dt >> 25) & 0x7f) + 1980;
766 343         483 my $mon = (($dt >> 21) & 0x0f) - 1;
767 343         453 my $mday = (($dt >> 16) & 0x1f);
768              
769 343         415 my $hour = (($dt >> 11) & 0x1f);
770 343         472 my $min = (($dt >> 5) & 0x3f);
771 343         513 my $sec = (($dt << 1) & 0x3e);
772              
773             # catch errors
774             my $time_t =
775 343         511 eval { Time::Local::timelocal($sec, $min, $hour, $mday, $mon, $year); };
  343         905  
776 343 50       18999 return time() if ($@);
777 343         2010 return $time_t;
778             }
779              
780             # Note, this is not exactly UTC 1980, it's 1980 + 12 hours and 1
781             # minute so that nothing timezoney can muck us up.
782             my $safe_epoch = 31.676060;
783              
784             # convert a unix time to DOS date/time
785             # NOT AN OBJECT METHOD!
786             sub _unixToDosTime {
787 399     399   13122 my $time_t = shift;
788 399 100       768 unless ($time_t) {
789 1         5 _error("Tried to add member with zero or undef value for time");
790 1         3 $time_t = $safe_epoch;
791             }
792 399 50       854 if ($time_t < $safe_epoch) {
793 0         0 _ioError("Unsupported date before 1980 encountered, moving to 1980");
794 0         0 $time_t = $safe_epoch;
795             }
796 399         6751 my ($sec, $min, $hour, $mday, $mon, $year) = localtime($time_t);
797 399         1095 my $dt = 0;
798 399         573 $dt += ($sec >> 1);
799 399         479 $dt += ($min << 5);
800 399         493 $dt += ($hour << 11);
801 399         557 $dt += ($mday << 16);
802 399         490 $dt += (($mon + 1) << 21);
803 399         633 $dt += (($year - 80) << 25);
804 399         1166 return $dt;
805             }
806              
807             # Write my local header to a file handle.
808             # Returns a pair (AZ_OK, $headerSize) on success.
809             sub _writeLocalFileHeader {
810 328     328   436 my $self = shift;
811 328         377 my $fh = shift;
812 328 100       615 my $refresh = @_ ? shift : 0;
813              
814 328         1271 my $zip64 = $self->zip64();
815 328         842 my $hasDataDescriptor = $self->hasDataDescriptor();
816              
817 328         737 my $versionNeededToExtract = $self->versionNeededToExtract();
818 328         638 my $crc32;
819             my $compressedSize;
820 328         0 my $uncompressedSize;
821 328         682 my $localExtraField = $self->localExtraField();
822              
823 328 100       589 if (! $zip64) {
824 233 100       432 if ($refresh) {
    100          
825 60         185 $crc32 = $self->crc32();
826 60         114 $compressedSize = $self->_writeOffset();
827 60         113 $uncompressedSize = $self->uncompressedSize();
828              
829             # Handle a brain-dead corner case gracefully.
830             # Otherwise we a) would always need to write zip64
831             # format or b) re-write the complete member data on
832             # refresh (which might not always be possible).
833 60 50       143 if ($compressedSize > 0xffffffff) {
834 0         0 return _formatError('compressed size too large for refresh');
835             }
836             }
837             elsif ($hasDataDescriptor) {
838 67         109 $crc32 = 0;
839 67         87 $compressedSize = 0;
840 67         83 $uncompressedSize = 0;
841             }
842             else {
843 106         301 $crc32 = $self->crc32();
844 106         266 $compressedSize = $self->_writeOffset();
845 106         175 $uncompressedSize = $self->uncompressedSize();
846             }
847             }
848             else {
849 95         170 return _zip64NotSupported() unless ZIP64_SUPPORTED;
850              
851 95 100       203 $versionNeededToExtract = 45 if ($versionNeededToExtract < 45);
852              
853 95         151 my $zip64CompressedSize;
854             my $zip64UncompressedSize;
855 95 100       260 if ($refresh) {
    100          
856 25         52 $crc32 = $self->crc32();
857 25         34 $compressedSize = 0xffffffff;
858 25         32 $uncompressedSize = 0xffffffff;
859 25         45 $zip64CompressedSize = $self->_writeOffset();
860 25         46 $zip64UncompressedSize = $self->uncompressedSize();
861             }
862             elsif ($hasDataDescriptor) {
863 31         94 $crc32 = 0;
864 31         47 $compressedSize = 0xffffffff;
865 31         48 $uncompressedSize = 0xffffffff;
866 31         40 $zip64CompressedSize = 0;
867 31         48 $zip64UncompressedSize = 0;
868             }
869             else {
870 39         92 $crc32 = $self->crc32();
871 39         53 $compressedSize = 0xffffffff;
872 39         55 $uncompressedSize = 0xffffffff;
873 39         90 $zip64CompressedSize = $self->_writeOffset();
874 39         76 $zip64UncompressedSize = $self->uncompressedSize();
875             }
876              
877 95         375 $localExtraField .= pack('S< S< Q< Q<',
878             0x0001, 16,
879             $zip64UncompressedSize,
880             $zip64CompressedSize);
881             }
882              
883 328         663 my $fileNameLength = length($self->fileNameAsBytes());
884 328         441 my $localFieldLength = length($localExtraField);
885              
886 328         444 my $signatureData = pack(SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE);
887 328 50       921 $self->_print($fh, $signatureData)
888             or return _ioError("writing local header signature");
889              
890             my $header =
891             pack(LOCAL_FILE_HEADER_FORMAT,
892             $versionNeededToExtract,
893 328         3343 $self->{'bitFlag'},
894             $self->desiredCompressionMethod(),
895             $self->lastModFileDateTime(),
896             $crc32,
897             $compressedSize,
898             $uncompressedSize,
899             $fileNameLength,
900             $localFieldLength);
901 328 50       876 $self->_print($fh, $header)
902             or return _ioError("writing local header");
903              
904             # Write these only if required
905 328 100 100     2703 if (! $refresh || $zip64) {
906 268 50       512 if ($fileNameLength) {
907 268 50       446 $self->_print($fh, $self->fileNameAsBytes())
908             or return _ioError("writing local header filename");
909             }
910 268 100       1765 if ($localFieldLength) {
911 97 50       203 $self->_print($fh, $localExtraField)
912             or return _ioError("writing local extra field");
913             }
914             }
915              
916             return
917 328         1208 (AZ_OK,
918             LOCAL_FILE_HEADER_LENGTH +
919             SIGNATURE_LENGTH +
920             $fileNameLength +
921             $localFieldLength);
922             }
923              
924             # Re-writes the local file header with new crc32 and compressedSize fields.
925             # To be called after writing the data stream.
926             # Assumes that filename and extraField sizes didn't change since last written.
927             sub _refreshLocalFileHeader {
928 85     85   126 my $self = shift;
929 85         110 my $fh = shift;
930              
931 85         238 my $here = $fh->tell();
932 85 50       455 $fh->seek($self->writeLocalHeaderRelativeOffset(), IO::Seekable::SEEK_SET)
933             or return _ioError("seeking to rewrite local header");
934              
935 85         2526 my ($status, undef) = $self->_writeLocalFileHeader($fh, 1);
936 85 50       248 return $status if $status != AZ_OK;
937              
938 85 50       225 $fh->seek($here, IO::Seekable::SEEK_SET)
939             or return _ioError("seeking after rewrite of local header");
940              
941 85         1588 return AZ_OK;
942             }
943              
944             # Write central directory file header.
945             # Returns a pair (AZ_OK, $headerSize) on success.
946             sub _writeCentralDirectoryFileHeader {
947 243     243   485 my $self = shift;
948 243         390 my $fh = shift;
949 243         292 my $adz64m = shift; # $archiveDesiredZip64Mode
950              
951             # (Re-)Determine whether to write zip64 format. Assume
952             # {'diskNumberStart'} is always zero.
953 243   33     796 my $zip64 = $adz64m == ZIP64_HEADERS
954             || $self->desiredZip64Mode() == ZIP64_HEADERS
955             || $self->_writeOffset() > 0xffffffff
956             || $self->uncompressedSize() > 0xffffffff
957             || $self->writeLocalHeaderRelativeOffset() > 0xffffffff;
958              
959 243   66     819 $self->{'zip64'} ||= $zip64;
960              
961 243         466 my $versionMadeBy = $self->versionMadeBy();
962 243         366 my $versionNeededToExtract = $self->versionNeededToExtract();
963 243         340 my $compressedSize = $self->_writeOffset();
964 243         334 my $uncompressedSize = $self->uncompressedSize();
965 243         375 my $localHeaderRelativeOffset = $self->writeLocalHeaderRelativeOffset();
966 243         457 my $cdExtraField = $self->cdExtraField();
967              
968 243 100       458 if (!$zip64) {
969             # no-op
970             }
971             else {
972 70         79 return _zip64NotSupported() unless ZIP64_SUPPORTED;
973              
974 70 100       153 $versionNeededToExtract = 45 if ($versionNeededToExtract < 45);
975              
976 70         108 my $extraFieldFormat = '';
977 70         121 my @extraFieldValues = ();
978 70         85 my $extraFieldSize = 0;
979 70 50       125 if ($uncompressedSize > 0xffffffff) {
980 0         0 $extraFieldFormat .= 'Q< ';
981 0         0 push(@extraFieldValues, $uncompressedSize);
982 0         0 $extraFieldSize += 8;
983 0         0 $uncompressedSize = 0xffffffff;
984             }
985 70 50       123 if ($compressedSize > 0xffffffff) {
986 0         0 $extraFieldFormat .= 'Q< ';
987 0         0 push(@extraFieldValues, $compressedSize);
988 0         0 $extraFieldSize += 8;
989 0         0 $compressedSize = 0xffffffff;
990             }
991             # Avoid empty zip64 extended information extra fields
992 70 50 33     231 if ( $localHeaderRelativeOffset > 0xffffffff
993             || @extraFieldValues == 0) {
994 70         128 $extraFieldFormat .= 'Q< ';
995 70         107 push(@extraFieldValues, $localHeaderRelativeOffset);
996 70         77 $extraFieldSize += 8;
997 70         87 $localHeaderRelativeOffset = 0xffffffff;
998             }
999              
1000             $cdExtraField .=
1001 70         193 pack("S< S< $extraFieldFormat",
1002             0x0001, $extraFieldSize,
1003             @extraFieldValues);
1004             }
1005              
1006 243         448 my $fileNameLength = length($self->fileNameAsBytes());
1007 243         319 my $extraFieldLength = length($cdExtraField);
1008 243         430 my $fileCommentLength = length($self->fileComment());
1009              
1010 243         331 my $sigData =
1011             pack(SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE);
1012 243 50       539 $self->_print($fh, $sigData)
1013             or return _ioError("writing central directory header signature");
1014              
1015 243         1736 my $header = pack(
1016             CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
1017             $versionMadeBy,
1018             $self->fileAttributeFormat(),
1019             $versionNeededToExtract,
1020             $self->bitFlag(),
1021             $self->desiredCompressionMethod(),
1022             $self->lastModFileDateTime(),
1023             $self->crc32(), # these three fields should have been updated
1024             $compressedSize, # by writing the data stream out
1025             $uncompressedSize, #
1026             $fileNameLength,
1027             $extraFieldLength,
1028             $fileCommentLength,
1029             0, # {'diskNumberStart'},
1030             $self->internalFileAttributes(),
1031             $self->externalFileAttributes(),
1032             $localHeaderRelativeOffset);
1033              
1034 243 50       617 $self->_print($fh, $header)
1035             or return _ioError("writing central directory header");
1036              
1037 243 50       1624 if ($fileNameLength) {
1038 243 50       483 $self->_print($fh, $self->fileNameAsBytes())
1039             or return _ioError("writing central directory header signature");
1040             }
1041 243 100       1602 if ($extraFieldLength) {
1042 72 50       156 $self->_print($fh, $cdExtraField)
1043             or return _ioError("writing central directory extra field");
1044             }
1045 243 50       760 if ($fileCommentLength) {
1046 0 0       0 $self->_print($fh, $self->fileComment())
1047             or return _ioError("writing central directory file comment");
1048             }
1049              
1050             # Update object members with information which might have
1051             # changed while writing this member. We already did the
1052             # zip64 flag. We must not update the extra fields with any
1053             # zip64 information, since we consider that internal.
1054 243         351 $self->{'versionNeededToExtract'} = $versionNeededToExtract;
1055 243         396 $self->{'compressedSize'} = $self->_writeOffset();
1056              
1057             return
1058 243         646 (AZ_OK,
1059             CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
1060             SIGNATURE_LENGTH +
1061             $fileNameLength +
1062             $extraFieldLength +
1063             $fileCommentLength)
1064             }
1065              
1066             # This writes a data descriptor to the given file handle.
1067             # Assumes that crc32, writeOffset, and uncompressedSize are
1068             # set correctly (they should be after a write).
1069             # Returns a pair (AZ_OK, $dataDescriptorSize) on success.
1070             # Further, the local file header should have the
1071             # GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
1072             sub _writeDataDescriptor {
1073 98     98   147 my $self = shift;
1074 98         131 my $fh = shift;
1075              
1076 98         120 my $descriptor;
1077 98 100       196 if (! $self->zip64()) {
1078 67         123 $descriptor =
1079             pack(SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
1080             DATA_DESCRIPTOR_SIGNATURE,
1081             $self->crc32(),
1082             $self->_writeOffset(), # compressed size
1083             $self->uncompressedSize());
1084             }
1085             else {
1086 31         39 return _zip64NotSupported() unless ZIP64_SUPPORTED;
1087              
1088 31         67 $descriptor =
1089             pack(SIGNATURE_FORMAT . DATA_DESCRIPTOR_ZIP64_FORMAT,
1090             DATA_DESCRIPTOR_SIGNATURE,
1091             $self->crc32(),
1092             $self->_writeOffset(), # compressed size
1093             $self->uncompressedSize());
1094             }
1095              
1096 98 50       261 $self->_print($fh, $descriptor)
1097             or return _ioError("writing data descriptor");
1098              
1099 98         632 return (AZ_OK, length($descriptor));
1100             }
1101              
1102             sub readChunk {
1103 273     273 1 389 my $self = shift;
1104 273 50       550 my $chunkSize = (ref($_[0]) eq 'HASH') ? $_[0]->{chunkSize} : $_[0];
1105              
1106 273 100       625 if ($self->readIsDone()) {
1107 12         28 $self->endRead();
1108 12         24 my $dummy = '';
1109 12         31 return (\$dummy, AZ_STREAM_END);
1110             }
1111              
1112 261 50       588 $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
1113 261 100       483 $chunkSize = $self->_readDataRemaining()
1114             if $chunkSize > $self->_readDataRemaining();
1115              
1116 261         421 my $buffer = '';
1117 261         313 my $outputRef;
1118 261         953 my ($bytesRead, $status) = $self->_readRawChunk(\$buffer, $chunkSize);
1119 261 50       570 return (\$buffer, $status) unless $status == AZ_OK;
1120              
1121 261 100 66     979 $buffer && $self->isEncrypted and $buffer = $self->_decode($buffer);
1122 261         396 $self->{'readDataRemaining'} -= $bytesRead;
1123 261         356 $self->{'readOffset'} += $bytesRead;
1124              
1125 261 100       473 if ($self->compressionMethod() == COMPRESSION_STORED) {
1126 213         679 $self->{'crc32'} = $self->computeCRC32($buffer, $self->{'crc32'});
1127             }
1128              
1129 261         495 ($outputRef, $status) = &{$self->{'chunkHandler'}}($self, \$buffer);
  261         522  
1130 261         473 $self->{'writeOffset'} += length($$outputRef);
1131              
1132 261 100       567 $self->endRead()
1133             if $self->readIsDone();
1134              
1135 261         549 return ($outputRef, $status);
1136             }
1137              
1138             # Read the next raw chunk of my data. Subclasses MUST implement.
1139             # my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
1140             sub _readRawChunk {
1141 0     0   0 my $self = shift;
1142 0         0 return $self->_subclassResponsibility();
1143             }
1144              
1145             # A place holder to catch rewindData errors if someone ignores
1146             # the error code.
1147             sub _noChunk {
1148 0     0   0 my $self = shift;
1149 0         0 return (\undef, _error("trying to copy chunk when init failed"));
1150             }
1151              
1152             # Basically a no-op so that I can have a consistent interface.
1153             # ( $outputRef, $status) = $self->_copyChunk( \$buffer );
1154             sub _copyChunk {
1155 183     183   353 my ($self, $dataRef) = @_;
1156 183         317 return ($dataRef, AZ_OK);
1157             }
1158              
1159             # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
1160             sub _deflateChunk {
1161 63     63   123 my ($self, $buffer) = @_;
1162 63         146 my ($status) = $self->_deflater()->deflate($buffer, my $out);
1163              
1164 63 100       193 if ($self->_readDataRemaining() == 0) {
    50          
1165 61         81 my $extraOutput;
1166 61         99 ($status) = $self->_deflater()->flush($extraOutput);
1167 61         283 $out .= $extraOutput;
1168 61         199 $self->endRead();
1169 61         241 return (\$out, AZ_STREAM_END);
1170             } elsif ($status == Z_OK) {
1171 2         13 return (\$out, AZ_OK);
1172             } else {
1173 0         0 $self->endRead();
1174 0         0 my $retval = _error('deflate error', $status);
1175 0         0 my $dummy = '';
1176 0         0 return (\$dummy, $retval);
1177             }
1178             }
1179              
1180             # ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
1181             sub _inflateChunk {
1182 15     15   30 my ($self, $buffer) = @_;
1183 15         46 my ($status) = $self->_inflater()->inflate($buffer, my $out);
1184 15         30 my $retval;
1185 15 100       54 $self->endRead() unless $status == Z_OK;
1186 15 50 66     42 if ($status == Z_OK || $status == Z_STREAM_END) {
1187 15 100       228 $retval = ($status == Z_STREAM_END) ? AZ_STREAM_END : AZ_OK;
1188 15         114 return (\$out, $retval);
1189             } else {
1190 0         0 $retval = _error('inflate error', $status);
1191 0         0 my $dummy = '';
1192 0         0 return (\$dummy, $retval);
1193             }
1194             }
1195              
1196             sub rewindData {
1197 321     321 1 525 my $self = shift;
1198 321         374 my $status;
1199              
1200             # set to trap init errors
1201 321         1191 $self->{'chunkHandler'} = $self->can('_noChunk');
1202              
1203             # Work around WinZip bug with 0-length DEFLATED files
1204 321 100       629 $self->desiredCompressionMethod(COMPRESSION_STORED)
1205             if $self->uncompressedSize() == 0;
1206              
1207             # assume that we're going to read the whole file, and compute the CRC anew.
1208 321 100       739 $self->{'crc32'} = 0
1209             if ($self->compressionMethod() == COMPRESSION_STORED);
1210              
1211             # These are the only combinations of methods we deal with right now.
1212 321 100 100     473 if ( $self->compressionMethod() == COMPRESSION_STORED
    100 100        
    50          
1213             and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED) {
1214 61         178 ($self->{'deflater'}, $status) = Compress::Raw::Zlib::Deflate->new(
1215             '-Level' => $self->desiredCompressionLevel(),
1216             '-WindowBits' => -MAX_WBITS(), # necessary magic
1217             '-Bufsize' => $Archive::Zip::ChunkSize,
1218             @_
1219             ); # pass additional options
1220 61 50       41535 return _error('deflateInit error:', $status)
1221             unless $status == Z_OK;
1222 61         562 $self->{'chunkHandler'} = $self->can('_deflateChunk');
1223             } elsif ($self->compressionMethod() == COMPRESSION_DEFLATED
1224             and $self->desiredCompressionMethod() == COMPRESSION_STORED) {
1225 20         75 ($self->{'inflater'}, $status) = Compress::Raw::Zlib::Inflate->new(
1226             '-WindowBits' => -MAX_WBITS(), # necessary magic
1227             '-Bufsize' => $Archive::Zip::ChunkSize,
1228             @_
1229             ); # pass additional options
1230 20 50       7858 return _error('inflateInit error:', $status)
1231             unless $status == Z_OK;
1232 20         244 $self->{'chunkHandler'} = $self->can('_inflateChunk');
1233             } elsif ($self->compressionMethod() == $self->desiredCompressionMethod()) {
1234 240         645 $self->{'chunkHandler'} = $self->can('_copyChunk');
1235             } else {
1236 0         0 return _error(
1237             sprintf(
1238             "Unsupported compression combination: read %d, write %d",
1239             $self->compressionMethod(),
1240             $self->desiredCompressionMethod()));
1241             }
1242              
1243 321 100       744 $self->{'readDataRemaining'} =
1244             ($self->compressionMethod() == COMPRESSION_STORED)
1245             ? $self->uncompressedSize()
1246             : $self->compressedSize();
1247 321         500 $self->{'dataEnded'} = 0;
1248 321         547 $self->{'readOffset'} = 0;
1249              
1250 321         605 return AZ_OK;
1251             }
1252              
1253             sub endRead {
1254 724     724 1 1132 my $self = shift;
1255 724         1039 delete $self->{'inflater'};
1256 724         2239 delete $self->{'deflater'};
1257 724         983 $self->{'dataEnded'} = 1;
1258 724         852 $self->{'readDataRemaining'} = 0;
1259 724         1173 return AZ_OK;
1260             }
1261              
1262             sub readIsDone {
1263 534     534 1 637 my $self = shift;
1264 534   100     841 return ($self->_dataEnded() or !$self->_readDataRemaining());
1265             }
1266              
1267             sub contents {
1268 18     18 1 29179 my $self = shift;
1269 18         32 my $newContents = shift;
1270              
1271 18 100       50 if (defined($newContents)) {
1272              
1273             # Change our type and ensure that succeeded to avoid
1274             # endless recursion
1275 6         56 $self->_become('Archive::Zip::StringMember');
1276 6 0       39 $self->_ISA('Archive::Zip::StringMember') or
    50          
1277             return
1278             wantarray
1279             ? (undef, $self->_error('becoming Archive::Zip::StringMember'))
1280             : undef;
1281              
1282             # Now call the subclass contents method
1283 6         55 my $retval =
1284             $self->contents(pack('C0a*', $newContents)); # in case of Unicode
1285              
1286 6 50       39 return wantarray ? ($retval, AZ_OK) : $retval;
1287             } else {
1288 12         26 my $oldCompression =
1289             $self->desiredCompressionMethod(COMPRESSION_STORED);
1290 12         37 my $status = $self->rewindData(@_);
1291 12 50       37 if ($status != AZ_OK) {
1292 0         0 $self->endRead();
1293 0 0       0 return wantarray ? (undef, $status) : undef;
1294             }
1295 12         31 my $retval = '';
1296 12         28 while ($status == AZ_OK) {
1297 23         33 my $ref;
1298 23         53 ($ref, $status) = $self->readChunk($self->_readDataRemaining());
1299              
1300             # did we get it in one chunk?
1301 23 100       46 if (length($$ref) == $self->uncompressedSize()) {
1302 11         33 $retval = $$ref;
1303             } else {
1304 12         31 $retval .= $$ref
1305             }
1306             }
1307 12         28 $self->desiredCompressionMethod($oldCompression);
1308 12         28 $self->endRead();
1309 12 50       21 $status = AZ_OK if $status == AZ_STREAM_END;
1310 12 50       24 $retval = undef unless $status == AZ_OK;
1311 12 100       52 return wantarray ? ($retval, $status) : $retval;
1312             }
1313             }
1314              
1315             sub extractToFileHandle {
1316 56     56 1 1619 my $self = shift;
1317             # This can be the link name when "extracting" symbolic links
1318 56 50       168 my $fhOrName = (ref($_[0]) eq 'HASH') ? shift->{fileHandle} : shift;
1319 56 100       188 _binmode($fhOrName) if ref($fhOrName);
1320 56         430 my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
1321 56         174 my $status = $self->rewindData(@_);
1322 56 50       245 $status = $self->_writeData($fhOrName) if $status == AZ_OK;
1323 56         136 $self->desiredCompressionMethod($oldCompression);
1324 56         126 $self->endRead();
1325 56         101 return $status;
1326             }
1327              
1328             # write local header and data stream to file handle.
1329             # Returns a pair ($status, $memberSize) if successful.
1330             # Stores the offset to the start of the header in my
1331             # writeLocalHeaderRelativeOffset member.
1332             sub _writeToFileHandle {
1333 243     243   350 my $self = shift;
1334 243         342 my $fh = shift;
1335 243         329 my $fhIsSeekable = shift;
1336 243         300 my $offset = shift;
1337 243         396 my $adz64m = shift; # $archiveDesiredZip64Mode
1338              
1339 243 50       568 return _error("no member name given for $self")
1340             if $self->fileName() eq '';
1341              
1342 243         503 $self->{'writeLocalHeaderRelativeOffset'} = $offset;
1343              
1344             # Determine if I need to refresh the header in a second pass
1345             # later. If in doubt, I'd rather refresh, since it does not
1346             # seem to be worth the hassle to save the extra seeks and
1347             # writes. In addition, having below condition independent of
1348             # any specific compression methods helps me piping through
1349             # members with unknown compression methods unchanged. See
1350             # test t/26_bzip2.t for details.
1351 243         547 my $headerFieldsUnknown = $self->uncompressedSize() > 0;
1352              
1353             # Determine if I need to write a data descriptor
1354             # I need to do this if I can't refresh the header
1355             # and I don't know compressed size or crc32 fields.
1356 243   100     766 my $shouldWriteDataDescriptor =
1357             ($headerFieldsUnknown and not $fhIsSeekable);
1358              
1359 243 100       501 $self->hasDataDescriptor(1)
1360             if ($shouldWriteDataDescriptor);
1361              
1362             # Determine whether to write zip64 format
1363 243   66     814 my $zip64 = $adz64m == ZIP64_HEADERS
1364             || $self->desiredZip64Mode() == ZIP64_HEADERS
1365             || $self->uncompressedSize() > 0xffffffff;
1366              
1367 243   66     1014 $self->{'zip64'} ||= $zip64;
1368              
1369 243         417 $self->{'writeOffset'} = 0;
1370              
1371 243         736 my $status = $self->rewindData();
1372 243 50       516 return $status if $status != AZ_OK;
1373              
1374 243         316 my $memberSize;
1375 243         665 ($status, $memberSize) = $self->_writeLocalFileHeader($fh);
1376 243 50       458 return $status if $status != AZ_OK;
1377              
1378 243         640 $status = $self->_writeData($fh);
1379 243 50       557 return $status if $status != AZ_OK;
1380 243         450 $memberSize += $self->_writeOffset();
1381              
1382 243 100       466 if ($self->hasDataDescriptor()) {
    100          
1383 98         119 my $ddSize;
1384 98         254 ($status, $ddSize) = $self->_writeDataDescriptor($fh);
1385 98         133 $memberSize += $ddSize;
1386             } elsif ($headerFieldsUnknown) {
1387 85         252 $status = $self->_refreshLocalFileHeader($fh);
1388             }
1389 243 50       496 return $status if $status != AZ_OK;
1390              
1391 243         631 return ($status, $memberSize);
1392             }
1393              
1394             # Copy my (possibly compressed) data to given file handle.
1395             # Returns C<AZ_OK> on success
1396             sub _writeData {
1397 299     299   451 my $self = shift;
1398 299         374 my $fhOrName = shift;
1399              
1400 299 100 100     711 if ($self->isSymbolicLink() && OS_SUPPORTS_SYMLINK) {
1401 7         12 my $chunkSize = $Archive::Zip::ChunkSize;
1402 7         24 my ($outRef, $status) = $self->readChunk($chunkSize);
1403 7 100       219 symlink($$outRef, $fhOrName)
1404             or return _ioError("creating symbolic link");
1405             } else {
1406 292 100       584 return AZ_OK if ($self->uncompressedSize() == 0);
1407 229         348 my $status;
1408 229         315 my $chunkSize = $Archive::Zip::ChunkSize;
1409 229         511 while ($self->_readDataRemaining() > 0) {
1410 235         308 my $outRef;
1411 235         602 ($outRef, $status) = $self->readChunk($chunkSize);
1412 235 50 66     733 return $status if ($status != AZ_OK and $status != AZ_STREAM_END);
1413              
1414 235 100       586 if (length($$outRef) > 0) {
1415 233 50       664 $self->_print($fhOrName, $$outRef)
1416             or return _ioError("write error during copy");
1417             }
1418              
1419 235 100       3245 last if $status == AZ_STREAM_END;
1420             }
1421             }
1422 234         419 return AZ_OK;
1423             }
1424              
1425             # Return true if I depend on the named file
1426             sub _usesFileNamed {
1427 108     108   288 return 0;
1428             }
1429              
1430             # ##############################################################################
1431             #
1432             # Decrypt section
1433             #
1434             # H.Merijn Brand (Tux) 2011-06-28
1435             #
1436             # ##############################################################################
1437              
1438             # This code is derived from the crypt source of unzip-6.0 dated 05 Jan 2007
1439             # Its license states:
1440             #
1441             # --8<---
1442             # Copyright (c) 1990-2007 Info-ZIP. All rights reserved.
1443              
1444             # See the accompanying file LICENSE, version 2005-Feb-10 or later
1445             # (the contents of which are also included in (un)zip.h) for terms of use.
1446             # If, for some reason, all these files are missing, the Info-ZIP license
1447             # also may be found at: ftp://ftp.info-zip.org/pub/infozip/license.html
1448             #
1449             # crypt.c (full version) by Info-ZIP. Last revised: [see crypt.h]
1450              
1451             # The main encryption/decryption source code for Info-Zip software was
1452             # originally written in Europe. To the best of our knowledge, it can
1453             # be freely distributed in both source and object forms from any country,
1454             # including the USA under License Exception TSU of the U.S. Export
1455             # Administration Regulations (section 740.13(e)) of 6 June 2002.
1456              
1457             # NOTE on copyright history:
1458             # Previous versions of this source package (up to version 2.8) were
1459             # not copyrighted and put in the public domain. If you cannot comply
1460             # with the Info-Zip LICENSE, you may want to look for one of those
1461             # public domain versions.
1462             #
1463             # This encryption code is a direct transcription of the algorithm from
1464             # Roger Schlafly, described by Phil Katz in the file appnote.txt. This
1465             # file (appnote.txt) is distributed with the PKZIP program (even in the
1466             # version without encryption capabilities).
1467             # -->8---
1468              
1469             # As of January 2000, US export regulations were amended to allow export
1470             # of free encryption source code from the US. As of June 2002, these
1471             # regulations were further relaxed to allow export of encryption binaries
1472             # associated with free encryption source code. The Zip 2.31, UnZip 5.52
1473             # and Wiz 5.02 archives now include full crypto source code. As of the
1474             # Zip 2.31 release, all official binaries include encryption support; the
1475             # former "zcr" archives ceased to exist.
1476             # (Note that restrictions may still exist in other countries, of course.)
1477              
1478             # For now, we just support the decrypt stuff
1479             # All below methods are supposed to be private
1480              
1481             # use Data::Peek;
1482              
1483             my @keys;
1484             my @crct = do {
1485             my $xor = 0xedb88320;
1486             my @crc = (0) x 1024;
1487              
1488             # generate a crc for every 8-bit value
1489             foreach my $n (0 .. 255) {
1490             my $c = $n;
1491             $c = $c & 1 ? $xor ^ ($c >> 1) : $c >> 1 for 1 .. 8;
1492             $crc[$n] = _revbe($c);
1493             }
1494              
1495             # generate crc for each value followed by one, two, and three zeros */
1496             foreach my $n (0 .. 255) {
1497             my $c = ($crc[($crc[$n] >> 24) ^ 0] ^ ($crc[$n] << 8)) & 0xffffffff;
1498             $crc[$_ * 256 + $n] = $c for 1 .. 3;
1499             }
1500             map { _revbe($crc[$_]) } 0 .. 1023;
1501             };
1502              
1503             sub _crc32 {
1504 194     194   221 my ($c, $b) = @_;
1505 194         271 return ($crct[($c ^ $b) & 0xff] ^ ($c >> 8));
1506             } # _crc32
1507              
1508             sub _revbe {
1509 35840     35840   35719 my $w = shift;
1510 35840         53708 return (($w >> 24) +
1511             (($w >> 8) & 0xff00) +
1512             (($w & 0xff00) << 8) +
1513             (($w & 0xff) << 24));
1514             } # _revbe
1515              
1516             sub _update_keys {
1517 28     28   12531 use integer;
  28         356  
  28         138  
1518 97     97   101 my $c = shift; # signed int
1519 97         110 $keys[0] = _crc32($keys[0], $c);
1520 97         125 $keys[1] = (($keys[1] + ($keys[0] & 0xff)) * 0x08088405 + 1) & 0xffffffff;
1521 97         102 my $keyshift = $keys[1] >> 24;
1522 97         116 $keys[2] = _crc32($keys[2], $keyshift);
1523             } # _update_keys
1524              
1525             sub _zdecode ($) {
1526 84     84   90 my $c = shift;
1527 84         96 my $t = ($keys[2] & 0xffff) | 2;
1528 84         144 _update_keys($c ^= ((($t * ($t ^ 1)) >> 8) & 0xff));
1529 84         115 return $c;
1530             } # _zdecode
1531              
1532             sub _decode {
1533 3     3   11 my $self = shift;
1534 3         5 my $buff = shift;
1535              
1536 3 50       6 $self->isEncrypted or return $buff;
1537              
1538 3         32 my $pass = $self->password;
1539 3 50       7 defined $pass or return "";
1540              
1541 3         13 @keys = (0x12345678, 0x23456789, 0x34567890);
1542 3         14 _update_keys($_) for unpack "C*", $pass;
1543              
1544             # DDumper { uk => [ @keys ] };
1545              
1546 3         9 my $head = substr $buff, 0, 12, "";
1547 3         16 my @head = map { _zdecode($_) } unpack "C*", $head;
  36         46  
1548             my $x =
1549             $self->{externalFileAttributes}
1550             ? ($self->{lastModFileDateTime} >> 8) & 0xff
1551 3 50       11 : $self->{crc32} >> 24;
1552 3 100       20 $head[-1] == $x or return ""; # Password fail
1553              
1554             # Worth checking ...
1555 2         13 $self->{crc32c} = (unpack LOCAL_FILE_HEADER_FORMAT, pack "C*", @head)[3];
1556              
1557             # DHexDump ($buff);
1558 2         8 $buff = pack "C*" => map { _zdecode($_) } unpack "C*" => $buff;
  48         57  
1559              
1560             # DHexDump ($buff);
1561 2         7 return $buff;
1562             } # _decode
1563              
1564             1;