File Coverage

blib/lib/Archive/Zip/Member.pm
Criterion Covered Total %
statement 588 661 88.9
branch 222 318 69.8
condition 75 116 64.6
subroutine 85 92 92.3
pod 44 47 93.6
total 1014 1234 82.1


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