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 45 47 95.7
total 1021 1235 82.6


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   203 use strict;
  28         58  
  28         951  
6 28     28   144 use vars qw( $VERSION @ISA );
  28         63  
  28         2525  
7              
8             BEGIN {
9 28     28   117 $VERSION = '1.68';
10 28         701 @ISA = qw( Archive::Zip );
11              
12 28 50       1055 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         10833 use Archive::Zip qw(
20             :CONSTANTS
21             :MISC_CONSTANTS
22             :ERROR_CODES
23             :PKZIP_CONSTANTS
24             :UTILITY_METHODS
25 28     28   200 );
  28         79  
26              
27 28     28   13692 use Time::Local ();
  28         40986  
  28         818  
28 28     28   222 use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
  28         57  
  28         2469  
29 28     28   178 use File::Path;
  28         56  
  28         1160  
30 28     28   150 use File::Basename;
  28         54  
  28         1624  
31              
32             # Unix perms for default creation of files/dirs.
33 28     28   201 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
  28         59  
  28         1378  
34 28     28   149 use constant DEFAULT_FILE_PERMISSIONS => 0100666;
  28         49  
  28         1249  
35 28     28   193 use constant DIRECTORY_ATTRIB => 040000;
  28         78  
  28         1507  
36 28     28   195 use constant FILE_ATTRIB => 0100000;
  28         67  
  28         2186  
37 28         58 use constant OS_SUPPORTS_SYMLINK => do {
38 28         55 local $@;
39 28         69 !!eval { symlink("",""); 1 };
  28         329  
  28         77945  
40 28     28   181 };
  28         78  
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 117     117   240 my $class = shift;
47 117         762 my $self = Archive::Zip::ZipFileMember->_newFromZipFile(@_);
48 117         251 return $self;
49             }
50              
51             sub newFromString {
52 15     15 1 1845 my $class = shift;
53              
54 15         33 my ($stringOrStringRef, $fileName);
55 15 50       49 if (ref($_[0]) eq 'HASH') {
56 0         0 $stringOrStringRef = $_[0]->{string};
57 0         0 $fileName = $_[0]->{zipName};
58             } else {
59 15         44 ($stringOrStringRef, $fileName) = @_;
60             }
61              
62 15         156 my $self =
63             Archive::Zip::StringMember->_newFromString($stringOrStringRef, $fileName);
64 15         56 return $self;
65             }
66              
67             sub newFromFile {
68 201     201 1 345 my $class = shift;
69              
70 201         304 my ($fileName, $zipName);
71 201 50       409 if (ref($_[0]) eq 'HASH') {
72 0         0 $fileName = $_[0]->{fileName};
73 0         0 $zipName = $_[0]->{zipName};
74             } else {
75 201         352 ($fileName, $zipName) = @_;
76             }
77              
78 201         808 my $self =
79             Archive::Zip::NewFileMember->_newFromFileNamed($fileName, $zipName);
80 201         478 return $self;
81             }
82              
83             sub newDirectoryNamed {
84 19     19 1 64 my $class = shift;
85              
86 19         49 my ($directoryName, $newName);
87 19 50       76 if (ref($_[0]) eq 'HASH') {
88 0         0 $directoryName = $_[0]->{directoryName};
89 0         0 $newName = $_[0]->{zipName};
90             } else {
91 19         59 ($directoryName, $newName) = @_;
92             }
93              
94 19         288 my $self =
95             Archive::Zip::DirectoryMember->_newNamed($directoryName, $newName);
96 19         81 return $self;
97             }
98              
99             sub new {
100 352     352 1 693 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 352 100       5447 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 352         805 bless($self, $class);
137 352         2096 $self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS);
138 352         1045 return $self;
139             }
140              
141             # Morph into given class (do whatever cleanup I need to do)
142             sub _become {
143 19     19   144 return bless($_[0], $_[1]);
144             }
145              
146             sub fileAttributeFormat {
147 409     409 1 577 my $self = shift;
148              
149 409 50       706 if (@_) {
150             $self->{fileAttributeFormat} =
151 0 0       0 (ref($_[0]) eq 'HASH') ? $_[0]->{format} : $_[0];
152             } else {
153 409         1084 return $self->{fileAttributeFormat};
154             }
155             }
156              
157             sub zip64 {
158 1050     1050 1 5095 shift->{'zip64'};
159             }
160              
161             sub desiredZip64Mode {
162 584     584 1 884 my $self = shift;
163 584         923 my $desiredZip64Mode = $self->{'desiredZip64Mode'};
164 584 100       1095 if (@_) {
165             $self->{'desiredZip64Mode'} =
166 1 50       4 ref($_[0]) eq 'HASH' ? shift->{desiredZip64Mode} : shift;
167             }
168 584         2404 return $desiredZip64Mode;
169             }
170              
171             sub versionMadeBy {
172 409     409 1 768 shift->{'versionMadeBy'};
173             }
174              
175             sub versionNeededToExtract {
176 841     841 1 1456 shift->{'versionNeededToExtract'};
177             }
178              
179             sub bitFlag {
180 409     409 1 694 my $self = shift;
181              
182             # Set General Purpose Bit Flags according to the desiredCompressionLevel setting
183 409 50 33     928 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 409 100       934 if ($Archive::Zip::UNICODE) {
198 14         18 $self->{'bitFlag'} |= 0x0800;
199             }
200 409         876 $self->{'bitFlag'};
201             }
202              
203             sub password {
204 8     8 1 13 my $self = shift;
205 8 100       21 $self->{'password'} = shift if @_;
206 8         24 $self->{'password'};
207             }
208              
209             sub compressionMethod {
210 2996     2996 1 8175 shift->{'compressionMethod'};
211             }
212              
213             sub desiredCompressionMethod {
214 2348     2348 1 10443 my $self = shift;
215             my $newDesiredCompressionMethod =
216 2348 50       4609 (ref($_[0]) eq 'HASH') ? shift->{compressionMethod} : shift;
217 2348         3410 my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
218 2348 100       4226 if (defined($newDesiredCompressionMethod)) {
219 595         866 $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
220 595 100       1239 if ($newDesiredCompressionMethod == COMPRESSION_STORED) {
    100          
221 284         518 $self->{'desiredCompressionLevel'} = 0;
222 284 100       654 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK
223             if $self->uncompressedSize() == 0;
224             } elsif ($oldDesiredCompressionMethod == COMPRESSION_STORED) {
225 306         489 $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
226             }
227             }
228 2348         5294 return $oldDesiredCompressionMethod;
229             }
230              
231             sub desiredCompressionLevel {
232 4276     4276 1 5932 my $self = shift;
233             my $newDesiredCompressionLevel =
234 4276 50       6754 (ref($_[0]) eq 'HASH') ? shift->{compressionLevel} : shift;
235 4276         5479 my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
236 4276 50       6943 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 4276         11917 return $oldDesiredCompressionLevel;
245             }
246              
247             sub fileName {
248 5217     5217 1 9863 my $self = shift;
249 5217         6477 my $newName = shift;
250 5217 100       8751 if (defined $newName) {
251 63         219 $newName =~ y{\\/}{/}s; # deal with dos/windoze problems
252 63         143 $self->{'fileName'} = $newName;
253             }
254 5217         14802 return $self->{'fileName'};
255             }
256              
257             sub fileNameAsBytes {
258 1665     1665 0 2289 my $self = shift;
259 1665         2623 my $bytes = $self->{'fileName'};
260 1665 100       3210 if($self->{'bitFlag'} & 0x800){
261 80         227 $bytes = Encode::encode_utf8($bytes);
262             }
263 1665         3928 return $bytes;
264             }
265              
266             sub lastModFileDateTime {
267 1170     1170 1 1884 my $modTime = shift->{'lastModFileDateTime'};
268 1170         6003 $modTime =~ m/^(\d+)$/; # untaint
269 1170         5429 return $1;
270             }
271              
272             sub lastModTime {
273 323     323 1 582 my $self = shift;
274 323         730 return _dosToUnixTime($self->lastModFileDateTime());
275             }
276              
277             sub setLastModFileDateTimeFromUnix {
278 251     251 1 416 my $self = shift;
279 251         377 my $time_t = shift;
280 251         645 $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
281             }
282              
283             sub internalFileAttributes {
284 664     664 1 1490 shift->{'internalFileAttributes'};
285             }
286              
287             sub externalFileAttributes {
288 410     410 1 1667 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 587     587   885 my $self = shift;
295 587         800 my $mode = shift;
296 587         877 my $attribs = $mode << 16;
297              
298             # Microsoft Windows Explorer needs this bit set for directories
299 587 100       1064 if ($mode & DIRECTORY_ATTRIB) {
300 38         57 $attribs |= 16;
301             }
302              
303 587         998 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 682     682   959 my $self = shift;
321              
322 682         1346 my $format = $self->{'fileAttributeFormat'};
323 682         979 my $attribs = $self->{'externalFileAttributes'};
324              
325 682         896 my $mode = 0;
326              
327 682 50       1467 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 682 50       1297 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 682 50 66     1576 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 678         970 $mode = $attribs >> 16;
350 678 50 66     2402 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         6 $mode = $attribs >> 16;
379             }
380              
381             # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
382 4         9 $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       10 return $mode if ($mode & 0700) == (0400 | $attribs << 6);
387 4         7 $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
388 4         5 return $mode;
389             }
390              
391             sub unixFileAttributes {
392 682     682 1 1111 my $self = shift;
393 682         1503 my $oldPerms = $self->_mapPermissionsToUnix;
394              
395 682         1052 my $perms;
396 682 100       1327 if (@_) {
397 587 50       1127 $perms = (ref($_[0]) eq 'HASH') ? $_[0]->{attributes} : $_[0];
398              
399 587 100       1366 if ($self->isDirectory) {
400 38         71 $perms &= ~FILE_ATTRIB;
401 38         78 $perms |= DIRECTORY_ATTRIB;
402             } else {
403 549         828 $perms &= ~DIRECTORY_ATTRIB;
404 549         793 $perms |= FILE_ATTRIB;
405             }
406             $self->{externalFileAttributes} =
407 587         1350 $self->_mapPermissionsFromUnix($perms);
408             }
409              
410 682         2795 return $oldPerms;
411             }
412              
413             sub localExtraField {
414 802     802 1 2188 my $self = shift;
415              
416 802 100       1623 if (@_) {
417             my $localExtraField =
418 6 50       42 (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0];
419 6         18 my ($status, $zip64) =
420             $self->_extractZip64ExtraField($localExtraField, undef, undef);
421 6 100       26 if ($status != AZ_OK) {
    100          
422 2         84 return $status;
423             }
424             elsif ($zip64) {
425 1         4 return _formatError('invalid extra field (contains zip64 information)');
426             }
427             else {
428 3         7 $self->{localExtraField} = $localExtraField;
429 3         35 return AZ_OK;
430             }
431             } else {
432 796         2830 return $self->{localExtraField};
433             }
434             }
435              
436             sub cdExtraField {
437 427     427 1 928 my $self = shift;
438              
439 427 100       795 if (@_) {
440             my $cdExtraField =
441 6 50       27 (ref($_[0]) eq 'HASH') ? $_[0]->{field} : $_[0];
442 6         49 my ($status, $zip64) =
443             $self->_extractZip64ExtraField($cdExtraField, undef, undef);
444 6 100       32 if ($status != AZ_OK) {
    100          
445 2         34 return $status;
446             }
447             elsif ($zip64) {
448 1         4 return _formatError('invalid extra field (contains zip64 information)');
449             }
450             else {
451 3         6 $self->{cdExtraField} = $cdExtraField;
452 3         26 return AZ_OK;
453             }
454             } else {
455 421         1034 return $self->{cdExtraField};
456             }
457             }
458              
459             sub extraFields {
460 6     6 1 16 my $self = shift;
461 6         21 return $self->localExtraField() . $self->cdExtraField();
462             }
463              
464             sub fileComment {
465 409     409 1 566 my $self = shift;
466              
467 409 50       721 if (@_) {
468             $self->{fileComment} =
469             (ref($_[0]) eq 'HASH')
470             ? pack('C0a*', $_[0]->{comment})
471 0 0       0 : pack('C0a*', $_[0]);
472             } else {
473 409         809 return $self->{fileComment};
474             }
475             }
476              
477             sub hasDataDescriptor {
478 1015     1015 1 1541 my $self = shift;
479 1015 100       1941 if (@_) {
480 158         242 my $shouldHave = shift;
481 158 50       375 if ($shouldHave) {
482 158         356 $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
483             } else {
484 0         0 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
485             }
486             }
487 1015         2527 return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
488             }
489              
490             sub crc32 {
491 853     853 1 2213 shift->{'crc32'};
492             }
493              
494             sub crc32String {
495 3     3 1 26 sprintf("%08x", shift->{'crc32'});
496             }
497              
498             sub compressedSize {
499 335     335 1 1288 shift->{'compressedSize'};
500             }
501              
502             sub uncompressedSize {
503 3725     3725 1 10816 shift->{'uncompressedSize'};
504             }
505              
506             sub isEncrypted {
507 567     567 1 1967 shift->{'bitFlag'} & GPBF_ENCRYPTED_MASK;
508             }
509              
510             sub isTextFile {
511 228     228 1 528 my $self = shift;
512 228         465 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
513 228 100       624 if (@_) {
514 201 50       546 my $flag = (ref($_[0]) eq 'HASH') ? shift->{flag} : shift;
515 201         299 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
516 201 100       443 $self->{'internalFileAttributes'} |=
517             ($flag ? IFA_TEXT_FILE : IFA_BINARY_FILE);
518             }
519 228         456 return $bit == IFA_TEXT_FILE;
520             }
521              
522             sub isBinaryFile {
523 27     27 1 3611 my $self = shift;
524 27         60 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
525 27 50       54 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         125 return $bit == IFA_BINARY_FILE;
532             }
533              
534             sub extractToFileNamed {
535 86     86 1 614 my $self = shift;
536              
537             # local FS name
538 86 50       229 my $name = (ref($_[0]) eq 'HASH') ? $_[0]->{name} : $_[0];
539              
540             # Create directory for regular files as well as for symbolic
541             # links
542 86 50 33     383 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 86         6886 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 86 100 100     475 if ($self->isSymbolicLink() && OS_SUPPORTS_SYMLINK) {
557 3         11 return $self->extractToFileHandle($name);
558             } else {
559 83         176 my ($status, $fh);
560 83 50 33     335 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 83         286 ($status, $fh) = _newFileHandle($name, 'w');
565             }
566 83 50       277 return _ioError("Can't open file $name for write") unless $status;
567 83         399 $status = $self->extractToFileHandle($fh);
568 83         267 $fh->close();
569 83 50       3880 chmod($self->unixFileAttributes(), $name)
570             or return _error("Can't chmod() ${name}: $!");
571 83         422 utime($self->lastModTime(), $self->lastModTime(), $name);
572 83         842 return $status;
573             }
574             }
575              
576             sub mkpath_win32 {
577 0     0 0 0 my $path = shift;
578 28     28   255 use File::Spec;
  28         75  
  28         112429  
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 583     583 1 2180 return shift->{'externalFileAttributes'} == 0xA1FF0000;
591             }
592              
593             sub isDirectory {
594 555     555 1 1410 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 66     66   456 my $classOrSelf = shift;
618              
619 66         141 my $extraField = $_[0];
620              
621 66         196 my ($zip64Data, $newExtraField) = (undef, '');
622 66         180 while (length($extraField) >= 4) {
623 57         165 my ($headerId, $dataSize) = unpack('v v', $extraField);
624 57 100       203 if (length($extraField) < 4 + $dataSize) {
    100          
625 2         12 return _formatError('invalid extra field (bad data)');
626             }
627             elsif ($headerId != 0x0001) {
628 4         15 $newExtraField .= substr($extraField, 0, 4 + $dataSize);
629 4         14 $extraField = substr($extraField, 4 + $dataSize);
630             }
631             else {
632 51         150 $zip64Data = substr($extraField, 4, $dataSize);
633 51         169 $extraField = substr($extraField, 4 + $dataSize);
634             }
635             }
636 64 100       171 if (length($extraField) != 0) {
637 2         9 return _formatError('invalid extra field (bad header ID or data size)');
638             }
639              
640 62         96 my $zip64 = 0;
641 62 100       127 if (defined($zip64Data)) {
642 51         75 return _zip64NotSupported() unless ZIP64_SUPPORTED;
643              
644 51         81 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 51         75 my @fields;
660 51 100 100     372 if (@_ == 3 && $dataLength == 16) {
    50 66        
    50 66        
    50 66        
    100 100        
661 40         120 @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         18 @fields = (undef, 0xffffffff, 0xffffffff, 0xffffffff, 0xffff);
676             }
677             else {
678 10 100       32 @fields = map { defined $_ ? $_ : 0 } @_;
  44         93  
679             }
680              
681 51         84 my @fieldIndexes = (0);
682 51         83 my $fieldFormat = '';
683 51         72 my $expDataLength = 0;
684 51 100       104 if ($fields[1] == 0xffffffff) {
685 43         128 push(@fieldIndexes, 1);
686 43         84 $fieldFormat .= 'Q< ';
687 43         72 $expDataLength += 8;
688             }
689 51 100       109 if ($fields[2] == 0xffffffff) {
690 42         53 push(@fieldIndexes, 2);
691 42         85 $fieldFormat .= 'Q< ';
692 42         68 $expDataLength += 8;
693             }
694 51 100 100     161 if (@fields > 3 && $fields[3] == 0xffffffff) {
695 7         29 push(@fieldIndexes, 3);
696 7         20 $fieldFormat .= 'Q< ';
697 7         17 $expDataLength += 8;
698             }
699 51 100 100     157 if (@fields > 3 && $fields[4] == 0xffff) {
700 1         6 push(@fieldIndexes, 4);
701 1         6 $fieldFormat .= 'L< ';
702 1         3 $expDataLength += 4;
703             }
704              
705 51 100       99 if ($dataLength == $expDataLength) {
706 50         177 @_[@fieldIndexes] = ($newExtraField, unpack($fieldFormat, $zip64Data));
707 50         112 $zip64 = 1;
708             }
709             else {
710 1         6 return _formatError('invalid zip64 extended information extra field');
711             }
712             }
713              
714 61         188 return (AZ_OK, $zip64);
715             }
716              
717             # The following are used when copying data
718             sub _writeOffset {
719 1948     1948   7981 shift->{'writeOffset'};
720             }
721              
722             sub _readOffset {
723 136     136   504 shift->{'readOffset'};
724             }
725              
726             sub writeLocalHeaderRelativeOffset {
727 721     721 1 1319 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 872     872   2954 shift->{'dataEnded'};
737             }
738              
739             sub _readDataRemaining {
740 2399     2399   6977 shift->{'readDataRemaining'};
741             }
742              
743             sub _inflater {
744 15     15   980 shift->{'inflater'};
745             }
746              
747             sub _deflater {
748 216     216   13844 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 339     339   650 my $dt = shift;
763 339 50       759 return time() unless defined($dt);
764              
765 339         903 my $year = (($dt >> 25) & 0x7f) + 1980;
766 339         547 my $mon = (($dt >> 21) & 0x0f) - 1;
767 339         492 my $mday = (($dt >> 16) & 0x1f);
768              
769 339         495 my $hour = (($dt >> 11) & 0x1f);
770 339         473 my $min = (($dt >> 5) & 0x3f);
771 339         589 my $sec = (($dt << 1) & 0x3e);
772              
773             # catch errors
774             my $time_t =
775 339         518 eval { Time::Local::timelocal($sec, $min, $hour, $mday, $mon, $year); };
  339         1030  
776 339 50       20822 return time() if ($@);
777 339         3044 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.686060;
783              
784             # convert a unix time to DOS date/time
785             # NOT AN OBJECT METHOD!
786             sub _unixToDosTime {
787 268     268   10202 my $time_t = shift;
788 268 100       612 unless ($time_t) {
789 1         12 _error("Tried to add member with zero or undef value for time");
790 1         2 $time_t = $safe_epoch;
791             }
792 268 50       629 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 268         6484 my ($sec, $min, $hour, $mday, $mon, $year) = localtime($time_t);
797 268         884 my $dt = 0;
798 268         445 $dt += ($sec >> 1);
799 268         437 $dt += ($min << 5);
800 268         393 $dt += ($hour << 11);
801 268         358 $dt += ($mday << 16);
802 268         405 $dt += (($mon + 1) << 21);
803 268         542 $dt += (($year - 80) << 25);
804 268         993 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 432     432   745 my $self = shift;
811 432         625 my $fh = shift;
812 432 100       883 my $refresh = @_ ? shift : 0;
813              
814 432         1239 my $zip64 = $self->zip64();
815 432         1180 my $hasDataDescriptor = $self->hasDataDescriptor();
816              
817 432         1005 my $versionNeededToExtract = $self->versionNeededToExtract();
818 432         1026 my $crc32;
819             my $compressedSize;
820 432         0 my $uncompressedSize;
821 432         1104 my $localExtraField = $self->localExtraField();
822              
823 432 100       977 if (! $zip64) {
824 306 100       688 if ($refresh) {
    100          
825 17         39 $crc32 = $self->crc32();
826 17         46 $compressedSize = $self->_writeOffset();
827 17         39 $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 17 50       44 if ($compressedSize > 0xffffffff) {
834 0         0 return _formatError('compressed size too large for refresh');
835             }
836             }
837             elsif ($hasDataDescriptor) {
838 203         332 $crc32 = 0;
839 203         289 $compressedSize = 0;
840 203         326 $uncompressedSize = 0;
841             }
842             else {
843 86         298 $crc32 = $self->crc32();
844 86         411 $compressedSize = $self->_writeOffset();
845 86         175 $uncompressedSize = $self->uncompressedSize();
846             }
847             }
848             else {
849 126         229 return _zip64NotSupported() unless ZIP64_SUPPORTED;
850              
851 126 100       386 $versionNeededToExtract = 45 if ($versionNeededToExtract < 45);
852              
853 126         250 my $zip64CompressedSize;
854             my $zip64UncompressedSize;
855 126 100       390 if ($refresh) {
    100          
856 6         20 $crc32 = $self->crc32();
857 6         11 $compressedSize = 0xffffffff;
858 6         15 $uncompressedSize = 0xffffffff;
859 6         29 $zip64CompressedSize = $self->_writeOffset();
860 6         14 $zip64UncompressedSize = $self->uncompressedSize();
861             }
862             elsif ($hasDataDescriptor) {
863 92         174 $crc32 = 0;
864 92         155 $compressedSize = 0xffffffff;
865 92         133 $uncompressedSize = 0xffffffff;
866 92         141 $zip64CompressedSize = 0;
867 92         151 $zip64UncompressedSize = 0;
868             }
869             else {
870 28         127 $crc32 = $self->crc32();
871 28         101 $compressedSize = 0xffffffff;
872 28         54 $uncompressedSize = 0xffffffff;
873 28         139 $zip64CompressedSize = $self->_writeOffset();
874 28         68 $zip64UncompressedSize = $self->uncompressedSize();
875             }
876              
877 126         594 $localExtraField .= pack('S< S< Q< Q<',
878             0x0001, 16,
879             $zip64UncompressedSize,
880             $zip64CompressedSize);
881             }
882              
883 432         1086 my $fileNameLength = length($self->fileNameAsBytes());
884 432         678 my $localFieldLength = length($localExtraField);
885              
886 432         773 my $signatureData = pack(SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE);
887 432 50       1448 $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 432         5631 $self->{'bitFlag'},
894             $self->desiredCompressionMethod(),
895             $self->lastModFileDateTime(),
896             $crc32,
897             $compressedSize,
898             $uncompressedSize,
899             $fileNameLength,
900             $localFieldLength);
901 432 50       1317 $self->_print($fh, $header)
902             or return _ioError("writing local header");
903              
904             # Write these only if required
905 432 100 100     3957 if (! $refresh || $zip64) {
906 415 50       805 if ($fileNameLength) {
907 415 50       817 $self->_print($fh, $self->fileNameAsBytes())
908             or return _ioError("writing local header filename");
909             }
910 415 100       3270 if ($localFieldLength) {
911 130 50       371 $self->_print($fh, $localExtraField)
912             or return _ioError("writing local extra field");
913             }
914             }
915              
916             return
917 432         2092 (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 23     23   37 my $self = shift;
929 23         38 my $fh = shift;
930              
931 23         73 my $here = $fh->tell();
932 23 50       157 $fh->seek($self->writeLocalHeaderRelativeOffset(), IO::Seekable::SEEK_SET)
933             or return _ioError("seeking to rewrite local header");
934              
935 23         897 my ($status, undef) = $self->_writeLocalFileHeader($fh, 1);
936 23 50       83 return $status if $status != AZ_OK;
937              
938 23 50       110 $fh->seek($here, IO::Seekable::SEEK_SET)
939             or return _ioError("seeking after rewrite of local header");
940              
941 23         564 return AZ_OK;
942             }
943              
944             # Write central directory file header.
945             # Returns a pair (AZ_OK, $headerSize) on success.
946             sub _writeCentralDirectoryFileHeader {
947 409     409   683 my $self = shift;
948 409         549 my $fh = shift;
949 409         575 my $adz64m = shift; # $archiveDesiredZip64Mode
950              
951             # (Re-)Determine whether to write zip64 format. Assume
952             # {'diskNumberStart'} is always zero.
953 409   33     1376 my $zip64 = $adz64m == ZIP64_HEADERS
954             || $self->desiredZip64Mode() == ZIP64_HEADERS
955             || $self->_writeOffset() > 0xffffffff
956             || $self->uncompressedSize() > 0xffffffff
957             || $self->writeLocalHeaderRelativeOffset() > 0xffffffff;
958              
959 409   66     1690 $self->{'zip64'} ||= $zip64;
960              
961 409         909 my $versionMadeBy = $self->versionMadeBy();
962 409         940 my $versionNeededToExtract = $self->versionNeededToExtract();
963 409         815 my $compressedSize = $self->_writeOffset();
964 409         711 my $uncompressedSize = $self->uncompressedSize();
965 409         675 my $localHeaderRelativeOffset = $self->writeLocalHeaderRelativeOffset();
966 409         898 my $cdExtraField = $self->cdExtraField();
967              
968 409 100       784 if (!$zip64) {
969             # no-op
970             }
971             else {
972 120         166 return _zip64NotSupported() unless ZIP64_SUPPORTED;
973              
974 120 100       231 $versionNeededToExtract = 45 if ($versionNeededToExtract < 45);
975              
976 120         228 my $extraFieldFormat = '';
977 120         184 my @extraFieldValues = ();
978 120         171 my $extraFieldSize = 0;
979 120 50       214 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 120 50       232 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 120 50 33     501 if ( $localHeaderRelativeOffset > 0xffffffff
993             || @extraFieldValues == 0) {
994 120         201 $extraFieldFormat .= 'Q< ';
995 120         187 push(@extraFieldValues, $localHeaderRelativeOffset);
996 120         167 $extraFieldSize += 8;
997 120         160 $localHeaderRelativeOffset = 0xffffffff;
998             }
999              
1000             $cdExtraField .=
1001 120         411 pack("S< S< $extraFieldFormat",
1002             0x0001, $extraFieldSize,
1003             @extraFieldValues);
1004             }
1005              
1006 409         829 my $fileNameLength = length($self->fileNameAsBytes());
1007 409         632 my $extraFieldLength = length($cdExtraField);
1008 409         906 my $fileCommentLength = length($self->fileComment());
1009              
1010 409         630 my $sigData =
1011             pack(SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE);
1012 409 50       1023 $self->_print($fh, $sigData)
1013             or return _ioError("writing central directory header signature");
1014              
1015 409         3529 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 409 50       1277 $self->_print($fh, $header)
1035             or return _ioError("writing central directory header");
1036              
1037 409 50       3259 if ($fileNameLength) {
1038 409 50       805 $self->_print($fh, $self->fileNameAsBytes())
1039             or return _ioError("writing central directory header signature");
1040             }
1041 409 100       3111 if ($extraFieldLength) {
1042 124 50       291 $self->_print($fh, $cdExtraField)
1043             or return _ioError("writing central directory extra field");
1044             }
1045 409 50       1408 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 409         764 $self->{'versionNeededToExtract'} = $versionNeededToExtract;
1055 409         785 $self->{'compressedSize'} = $self->_writeOffset();
1056              
1057             return
1058 409         1447 (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 295     295   471 my $self = shift;
1074 295         413 my $fh = shift;
1075              
1076 295         388 my $descriptor;
1077 295 100       630 if (! $self->zip64()) {
1078 203         447 $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 92         125 return _zip64NotSupported() unless ZIP64_SUPPORTED;
1087              
1088 92         190 $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 295 50       888 $self->_print($fh, $descriptor)
1097             or return _ioError("writing data descriptor");
1098              
1099 295         2553 return (AZ_OK, length($descriptor));
1100             }
1101              
1102             sub readChunk {
1103 442     442 1 757 my $self = shift;
1104 442 50       963 my $chunkSize = (ref($_[0]) eq 'HASH') ? $_[0]->{chunkSize} : $_[0];
1105              
1106 442 100       980 if ($self->readIsDone()) {
1107 12         39 $self->endRead();
1108 12         32 my $dummy = '';
1109 12         39 return (\$dummy, AZ_STREAM_END);
1110             }
1111              
1112 430 50       1116 $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
1113 430 100       816 $chunkSize = $self->_readDataRemaining()
1114             if $chunkSize > $self->_readDataRemaining();
1115              
1116 430         900 my $buffer = '';
1117 430         619 my $outputRef;
1118 430         1783 my ($bytesRead, $status) = $self->_readRawChunk(\$buffer, $chunkSize);
1119 430 50       1026 return (\$buffer, $status) unless $status == AZ_OK;
1120              
1121 430 100 66     1952 $buffer && $self->isEncrypted and $buffer = $self->_decode($buffer);
1122 430         826 $self->{'readDataRemaining'} -= $bytesRead;
1123 430         680 $self->{'readOffset'} += $bytesRead;
1124              
1125 430 100       943 if ($self->compressionMethod() == COMPRESSION_STORED) {
1126 358         1327 $self->{'crc32'} = $self->computeCRC32($buffer, $self->{'crc32'});
1127             }
1128              
1129 430         936 ($outputRef, $status) = &{$self->{'chunkHandler'}}($self, \$buffer);
  430         947  
1130 430         973 $self->{'writeOffset'} += length($$outputRef);
1131              
1132 430 100       938 $self->endRead()
1133             if $self->readIsDone();
1134              
1135 430         1180 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 305     305   659 my ($self, $dataRef) = @_;
1156 305         734 return ($dataRef, AZ_OK);
1157             }
1158              
1159             # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
1160             sub _deflateChunk {
1161 110     110   225 my ($self, $buffer) = @_;
1162 110         295 my ($status) = $self->_deflater()->deflate($buffer, my $out);
1163              
1164 110 100       378 if ($self->_readDataRemaining() == 0) {
    50          
1165 106         170 my $extraOutput;
1166 106         192 ($status) = $self->_deflater()->flush($extraOutput);
1167 106         635 $out .= $extraOutput;
1168 106         408 $self->endRead();
1169 106         511 return (\$out, AZ_STREAM_END);
1170             } elsif ($status == Z_OK) {
1171 4         44 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   33 my ($self, $buffer) = @_;
1183 15         70 my ($status) = $self->_inflater()->inflate($buffer, my $out);
1184 15         41 my $retval;
1185 15 100       55 $self->endRead() unless $status == Z_OK;
1186 15 50 66     63 if ($status == Z_OK || $status == Z_STREAM_END) {
1187 15 100       343 $retval = ($status == Z_STREAM_END) ? AZ_STREAM_END : AZ_OK;
1188 15         162 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 519     519 1 1024 my $self = shift;
1198 519         713 my $status;
1199              
1200             # set to trap init errors
1201 519         2335 $self->{'chunkHandler'} = $self->can('_noChunk');
1202              
1203             # Work around WinZip bug with 0-length DEFLATED files
1204 519 100       1082 $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 519 100       1234 $self->{'crc32'} = 0
1209             if ($self->compressionMethod() == COMPRESSION_STORED);
1210              
1211             # These are the only combinations of methods we deal with right now.
1212 519 100 100     902 if ( $self->compressionMethod() == COMPRESSION_STORED
    100 100        
    50          
1213             and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED) {
1214 106         404 ($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 106 50       79447 return _error('deflateInit error:', $status)
1221             unless $status == Z_OK;
1222 106         1066 $self->{'chunkHandler'} = $self->can('_deflateChunk');
1223             } elsif ($self->compressionMethod() == COMPRESSION_DEFLATED
1224             and $self->desiredCompressionMethod() == COMPRESSION_STORED) {
1225 21         95 ($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 21 50       9043 return _error('inflateInit error:', $status)
1231             unless $status == Z_OK;
1232 21         367 $self->{'chunkHandler'} = $self->can('_inflateChunk');
1233             } elsif ($self->compressionMethod() == $self->desiredCompressionMethod()) {
1234 392         1130 $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 519 100       1211 $self->{'readDataRemaining'} =
1244             ($self->compressionMethod() == COMPRESSION_STORED)
1245             ? $self->uncompressedSize()
1246             : $self->compressedSize();
1247 519         1014 $self->{'dataEnded'} = 0;
1248 519         933 $self->{'readOffset'} = 0;
1249              
1250 519         1896 return AZ_OK;
1251             }
1252              
1253             sub endRead {
1254 1132     1132 1 1911 my $self = shift;
1255 1132         1802 delete $self->{'inflater'};
1256 1132         3905 delete $self->{'deflater'};
1257 1132         1756 $self->{'dataEnded'} = 1;
1258 1132         1531 $self->{'readDataRemaining'} = 0;
1259 1132         1867 return AZ_OK;
1260             }
1261              
1262             sub readIsDone {
1263 872     872 1 1289 my $self = shift;
1264 872   100     1670 return ($self->_dataEnded() or !$self->_readDataRemaining());
1265             }
1266              
1267             sub contents {
1268 18     18 1 10313 my $self = shift;
1269 18         38 my $newContents = shift;
1270              
1271 18 100       74 if (defined($newContents)) {
1272              
1273             # Change our type and ensure that succeeded to avoid
1274             # endless recursion
1275 6         123 $self->_become('Archive::Zip::StringMember');
1276 6 0       66 $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         85 my $retval =
1284             $self->contents(pack('C0a*', $newContents)); # in case of Unicode
1285              
1286 6 50       61 return wantarray ? ($retval, AZ_OK) : $retval;
1287             } else {
1288 12         33 my $oldCompression =
1289             $self->desiredCompressionMethod(COMPRESSION_STORED);
1290 12         55 my $status = $self->rewindData(@_);
1291 12 50       46 if ($status != AZ_OK) {
1292 0         0 $self->endRead();
1293 0 0       0 return wantarray ? (undef, $status) : undef;
1294             }
1295 12         44 my $retval = '';
1296 12         42 while ($status == AZ_OK) {
1297 23         36 my $ref;
1298 23         102 ($ref, $status) = $self->readChunk($self->_readDataRemaining());
1299              
1300             # did we get it in one chunk?
1301 23 100       62 if (length($$ref) == $self->uncompressedSize()) {
1302 11         41 $retval = $$ref;
1303             } else {
1304 12         37 $retval .= $$ref
1305             }
1306             }
1307 12         40 $self->desiredCompressionMethod($oldCompression);
1308 12         36 $self->endRead();
1309 12 50       32 $status = AZ_OK if $status == AZ_STREAM_END;
1310 12 50       26 $retval = undef unless $status == AZ_OK;
1311 12 100       71 return wantarray ? ($retval, $status) : $retval;
1312             }
1313             }
1314              
1315             sub extractToFileHandle {
1316 88     88 1 168 my $self = shift;
1317             # This can be the link name when "extracting" symbolic links
1318 88 50       292 my $fhOrName = (ref($_[0]) eq 'HASH') ? shift->{fileHandle} : shift;
1319 88 100       334 _binmode($fhOrName) if ref($fhOrName);
1320 88         820 my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
1321 88         309 my $status = $self->rewindData(@_);
1322 88 50       406 $status = $self->_writeData($fhOrName) if $status == AZ_OK;
1323 88         253 $self->desiredCompressionMethod($oldCompression);
1324 88         237 $self->endRead();
1325 88         265 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 409     409   825 my $self = shift;
1334 409         656 my $fh = shift;
1335 409         700 my $fhIsSeekable = shift;
1336 409         575 my $offset = shift;
1337 409         653 my $adz64m = shift; # $archiveDesiredZip64Mode
1338              
1339 409 50       1464 return _error("no member name given for $self")
1340             if $self->fileName() eq '';
1341              
1342 409         1242 $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 409         1265 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 409   100     1798 my $shouldWriteDataDescriptor =
1357             ($headerFieldsUnknown and not $fhIsSeekable);
1358              
1359 409 100       1068 $self->hasDataDescriptor(1)
1360             if ($shouldWriteDataDescriptor);
1361              
1362             # Determine whether to write zip64 format
1363 409   66     1713 my $zip64 = $adz64m == ZIP64_HEADERS
1364             || $self->desiredZip64Mode() == ZIP64_HEADERS
1365             || $self->uncompressedSize() > 0xffffffff;
1366              
1367 409   66     2311 $self->{'zip64'} ||= $zip64;
1368              
1369 409         1108 $self->{'writeOffset'} = 0;
1370              
1371 409         2030 my $status = $self->rewindData();
1372 409 50       986 return $status if $status != AZ_OK;
1373              
1374 409         572 my $memberSize;
1375 409         1545 ($status, $memberSize) = $self->_writeLocalFileHeader($fh);
1376 409 50       903 return $status if $status != AZ_OK;
1377              
1378 409         1293 $status = $self->_writeData($fh);
1379 409 50       1010 return $status if $status != AZ_OK;
1380 409         881 $memberSize += $self->_writeOffset();
1381              
1382 409 100       827 if ($self->hasDataDescriptor()) {
    100          
1383 295         412 my $ddSize;
1384 295         4992 ($status, $ddSize) = $self->_writeDataDescriptor($fh);
1385 295         490 $memberSize += $ddSize;
1386             } elsif ($headerFieldsUnknown) {
1387 23         101 $status = $self->_refreshLocalFileHeader($fh);
1388             }
1389 409 50       825 return $status if $status != AZ_OK;
1390              
1391 409         1414 return ($status, $memberSize);
1392             }
1393              
1394             # Copy my (possibly compressed) data to given file handle.
1395             # Returns C on success
1396             sub _writeData {
1397 497     497   825 my $self = shift;
1398 497         709 my $fhOrName = shift;
1399              
1400 497 100 100     1258 if ($self->isSymbolicLink() && OS_SUPPORTS_SYMLINK) {
1401 5         8 my $chunkSize = $Archive::Zip::ChunkSize;
1402 5         20 my ($outRef, $status) = $self->readChunk($chunkSize);
1403 5 100       119 symlink($$outRef, $fhOrName)
1404             or return _ioError("creating symbolic link");
1405             } else {
1406 492 100       1037 return AZ_OK if ($self->uncompressedSize() == 0);
1407 398         593 my $status;
1408 398         939 my $chunkSize = $Archive::Zip::ChunkSize;
1409 398         1236 while ($self->_readDataRemaining() > 0) {
1410 406         609 my $outRef;
1411 406         1189 ($outRef, $status) = $self->readChunk($chunkSize);
1412 406 50 66     1708 return $status if ($status != AZ_OK and $status != AZ_STREAM_END);
1413              
1414 406 100       1006 if (length($$outRef) > 0) {
1415 402 50       1290 $self->_print($fhOrName, $$outRef)
1416             or return _ioError("write error during copy");
1417             }
1418              
1419 406 100       5469 last if $status == AZ_STREAM_END;
1420             }
1421             }
1422 401         1010 return AZ_OK;
1423             }
1424              
1425             # Return true if I depend on the named file
1426             sub _usesFileNamed {
1427 109     109   344 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   241 my ($c, $b) = @_;
1505 194         281 return ($crct[($c ^ $b) & 0xff] ^ ($c >> 8));
1506             } # _crc32
1507              
1508             sub _revbe {
1509 35840     35840   40012 my $w = shift;
1510 35840         59232 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   14563 use integer;
  28         410  
  28         156  
1518 97     97   100 my $c = shift; # signed int
1519 97         120 $keys[0] = _crc32($keys[0], $c);
1520 97         132 $keys[1] = (($keys[1] + ($keys[0] & 0xff)) * 0x08088405 + 1) & 0xffffffff;
1521 97         105 my $keyshift = $keys[1] >> 24;
1522 97         123 $keys[2] = _crc32($keys[2], $keyshift);
1523             } # _update_keys
1524              
1525             sub _zdecode ($) {
1526 84     84   90 my $c = shift;
1527 84         137 my $t = ($keys[2] & 0xffff) | 2;
1528 84         154 _update_keys($c ^= ((($t * ($t ^ 1)) >> 8) & 0xff));
1529 84         119 return $c;
1530             } # _zdecode
1531              
1532             sub _decode {
1533 3     3   8 my $self = shift;
1534 3         5 my $buff = shift;
1535              
1536 3 50       8 $self->isEncrypted or return $buff;
1537              
1538 3         8 my $pass = $self->password;
1539 3 50       8 defined $pass or return "";
1540              
1541 3         9 @keys = (0x12345678, 0x23456789, 0x34567890);
1542 3         16 _update_keys($_) for unpack "C*", $pass;
1543              
1544             # DDumper { uk => [ @keys ] };
1545              
1546 3         18 my $head = substr $buff, 0, 12, "";
1547 3         11 my @head = map { _zdecode($_) } unpack "C*", $head;
  36         46  
1548             my $x =
1549             $self->{externalFileAttributes}
1550             ? ($self->{lastModFileDateTime} >> 8) & 0xff
1551 3 50       15 : $self->{crc32} >> 24;
1552 3 100       11 $head[-1] == $x or return ""; # Password fail
1553              
1554             # Worth checking ...
1555 2         27 $self->{crc32c} = (unpack LOCAL_FILE_HEADER_FORMAT, pack "C*", @head)[3];
1556              
1557             # DHexDump ($buff);
1558 2         9 $buff = pack "C*" => map { _zdecode($_) } unpack "C*" => $buff;
  48         57  
1559              
1560             # DHexDump ($buff);
1561 2         8 return $buff;
1562             } # _decode
1563              
1564             1;