File Coverage

blib/lib/Archive/Zip/Member.pm
Criterion Covered Total %
statement 362 405 89.4
branch 107 178 60.1
condition 27 45 60.0
subroutine 79 84 94.0
pod 41 41 100.0
total 616 753 81.8


line stmt bran cond sub pod time code
1             package Archive::Zip::Member;
2              
3             # A generic membet of an archive
4              
5 6     6   114 use strict;
  6         58  
  6         100  
6 6     6   239 use vars qw( $VERSION @ISA );
  6         75  
  6         100  
7              
8             BEGIN {
9 6     6   81     $VERSION = '1.18';
10 6         81     @ISA = qw( Archive::Zip );
11             }
12              
13 6         119 use Archive::Zip qw(
14             :CONSTANTS
15             :MISC_CONSTANTS
16             :ERROR_CODES
17             :PKZIP_CONSTANTS
18             :UTILITY_METHODS
19 6     6   100 );
  6         55  
20              
21 6     6   243 use Time::Local ();
  6         61  
  6         61  
22 6     6   102 use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
  6         54  
  6         161  
23 6     6   102 use File::Path;
  6         53  
  6         102  
24 6     6   108 use File::Basename;
  6         57  
  6         103  
25              
26 6     6   102 use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
  6         88  
  6         90  
27 6     6   100 use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
  6         56  
  6         77  
28 6     6   90 use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
  6         58  
  6         104  
29 6     6   110 use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
  6         63  
  6         77  
30              
31             # Unix perms for default creation of files/dirs.
32 6     6   150 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
  6         56  
  6         74  
33 6     6   90 use constant DEFAULT_FILE_PERMISSIONS => 0100666;
  6         55  
  6         69  
34 6     6   129 use constant DIRECTORY_ATTRIB => 040000;
  6         107  
  6         87  
35 6     6   92 use constant FILE_ATTRIB => 0100000;
  6         56  
  6         70  
36              
37             # Returns self if successful, else undef
38             # Assumes that fh is positioned at beginning of central directory file header.
39             # Leaves fh positioned immediately after file header or EOCD signature.
40             sub _newFromZipFile {
41 6     6   55     my $class = shift;
42 6         157     my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
43 6         65     return $self;
44             }
45              
46             sub newFromString {
47 4     4 1 74     my $class = shift;
48 4         3021     my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
49 4         55     return $self;
50             }
51              
52             sub newFromFile {
53 64     64 1 665     my $class = shift;
54 64         1849     my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
55 64         852     return $self;
56             }
57              
58             sub newDirectoryNamed {
59 2     2 1 28     my $class = shift;
60 2         248     my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
61 2         25     return $self;
62             }
63              
64             sub new {
65 76     76 1 698     my $class = shift;
66 76         7088     my $self = {
67                     'lastModFileDateTime' => 0,
68                     'fileAttributeFormat' => FA_UNIX,
69                     'versionMadeBy' => 20,
70                     'versionNeededToExtract' => 20,
71                     'bitFlag' => 0,
72                     'compressionMethod' => COMPRESSION_STORED,
73                     'desiredCompressionMethod' => COMPRESSION_STORED,
74                     'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
75                     'internalFileAttributes' => 0,
76                     'externalFileAttributes' => 0, # set later
77                     'fileName' => '',
78                     'cdExtraField' => '',
79                     'localExtraField' => '',
80                     'fileComment' => '',
81                     'crc32' => 0,
82                     'compressedSize' => 0,
83                     'uncompressedSize' => 0,
84                     @_
85                 };
86 76         2077     bless( $self, $class );
87 76         1723     $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
88 76         1293     return $self;
89             }
90              
91             sub _becomeDirectoryIfNecessary {
92 5     5   44     my $self = shift;
93 5 100       57     $self->_become(DIRECTORYMEMBERCLASS)
94                   if $self->isDirectory();
95 5         55     return $self;
96             }
97              
98             # Morph into given class (do whatever cleanup I need to do)
99             sub _become {
100 3     3   182     return bless( $_[0], $_[1] );
101             }
102              
103             sub versionMadeBy {
104 71     71 1 955     shift->{'versionMadeBy'};
105             }
106              
107             sub fileAttributeFormat {
108 71 50   71 1 895     ( $#_ > 0 )
109                   ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
110                   : $_[0]->{'fileAttributeFormat'};
111             }
112              
113             sub versionNeededToExtract {
114 168     168 1 1961     shift->{'versionNeededToExtract'};
115             }
116              
117             sub bitFlag {
118 190     190 1 2613     shift->{'bitFlag'};
119             }
120              
121             sub compressionMethod {
122 545     545 1 8802     shift->{'compressionMethod'};
123             }
124              
125             sub desiredCompressionMethod {
126 456     456 1 7725     my $self = shift;
127 456         4681     my $newDesiredCompressionMethod = shift;
128 456         4410     my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
129 456 100       5179     if ( defined($newDesiredCompressionMethod) ) {
130 119         1261         $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
131 119 100       2147         if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) {
    100          
132 44         418             $self->{'desiredCompressionLevel'} = 0;
133                     }
134                     elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
135 74         697             $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
136                     }
137                 }
138 456         9045     return $oldDesiredCompressionMethod;
139             }
140              
141             sub desiredCompressionLevel {
142 19     19 1 346     my $self = shift;
143 19         159     my $newDesiredCompressionLevel = shift;
144 19         255     my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
145 19 50       537     if ( defined($newDesiredCompressionLevel) ) {
146 0         0         $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
147 0 0       0         $self->{'desiredCompressionMethod'} = (
148                         $newDesiredCompressionLevel
149                         ? COMPRESSION_DEFLATED
150                         : COMPRESSION_STORED
151                     );
152                 }
153 19         516     return $oldDesiredCompressionLevel;
154             }
155              
156             sub fileName {
157 1118     1118 1 13590     my $self = shift;
158 1118         10273     my $newName = shift;
159 1118 100       14552     if ($newName) {
160 77         967         $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
161 77         969         $self->{'fileName'} = $newName;
162                 }
163 1118         18936     return $self->{'fileName'};
164             }
165              
166             sub lastModFileDateTime {
167 231     231 1 2553     my $modTime = shift->{'lastModFileDateTime'};
168 231         3965     $modTime =~ m/^(\d+)$/; # untaint
169 231         4817     return $1;
170             }
171              
172             sub lastModTime {
173 61     61 1 834     my $self = shift;
174 61         899     return _dosToUnixTime( $self->lastModFileDateTime() );
175             }
176              
177             sub setLastModFileDateTimeFromUnix {
178 70     70 1 635     my $self = shift;
179 70         623     my $time_t = shift;
180 70         1212     $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
181             }
182              
183             sub internalFileAttributes {
184 153     153 1 1800     shift->{'internalFileAttributes'};
185             }
186              
187             sub externalFileAttributes {
188 71     71 1 822     shift->{'externalFileAttributes'};
189             }
190              
191             # Convert UNIX permissions into proper value for zip file
192             # NOT A METHOD!
193             sub _mapPermissionsFromUnix {
194 146     146   8873     my $perms = shift;
195 146         1780     return $perms << 16;
196              
197             # TODO: map MS-DOS perms too (RHSA?)
198             }
199              
200             # Convert ZIP permissions into Unix ones
201             #
202             # This was taken from Info-ZIP group's portable UnZip
203             # zipfile-extraction program, version 5.50.
204             # http://www.info-zip.org/pub/infozip/
205             #
206             # See the mapattr() function in unix/unix.c
207             # See the attribute format constants in unzpriv.h
208             #
209             # XXX Note that there's one situation that isn't implemented
210             # yet that depends on the "extra field."
211             sub _mapPermissionsToUnix {
212 149     149   1333     my $self = shift;
213              
214 149         1433     my $format = $self->{'fileAttributeFormat'};
215 149         2393     my $attribs = $self->{'externalFileAttributes'};
216              
217 149         2676     my $mode = 0;
218              
219 149 50       1544     if ( $format == FA_AMIGA ) {
220 0         0         $attribs = $attribs >> 17 & 7; # Amiga RWE bits
221 0         0         $mode = $attribs << 6 | $attribs << 3 | $attribs;
222 0         0         return $mode;
223                 }
224              
225 149 50       1378     if ( $format == FA_THEOS ) {
226 0         0         $attribs &= 0xF1FFFFFF;
227 0 0       0         if ( ( $attribs & 0xF0000000 ) != 0x40000000 ) {
228 0         0             $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
229                     }
230                     else {
231 0         0             $attribs &= 0x41FFFFFF; # leave directory bit as set
232                     }
233                 }
234              
235 149 50 33     2623     if ( $format == FA_UNIX
      33        
      33        
      33        
      33        
      33        
236                     || $format == FA_VAX_VMS
237                     || $format == FA_ACORN
238                     || $format == FA_ATARI_ST
239                     || $format == FA_BEOS
240                     || $format == FA_QDOS
241                     || $format == FA_TANDEM )
242                 {
243 149         1739         $mode = $attribs >> 16;
244 149 50 66     2692         return $mode if $mode != 0 or not $self->localExtraField;
245              
246             # warn("local extra field is: ", $self->localExtraField, "\n");
247              
248             # XXX This condition is not implemented
249             # I'm just including the comments from the info-zip section for now.
250              
251             # Some (non-Info-ZIP) implementations of Zip for Unix and
252             # VMS (and probably others ??) leave 0 in the upper 16-bit
253             # part of the external_file_attributes field. Instead, they
254             # store file permission attributes in some extra field.
255             # As a work-around, we search for the presence of one of
256             # these extra fields and fall back to the MSDOS compatible
257             # part of external_file_attributes if one of the known
258             # e.f. types has been detected.
259             # Later, we might implement extraction of the permission
260             # bits from the VMS extra field. But for now, the work-around
261             # should be sufficient to provide "readable" extracted files.
262             # (For ASI Unix e.f., an experimental remap from the e.f.
263             # mode value IS already provided!)
264                 }
265              
266             # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
267             # Unix attributes in the upper 16 bits of the external attributes
268             # field, just like Info-ZIP's Zip for Unix. We try to use that
269             # value, after a check for consistency with the MSDOS attribute
270             # bits (see below).
271 0 0       0     if ( $format == FA_MSDOS ) {
272 0         0         $mode = $attribs >> 16;
273                 }
274              
275             # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
276 0         0     $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
277              
278             # keep previous $mode setting when its "owner"
279             # part appears to be consistent with DOS attribute flags!
280 0 0       0     return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
281 0         0     $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
282 0         0     return $mode;
283             }
284              
285             sub unixFileAttributes {
286 149     149 1 2084     my $self = shift;
287 149         4233     my $oldPerms = $self->_mapPermissionsToUnix();
288 149 100       2521     if (@_) {
289 146         1321         my $perms = shift;
290 146 100       8428         if ( $self->isDirectory() ) {
291 4         34             $perms &= ~FILE_ATTRIB;
292 4         36             $perms |= DIRECTORY_ATTRIB;
293                     }
294                     else {
295 142         1343             $perms &= ~DIRECTORY_ATTRIB;
296 142         1644             $perms |= FILE_ATTRIB;
297                     }
298 146         1565         $self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
299                 }
300 149         1563     return $oldPerms;
301             }
302              
303             sub localExtraField {
304 315 50   315 1 6957     ( $#_ > 0 )
305                   ? ( $_[0]->{'localExtraField'} = $_[1] )
306                   : $_[0]->{'localExtraField'};
307             }
308              
309             sub cdExtraField {
310 142 50   142 1 1961     ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
311             }
312              
313             sub extraFields {
314 0     0 1 0     my $self = shift;
315 0         0     return $self->localExtraField() . $self->cdExtraField();
316             }
317              
318             sub fileComment {
319 142 50   142 1 1796     ( $#_ > 0 )
320                   ? ( $_[0]->{'fileComment'} = pack( 'C0a*', $_[1] ) )
321                   : $_[0]->{'fileComment'};
322             }
323              
324             sub hasDataDescriptor {
325 152     152 1 1363     my $self = shift;
326 152 100       1835     if (@_) {
327 8         87         my $shouldHave = shift;
328 8 50       177         if ($shouldHave) {
329 8         96             $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
330                     }
331                     else {
332 0         0             $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
333                     }
334                 }
335 152         1982     return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
336             }
337              
338             sub crc32 {
339 203     203 1 3652     shift->{'crc32'};
340             }
341              
342             sub crc32String {
343 1     1 1 106     sprintf( "%08x", shift->{'crc32'} );
344             }
345              
346             sub compressedSize {
347 161     161 1 2489     shift->{'compressedSize'};
348             }
349              
350             sub uncompressedSize {
351 531     531 1 7961     shift->{'uncompressedSize'};
352             }
353              
354             sub isEncrypted {
355 22     22 1 814     shift->bitFlag() & GPBF_ENCRYPTED_MASK;
356             }
357              
358             sub isTextFile {
359 73     73 1 828     my $self = shift;
360 73         991     my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
361 73 100       786     if (@_) {
362 64         693         my $flag = shift;
363 64         586         $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
364 64 100       683         $self->{'internalFileAttributes'} |=
365                       ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
366                 }
367 73         771     return $bit == IFA_TEXT_FILE;
368             }
369              
370             sub isBinaryFile {
371 9     9 1 227     my $self = shift;
372 9         152     my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
373 9 50       213     if (@_) {
374 0         0         my $flag = shift;
375 0         0         $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
376 0 0       0         $self->{'internalFileAttributes'} |=
377                       ( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
378                 }
379 9         105     return $bit == IFA_BINARY_FILE;
380             }
381              
382             sub extractToFileNamed {
383 11     11 1 572     my $self = shift;
384 11         288     my $name = shift; # local FS name
385 11 50       748     return _error("encryption unsupported") if $self->isEncrypted();
386 11         1017     mkpath( dirname($name) ); # croaks on error
387 11         10112     my ( $status, $fh ) = _newFileHandle( $name, 'w' );
388 11 50       564     return _ioError("Can't open file $name for write") unless $status;
389 11         805     my $retval = $self->extractToFileHandle($fh);
390 11         415     $fh->close();
391 11         2475     utime( $self->lastModTime(), $self->lastModTime(), $name );
392 11         228     return $retval;
393             }
394              
395             sub isDirectory {
396 140     140 1 1450     return 0;
397             }
398              
399             sub externalFileName {
400 0     0 1 0     return undef;
401             }
402              
403             # The following are used when copying data
404             sub _writeOffset {
405 267     267   3285     shift->{'writeOffset'};
406             }
407              
408             sub _readOffset {
409 29     29   701     shift->{'readOffset'};
410             }
411              
412             sub writeLocalHeaderRelativeOffset {
413 97     97 1 1943     shift->{'writeLocalHeaderRelativeOffset'};
414             }
415              
416 0     0 1 0 sub wasWritten { shift->{'wasWritten'} }
417              
418             sub _dataEnded {
419 154     154   2364     shift->{'dataEnded'};
420             }
421              
422             sub _readDataRemaining {
423 407     407   7231     shift->{'readDataRemaining'};
424             }
425              
426             sub _inflater {
427 2     2   84     shift->{'inflater'};
428             }
429              
430             sub _deflater {
431 38     38   714     shift->{'deflater'};
432             }
433              
434             # Return the total size of my local header
435             sub _localHeaderSize {
436 71     71   648     my $self = shift;
437 71         799     return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
438                   length( $self->fileName() ) + length( $self->localExtraField() );
439             }
440              
441             # Return the total size of my CD header
442             sub _centralDirectoryHeaderSize {
443 71     71   687     my $self = shift;
444 71         714     return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
445                   length( $self->fileName() ) + length( $self->cdExtraField() ) +
446                   length( $self->fileComment() );
447             }
448              
449             # DOS date/time format
450             # 0-4 (5) Second divided by 2
451             # 5-10 (6) Minute (0-59)
452             # 11-15 (5) Hour (0-23 on a 24-hour clock)
453             # 16-20 (5) Day of the month (1-31)
454             # 21-24 (4) Month (1 = January, 2 = February, etc.)
455             # 25-31 (7) Year offset from 1980 (add 1980 to get actual year)
456              
457             # Convert DOS date/time format to unix time_t format
458             # NOT AN OBJECT METHOD!
459             sub _dosToUnixTime {
460 77     77   1538     my $dt = shift;
461 77 50       863     return time() unless defined($dt);
462              
463 77         1514     my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
464 77         3602     my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
465 77         726     my $mday = ( ( $dt >> 16 ) & 0x1f );
466              
467 77         952     my $hour = ( ( $dt >> 11 ) & 0x1f );
468 77         3944     my $min = ( ( $dt >> 5 ) & 0x3f );
469 77         1348     my $sec = ( ( $dt << 1 ) & 0x3e );
470              
471             # catch errors
472                 my $time_t =
473 77         1466       eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
  77         2955  
474 77 50       32111     return time() if ($@);
475 77         1950     return $time_t;
476             }
477              
478             # Note, this isn't exactly UTC 1980, it's 1980 + 12 hours and 1
479             # minute so that nothing timezoney can muck us up.
480             my $safe_epoch = 315576060;
481              
482             # convert a unix time to DOS date/time
483             # NOT AN OBJECT METHOD!
484             sub _unixToDosTime {
485 87     87   1151     my $time_t = shift;
486 87 100       2668     unless ($time_t) {
487 1         47         _error("Tried to add member with zero or undef value for time");
488 1         10         $time_t = $safe_epoch;
489                 }
490 87 50       907     if ( $time_t < $safe_epoch ) {
491 0         0         _ioError("Unsupported date before 1980 encountered, moving to 1980");
492 0         0         $time_t = $safe_epoch;
493                 }
494 87         1998     my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
495 87         818     my $dt = 0;
496 87         778     $dt += ( $sec >> 1 );
497 87         757     $dt += ( $min << 5 );
498 87         738     $dt += ( $hour << 11 );
499 87         840     $dt += ( $mday << 16 );
500 87         772     $dt += ( ( $mon + 1 ) << 21 );
501 87         832     $dt += ( ( $year - 80 ) << 25 );
502 87         1066     return $dt;
503             }
504              
505             # Write my local header to a file handle.
506             # Stores the offset to the start of the header in my
507             # writeLocalHeaderRelativeOffset member.
508             # Returns AZ_OK on success.
509             sub _writeLocalFileHeader {
510 71     71   654     my $self = shift;
511 71         616     my $fh = shift;
512              
513 71         1090     my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
514 71 50       938     $fh->print($signatureData)
515                   or return _ioError("writing local header signature");
516              
517 71         2892     my $header = pack(
518                     LOCAL_FILE_HEADER_FORMAT,
519                     $self->versionNeededToExtract(),
520                     $self->bitFlag(),
521                     $self->desiredCompressionMethod(),
522                     $self->lastModFileDateTime(),
523                     $self->crc32(),
524                     $self->compressedSize(), # may need to be re-written later
525                     $self->uncompressedSize(),
526                     length( $self->fileName() ),
527                     length( $self->localExtraField() )
528                 );
529              
530 71 50       2724     $fh->print($header) or return _ioError("writing local header");
531 71 50       2091     if ( $self->fileName() ) {
532 71 50       753         $fh->print( $self->fileName() )
533                       or return _ioError("writing local header filename");
534                 }
535 71 50       8857     if ( $self->localExtraField() ) {
536 0 0       0         $fh->print( $self->localExtraField() )
537                       or return _ioError("writing local extra field");
538                 }
539              
540 71         1151     return AZ_OK;
541             }
542              
543             sub _writeCentralDirectoryFileHeader {
544 71     71   608     my $self = shift;
545 71         583     my $fh = shift;
546              
547 71         902     my $sigData =
548                   pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
549 71 50       917     $fh->print($sigData)
550                   or return _ioError("writing central directory header signature");
551              
552 71         1642     my $fileNameLength = length( $self->fileName() );
553 71         978     my $extraFieldLength = length( $self->cdExtraField() );
554 71         823     my $fileCommentLength = length( $self->fileComment() );
555              
556 71         1157     my $header = pack(
557                     CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
558                     $self->versionMadeBy(),
559                     $self->fileAttributeFormat(),
560                     $self->versionNeededToExtract(),
561                     $self->bitFlag(),
562                     $self->desiredCompressionMethod(),
563                     $self->lastModFileDateTime(),
564                     $self->crc32(), # these three fields should have been updated
565                     $self->_writeOffset(), # by writing the data stream out
566                     $self->uncompressedSize(), #
567                     $fileNameLength,
568                     $extraFieldLength,
569                     $fileCommentLength,
570                     0, # {'diskNumberStart'},
571                     $self->internalFileAttributes(),
572                     $self->externalFileAttributes(),
573                     $self->writeLocalHeaderRelativeOffset()
574                 );
575              
576 71 50       885     $fh->print($header)
577                   or return _ioError("writing central directory header");
578 71 50       1561     if ($fileNameLength) {
579 71 50       737         $fh->print( $self->fileName() )
580                       or return _ioError("writing central directory header signature");
581                 }
582 71 50       1914     if ($extraFieldLength) {
583 0 0       0         $fh->print( $self->cdExtraField() )
584                       or return _ioError("writing central directory extra field");
585                 }
586 71 50       668     if ($fileCommentLength) {
587 0 0       0         $fh->print( $self->fileComment() )
588                       or return _ioError("writing central directory file comment");
589                 }
590              
591 71         1174     return AZ_OK;
592             }
593              
594             # This writes a data descriptor to the given file handle.
595             # Assumes that crc32, writeOffset, and uncompressedSize are
596             # set correctly (they should be after a write).
597             # Further, the local file header should have the
598             # GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
599             sub _writeDataDescriptor {
600 31     31   444     my $self = shift;
601 31         259     my $fh = shift;
602 31         338     my $header = pack(
603                     SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
604                     DATA_DESCRIPTOR_SIGNATURE,
605                     $self->crc32(),
606                     $self->_writeOffset(), # compressed size
607                     $self->uncompressedSize()
608                 );
609              
610 31 50       353     $fh->print($header)
611                   or return _ioError("writing data descriptor");
612 31         2835     return AZ_OK;
613             }
614              
615             # Re-writes the local file header with new crc32 and compressedSize fields.
616             # To be called after writing the data stream.
617             # Assumes that filename and extraField sizes didn't change since last written.
618             sub _refreshLocalFileHeader {
619 26     26   225     my $self = shift;
620 26         326     my $fh = shift;
621              
622 26         345     my $here = $fh->tell();
623 26 50       1074     $fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
624                     IO::Seekable::SEEK_SET )
625                   or return _ioError("seeking to rewrite local header");
626              
627 26         3584     my $header = pack(
628                     LOCAL_FILE_HEADER_FORMAT,
629                     $self->versionNeededToExtract(),
630                     $self->bitFlag(),
631                     $self->desiredCompressionMethod(),
632                     $self->lastModFileDateTime(),
633                     $self->crc32(),
634                     $self->_writeOffset(), # compressed size
635                     $self->uncompressedSize(),
636                     length( $self->fileName() ),
637                     length( $self->localExtraField() )
638                 );
639              
640 26 50       436     $fh->print($header)
641                   or return _ioError("re-writing local header");
642 26 50       675     $fh->seek( $here, IO::Seekable::SEEK_SET )
643                   or return _ioError("seeking after rewrite of local header");
644              
645 26         1546     return AZ_OK;
646             }
647              
648             sub readChunk {
649 81     81 1 840     my ( $self, $chunkSize ) = @_;
650              
651 81 100       1417     if ( $self->readIsDone() ) {
652 8         90         $self->endRead();
653 8         77         my $dummy = '';
654 8         98         return ( \$dummy, AZ_STREAM_END );
655                 }
656              
657 73 50       758     $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
658 73 100       760     $chunkSize = $self->_readDataRemaining()
659                   if $chunkSize > $self->_readDataRemaining();
660              
661 73         756     my $buffer = '';
662 73         606     my $outputRef;
663 73         1758     my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
664 73 50       1021     return ( \$buffer, $status ) unless $status == AZ_OK;
665              
666 73         786     $self->{'readDataRemaining'} -= $bytesRead;
667 73         749     $self->{'readOffset'} += $bytesRead;
668              
669 73 100       1327     if ( $self->compressionMethod() == COMPRESSION_STORED ) {
670 62         1673         $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
671                 }
672              
673 73         684     ( $outputRef, $status ) = &{ $self->{'chunkHandler'} }( $self, \$buffer );
  73         1476  
674 73         779     $self->{'writeOffset'} += length($$outputRef);
675              
676 73 100       807     $self->endRead()
677                   if $self->readIsDone();
678              
679 73         878     return ( $outputRef, $status );
680             }
681              
682             # Read the next raw chunk of my data. Subclasses MUST implement.
683             # my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
684             sub _readRawChunk {
685 0     0   0     my $self = shift;
686 0         0     return $self->_subclassResponsibility();
687             }
688              
689             # A place holder to catch rewindData errors if someone ignores
690             # the error code.
691             sub _noChunk {
692 0     0   0     my $self = shift;
693 0         0     return ( \undef, _error("trying to copy chunk when init failed") );
694             }
695              
696             # Basically a no-op so that I can have a consistent interface.
697             # ( $outputRef, $status) = $self->_copyChunk( \$buffer );
698             sub _copyChunk {
699 52     52   475     my ( $self, $dataRef ) = @_;
700 52         564     return ( $dataRef, AZ_OK );
701             }
702              
703             # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
704             sub _deflateChunk {
705 19     19   246     my ( $self, $buffer ) = @_;
706 19         282     my ( $out, $status ) = $self->_deflater()->deflate($buffer);
707              
708 19 50       2380     if ( $self->_readDataRemaining() == 0 ) {
    0          
709 19         159         my $extraOutput;
710 19         184         ( $extraOutput, $status ) = $self->_deflater()->flush();
711 19         2921         $out .= $extraOutput;
712 19         794         $self->endRead();
713 19         542         return ( \$out, AZ_STREAM_END );
714                 }
715                 elsif ( $status == Z_OK ) {
716 0         0         return ( \$out, AZ_OK );
717                 }
718                 else {
719 0         0         $self->endRead();
720 0         0         my $retval = _error( 'deflate error', $status );
721 0         0         my $dummy = '';
722 0         0         return ( \$dummy, $retval );
723                 }
724             }
725              
726             # ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
727             sub _inflateChunk {
728 2     2   72     my ( $self, $buffer ) = @_;
729 2         93     my ( $out, $status ) = $self->_inflater()->inflate($buffer);
730 2         340     my $retval;
731 2 50       29     $self->endRead() unless $status == Z_OK;
732 2 50 33     30     if ( $status == Z_OK || $status == Z_STREAM_END ) {
733 2 50       24         $retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
734 2         56         return ( \$out, $retval );
735                 }
736                 else {
737 0         0         $retval = _error( 'inflate error', $status );
738 0         0         my $dummy = '';
739 0         0         return ( \$dummy, $retval );
740                 }
741             }
742              
743             sub rewindData {
744 90     90 1 835     my $self = shift;
745 90         855     my $status;
746              
747             # set to trap init errors
748 90         2005     $self->{'chunkHandler'} = $self->can('_noChunk');
749              
750             # Work around WinZip bug with 0-length DEFLATED files
751 90 100       1513     $self->desiredCompressionMethod(COMPRESSION_STORED)
752                   if $self->uncompressedSize() == 0;
753              
754             # assume that we're going to read the whole file, and compute the CRC anew.
755 90 100       1067     $self->{'crc32'} = 0
756                   if ( $self->compressionMethod() == COMPRESSION_STORED );
757              
758             # These are the only combinations of methods we deal with right now.
759 90 100 100     1124     if ( $self->compressionMethod() == COMPRESSION_STORED
    100 100        
    50          
760                     and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
761                 {
762 19         667         ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
763                         '-Level' => $self->desiredCompressionLevel(),
764                         '-WindowBits' => -MAX_WBITS(), # necessary magic
765                         '-Bufsize' => $Archive::Zip::ChunkSize,
766                         @_
767                     ); # pass additional options
768 19 50       60586         return _error( 'deflateInit error:', $status )
769                       unless $status == Z_OK;
770 19         477         $self->{'chunkHandler'} = $self->can('_deflateChunk');
771                 }
772                 elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
773                     and $self->desiredCompressionMethod() == COMPRESSION_STORED )
774                 {
775 2         446         ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
776                         '-WindowBits' => -MAX_WBITS(), # necessary magic
777                         '-Bufsize' => $Archive::Zip::ChunkSize,
778                         @_
779                     ); # pass additional options
780 2 50       4355         return _error( 'inflateInit error:', $status )
781                       unless $status == Z_OK;
782 2         179         $self->{'chunkHandler'} = $self->can('_inflateChunk');
783                 }
784                 elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() ) {
785 69         1249         $self->{'chunkHandler'} = $self->can('_copyChunk');
786                 }
787                 else {
788 0         0         return _error(
789                         sprintf(
790                             "Unsupported compression combination: read %d, write %d",
791                             $self->compressionMethod(),
792                             $self->desiredCompressionMethod()
793                         )
794                     );
795                 }
796              
797 90 100       1081     $self->{'readDataRemaining'} =
798                   ( $self->compressionMethod() == COMPRESSION_STORED )
799                   ? $self->uncompressedSize()
800                   : $self->compressedSize();
801 90         910     $self->{'dataEnded'} = 0;
802 90         952     $self->{'readOffset'} = 0;
803              
804 90         1008     return AZ_OK;
805             }
806              
807             sub endRead {
808 192     192 1 4442     my $self = shift;
809 192         1735     delete $self->{'inflater'};
810 192         5097     delete $self->{'deflater'};
811 192         1863     $self->{'dataEnded'} = 1;
812 192         1944     $self->{'readDataRemaining'} = 0;
813 192         2930     return AZ_OK;
814             }
815              
816             sub readIsDone {
817 154     154 1 1464     my $self = shift;
818 154   100     1920     return ( $self->_dataEnded() or !$self->_readDataRemaining() );
819             }
820              
821             sub contents {
822 5     5 1 460     my $self = shift;
823 5         107     my $newContents = shift;
824              
825 5 100       120     if ( defined($newContents) ) {
826              
827             # change our type and call the subclass contents method.
828 2         544         $self->_become(STRINGMEMBERCLASS);
829 2         190         return $self->contents( pack( 'C0a*', $newContents ) )
830                       ; # in case of Unicode
831                 }
832                 else {
833 3         34         my $oldCompression =
834                       $self->desiredCompressionMethod(COMPRESSION_STORED);
835 3         61         my $status = $self->rewindData(@_);
836 3 50       37         if ( $status != AZ_OK ) {
837 0         0             $self->endRead();
838 0         0             return $status;
839                     }
840 3         27         my $retval = '';
841 3         33         while ( $status == AZ_OK ) {
842 6         49             my $ref;
843 6         4061             ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
844              
845             # did we get it in one chunk?
846 6 100       113             if ( length($$ref) == $self->uncompressedSize() ) {
847 3         37                 $retval = $$ref;
848                         }
849 3         38             else { $retval .= $$ref }
850                     }
851 3         135         $self->desiredCompressionMethod($oldCompression);
852 3         40         $self->endRead();
853 3 50       35         $status = AZ_OK if $status == AZ_STREAM_END;
854 3 50       30         $retval = undef unless $status == AZ_OK;
855 3 50       61         return wantarray ? ( $retval, $status ) : $retval;
856                 }
857             }
858              
859             sub extractToFileHandle {
860 11     11 1 104     my $self = shift;
861 11 50       170     return _error("encryption unsupported") if $self->isEncrypted();
862 11         95     my $fh = shift;
863 11         125     _binmode($fh);
864 11         688     my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
865 11         841     my $status = $self->rewindData(@_);
866 11 50       492     $status = $self->_writeData($fh) if $status == AZ_OK;
867 11         144     $self->desiredCompressionMethod($oldCompression);
868 11         116     $self->endRead();
869 11         113     return $status;
870             }
871              
872             # write local header and data stream to file handle
873             sub _writeToFileHandle {
874 71     71   728     my $self = shift;
875 71         596     my $fh = shift;
876 71         672     my $fhIsSeekable = shift;
877 71         602     my $offset = shift;
878              
879 71 50       4184     return _error("no member name given for $self")
880                   unless $self->fileName();
881              
882 71         907     $self->{'writeLocalHeaderRelativeOffset'} = $offset;
883 71         667     $self->{'wasWritten'} = 0;
884              
885             # Determine if I need to write a data descriptor
886             # I need to do this if I can't refresh the header
887             # and I don't know compressed size or crc32 fields.
888 71   66     1150     my $headerFieldsUnknown = (
      66        
889                     ( $self->uncompressedSize() > 0 )
890                       and ($self->compressionMethod() == COMPRESSION_STORED
891                         or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
892                 );
893              
894 71   100     1425     my $shouldWriteDataDescriptor =
895                   ( $headerFieldsUnknown and not $fhIsSeekable );
896              
897 71 100       902     $self->hasDataDescriptor(1)
898                   if ($shouldWriteDataDescriptor);
899              
900 71         706     $self->{'writeOffset'} = 0;
901              
902 71         4244     my $status = $self->rewindData();
903 71 50       1472     ( $status = $self->_writeLocalFileHeader($fh) )
904                   if $status == AZ_OK;
905 71 50       1046     ( $status = $self->_writeData($fh) )
906                   if $status == AZ_OK;
907 71 50       760     if ( $status == AZ_OK ) {
908 71         1486         $self->{'wasWritten'} = 1;
909 71 100       1683         if ( $self->hasDataDescriptor() ) {
    100          
910 31         556             $status = $self->_writeDataDescriptor($fh);
911                     }
912                     elsif ($headerFieldsUnknown) {
913 26         342             $status = $self->_refreshLocalFileHeader($fh);
914                     }
915                 }
916              
917 71         1592     return $status;
918             }
919              
920             # Copy my (possibly compressed) data to given file handle.
921             # Returns C<AZ_OK> on success
922             sub _writeData {
923 82     82   736     my $self = shift;
924 82         772     my $writeFh = shift;
925              
926 82 100       878     return AZ_OK if ( $self->uncompressedSize() == 0 );
927 68         694     my $status;
928 68         690     my $chunkSize = $Archive::Zip::ChunkSize;
929 68         1377     while ( $self->_readDataRemaining() > 0 ) {
930 68         644         my $outRef;
931 68         1514         ( $outRef, $status ) = $self->readChunk($chunkSize);
932 68 50 66     1132         return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
933              
934 68 50       682         if ( length($$outRef) > 0 ) {
935 68 50       2088             $writeFh->print($$outRef)
936                           or return _ioError("write error during copy");
937                     }
938              
939 68 100       2283         last if $status == AZ_STREAM_END;
940                 }
941 68         2419     $self->{'compressedSize'} = $self->_writeOffset();
942 68         710     return AZ_OK;
943             }
944              
945             # Return true if I depend on the named file
946             sub _usesFileNamed {
947 34     34   518     return 0;
948             }
949              
950             1;
951