|
1 #! perl -w |
|
2 # $Revision: 1.39 $ |
|
3 |
|
4 # Copyright (c) 2000 Ned Konz. All rights reserved. This program is free |
|
5 # software; you can redistribute it and/or modify it under the same terms |
|
6 # as Perl itself. |
|
7 |
|
8 =head1 NAME |
|
9 |
|
10 Archive::Zip - Provide an interface to ZIP archive files. |
|
11 |
|
12 =head1 SYNOPSIS |
|
13 |
|
14 use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); |
|
15 |
|
16 my $zip = Archive::Zip->new(); |
|
17 my $member = $zip->addDirectory( 'dirname/' ); |
|
18 $member = $zip->addString( 'This is a test', 'stringMember.txt' ); |
|
19 $member->desiredCompressionMethod( COMPRESSION_DEFLATED ); |
|
20 $member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' ); |
|
21 |
|
22 die 'write error' if $zip->writeToFileNamed( 'someZip.zip' ) != AZ_OK; |
|
23 |
|
24 $zip = Archive::Zip->new(); |
|
25 die 'read error' if $zip->read( 'someZip.zip' ) != AZ_OK; |
|
26 |
|
27 $member = $zip->memberNamed( 'stringMember.txt' ); |
|
28 $member->desiredCompressionMethod( COMPRESSION_STORED ); |
|
29 |
|
30 die 'write error' if $zip->writeToFileNamed( 'someOtherZip.zip' ) != AZ_OK; |
|
31 |
|
32 =head1 DESCRIPTION |
|
33 |
|
34 The Archive::Zip module allows a Perl program to create, |
|
35 manipulate, read, and write Zip archive files. |
|
36 |
|
37 Zip archives can be created, or you can read from existing zip files. |
|
38 Once created, they can be written to files, streams, or strings. |
|
39 |
|
40 Members can be added, removed, extracted, replaced, rearranged, |
|
41 and enumerated. |
|
42 They can also be renamed or have their dates, comments, |
|
43 or other attributes queried or modified. |
|
44 Their data can be compressed or uncompressed as needed. |
|
45 Members can be created from members in existing Zip files, |
|
46 or from existing directories, files, or strings. |
|
47 |
|
48 This module uses the L<Compress::Zlib|Compress::Zlib> library |
|
49 to read and write the compressed streams inside the files. |
|
50 |
|
51 =head1 EXPORTS |
|
52 |
|
53 =over 4 |
|
54 |
|
55 =item :CONSTANTS |
|
56 |
|
57 Exports the following constants: |
|
58 |
|
59 FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK |
|
60 GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK |
|
61 COMPRESSION_STORED COMPRESSION_DEFLATED |
|
62 IFA_TEXT_FILE_MASK IFA_TEXT_FILE IFA_BINARY_FILE |
|
63 COMPRESSION_LEVEL_NONE |
|
64 COMPRESSION_LEVEL_DEFAULT |
|
65 COMPRESSION_LEVEL_FASTEST |
|
66 COMPRESSION_LEVEL_BEST_COMPRESSION |
|
67 |
|
68 =item :MISC_CONSTANTS |
|
69 |
|
70 Exports the following constants (only necessary for extending the module): |
|
71 |
|
72 FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST |
|
73 FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS |
|
74 GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK |
|
75 GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK |
|
76 GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK |
|
77 DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM |
|
78 DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST |
|
79 COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3 |
|
80 COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED |
|
81 COMPRESSION_DEFLATED_ENHANCED |
|
82 COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED |
|
83 |
|
84 =item :ERROR_CODES |
|
85 |
|
86 Explained below. Returned from most methods. |
|
87 |
|
88 AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR |
|
89 |
|
90 =back |
|
91 |
|
92 =head1 OBJECT MODEL |
|
93 |
|
94 =head2 Inheritance |
|
95 |
|
96 Exporter |
|
97 Archive::Zip Common base class, has defs. |
|
98 Archive::Zip::Archive A Zip archive. |
|
99 Archive::Zip::Member Abstract superclass for all members. |
|
100 Archive::Zip::StringMember Member made from a string |
|
101 Archive::Zip::FileMember Member made from an external file |
|
102 Archive::Zip::ZipFileMember Member that lives in a zip file |
|
103 Archive::Zip::NewFileMember Member whose data is in a file |
|
104 Archive::Zip::DirectoryMember Member that is a directory |
|
105 |
|
106 =cut |
|
107 |
|
108 # ---------------------------------------------------------------------- |
|
109 # class Archive::Zip |
|
110 # Note that the package Archive::Zip exists only for exporting and |
|
111 # sharing constants. Everything else is in another package |
|
112 # in this file. |
|
113 # Creation of a new Archive::Zip object actually creates a new object |
|
114 # of class Archive::Zip::Archive. |
|
115 # ---------------------------------------------------------------------- |
|
116 |
|
117 package Archive::Zip; |
|
118 require 5.003_96; |
|
119 use strict; |
|
120 |
|
121 use Carp (); |
|
122 use IO::File (); |
|
123 use IO::Seekable (); |
|
124 use Compress::Zlib (); |
|
125 use POSIX qw(_exit); |
|
126 |
|
127 use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS $VERSION $ChunkSize $ErrorHandler ); |
|
128 |
|
129 if ($Compress::Zlib::VERSION < 1.06) |
|
130 { |
|
131 if ($] < 5.006001) |
|
132 { |
|
133 print STDERR "Your current perl libraries are too old; please upgrade to Perl 5.6.1\n"; |
|
134 } |
|
135 else |
|
136 { |
|
137 print STDERR "There is a problem with your perl run time environment.\n An old version of Zlib is in use,\n please check your perl installation (5.6.1 or later) and your perl libraries\n"; |
|
138 } |
|
139 STDERR->flush; |
|
140 POSIX:_exit(1); |
|
141 } |
|
142 |
|
143 # This is the size we'll try to read, write, and (de)compress. |
|
144 # You could set it to something different if you had lots of memory |
|
145 # and needed more speed. |
|
146 $ChunkSize = 32768; |
|
147 |
|
148 $ErrorHandler = \&Carp::carp; |
|
149 |
|
150 # BEGIN block is necessary here so that other modules can use the constants. |
|
151 BEGIN |
|
152 { |
|
153 require Exporter; |
|
154 |
|
155 $VERSION = "0.11"; |
|
156 @ISA = qw( Exporter ); |
|
157 |
|
158 my @ConstantNames = qw( FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK |
|
159 GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK |
|
160 COMPRESSION_STORED COMPRESSION_DEFLATED COMPRESSION_LEVEL_NONE |
|
161 COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST |
|
162 COMPRESSION_LEVEL_BEST_COMPRESSION IFA_TEXT_FILE_MASK IFA_TEXT_FILE |
|
163 IFA_BINARY_FILE ); |
|
164 |
|
165 my @MiscConstantNames = qw( FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST |
|
166 FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS |
|
167 GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK |
|
168 GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK |
|
169 GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK |
|
170 DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM |
|
171 DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST |
|
172 COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3 |
|
173 COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED |
|
174 COMPRESSION_DEFLATED_ENHANCED |
|
175 COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED ); |
|
176 |
|
177 my @ErrorCodeNames = qw( AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR |
|
178 AZ_IO_ERROR ); |
|
179 |
|
180 my @PKZipConstantNames = qw( SIGNATURE_FORMAT SIGNATURE_LENGTH |
|
181 LOCAL_FILE_HEADER_SIGNATURE LOCAL_FILE_HEADER_FORMAT |
|
182 LOCAL_FILE_HEADER_LENGTH DATA_DESCRIPTOR_FORMAT DATA_DESCRIPTOR_LENGTH |
|
183 CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE |
|
184 CENTRAL_DIRECTORY_FILE_HEADER_FORMAT CENTRAL_DIRECTORY_FILE_HEADER_LENGTH |
|
185 END_OF_CENTRAL_DIRECTORY_SIGNATURE |
|
186 END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING END_OF_CENTRAL_DIRECTORY_FORMAT |
|
187 END_OF_CENTRAL_DIRECTORY_LENGTH ); |
|
188 |
|
189 my @UtilityMethodNames = qw( _error _ioError _formatError |
|
190 _subclassResponsibility _binmode _isSeekable _newFileHandle); |
|
191 |
|
192 @EXPORT_OK = ( 'computeCRC32' ); |
|
193 %EXPORT_TAGS = ( 'CONSTANTS' => \@ConstantNames, |
|
194 'MISC_CONSTANTS' => \@MiscConstantNames, |
|
195 'ERROR_CODES' => \@ErrorCodeNames, |
|
196 # The following two sets are for internal use only |
|
197 'PKZIP_CONSTANTS' => \@PKZipConstantNames, |
|
198 'UTILITY_METHODS' => \@UtilityMethodNames ); |
|
199 |
|
200 # Add all the constant names and error code names to @EXPORT_OK |
|
201 Exporter::export_ok_tags( 'CONSTANTS', 'ERROR_CODES', |
|
202 'PKZIP_CONSTANTS', 'UTILITY_METHODS', 'MISC_CONSTANTS' ); |
|
203 } |
|
204 |
|
205 # ------------------------- begin exportable error codes ------------------- |
|
206 |
|
207 =head1 ERROR CODES |
|
208 |
|
209 Many of the methods in Archive::Zip return error codes. |
|
210 These are implemented as inline subroutines, using the C<use constant> pragma. |
|
211 They can be imported into your namespace using the C<:CONSTANT> |
|
212 tag: |
|
213 |
|
214 use Archive::Zip qw( :CONSTANTS ); |
|
215 ... |
|
216 die "whoops!" if $zip->read( 'myfile.zip' ) != AZ_OK; |
|
217 |
|
218 =over 4 |
|
219 |
|
220 =item AZ_OK (0) |
|
221 |
|
222 Everything is fine. |
|
223 |
|
224 =item AZ_STREAM_END (1) |
|
225 |
|
226 The read stream (or central directory) ended normally. |
|
227 |
|
228 =item AZ_ERROR (2) |
|
229 |
|
230 There was some generic kind of error. |
|
231 |
|
232 =item AZ_FORMAT_ERROR (3) |
|
233 |
|
234 There is a format error in a ZIP file being read. |
|
235 |
|
236 =item AZ_IO_ERROR (4) |
|
237 |
|
238 There was an IO error. |
|
239 |
|
240 =back |
|
241 |
|
242 =cut |
|
243 |
|
244 use constant AZ_OK => 0; |
|
245 use constant AZ_STREAM_END => 1; |
|
246 use constant AZ_ERROR => 2; |
|
247 use constant AZ_FORMAT_ERROR => 3; |
|
248 use constant AZ_IO_ERROR => 4; |
|
249 |
|
250 # ------------------------- end exportable error codes --------------------- |
|
251 # ------------------------- begin exportable constants --------------------- |
|
252 |
|
253 # File types |
|
254 # Values of Archive::Zip::Member->fileAttributeFormat() |
|
255 |
|
256 use constant FA_MSDOS => 0; |
|
257 use constant FA_UNIX => 3; |
|
258 |
|
259 # general-purpose bit flag masks |
|
260 # Found in Archive::Zip::Member->bitFlag() |
|
261 |
|
262 use constant GPBF_ENCRYPTED_MASK => 1 << 0; |
|
263 use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1; |
|
264 use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3; |
|
265 |
|
266 # deflating compression types, if compressionMethod == COMPRESSION_DEFLATED |
|
267 # ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK ) |
|
268 |
|
269 use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1; |
|
270 use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1; |
|
271 use constant DEFLATING_COMPRESSION_FAST => 2 << 1; |
|
272 use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1; |
|
273 |
|
274 # compression method |
|
275 |
|
276 =head1 COMPRESSION |
|
277 |
|
278 Archive::Zip allows each member of a ZIP file to be compressed (using |
|
279 the Deflate algorithm) or uncompressed. Other compression algorithms |
|
280 that some versions of ZIP have been able to produce are not supported. |
|
281 |
|
282 Each member has two compression methods: the one it's stored as (this |
|
283 is always COMPRESSION_STORED for string and external file members), |
|
284 and the one you desire for the member in the zip file. |
|
285 These can be different, of course, so you can make a zip member that |
|
286 is not compressed out of one that is, and vice versa. |
|
287 You can inquire about the current compression and set |
|
288 the desired compression method: |
|
289 |
|
290 my $member = $zip->memberNamed( 'xyz.txt' ); |
|
291 $member->compressionMethod(); # return current compression |
|
292 # set to read uncompressed |
|
293 $member->desiredCompressionMethod( COMPRESSION_STORED ); |
|
294 # set to read compressed |
|
295 $member->desiredCompressionMethod( COMPRESSION_DEFLATED ); |
|
296 |
|
297 There are two different compression methods: |
|
298 |
|
299 =over 4 |
|
300 |
|
301 =item COMPRESSION_STORED |
|
302 |
|
303 file is stored (no compression) |
|
304 |
|
305 =item COMPRESSION_DEFLATED |
|
306 |
|
307 file is Deflated |
|
308 |
|
309 =back |
|
310 |
|
311 =head2 Compression Levels |
|
312 |
|
313 If a member's desiredCompressionMethod is COMPRESSION_DEFLATED, |
|
314 you can choose different compression levels. This choice may |
|
315 affect the speed of compression and decompression, as well as |
|
316 the size of the compressed member data. |
|
317 |
|
318 $member->desiredCompressionLevel( 9 ); |
|
319 |
|
320 The levels given can be: |
|
321 |
|
322 =over 4 |
|
323 |
|
324 =item 0 or COMPRESSION_LEVEL_NONE |
|
325 |
|
326 This is the same as saying |
|
327 |
|
328 $member->desiredCompressionMethod( COMPRESSION_STORED ); |
|
329 |
|
330 =item 1 .. 9 |
|
331 |
|
332 1 gives the best speed and worst compression, and 9 gives the best |
|
333 compression and worst speed. |
|
334 |
|
335 =item COMPRESSION_LEVEL_FASTEST |
|
336 |
|
337 This is a synonym for level 1. |
|
338 |
|
339 =item COMPRESSION_LEVEL_BEST_COMPRESSION |
|
340 |
|
341 This is a synonym for level 9. |
|
342 |
|
343 =item COMPRESSION_LEVEL_DEFAULT |
|
344 |
|
345 This gives a good compromise between speed and compression, and is |
|
346 currently equivalent to 6 (this is in the zlib code). |
|
347 |
|
348 This is the level that will be used if not specified. |
|
349 |
|
350 =back |
|
351 |
|
352 =cut |
|
353 |
|
354 # these two are the only ones supported in this module |
|
355 use constant COMPRESSION_STORED => 0; # file is stored (no compression) |
|
356 use constant COMPRESSION_DEFLATED => 8; # file is Deflated |
|
357 |
|
358 use constant COMPRESSION_LEVEL_NONE => 0; |
|
359 use constant COMPRESSION_LEVEL_DEFAULT => -1; |
|
360 use constant COMPRESSION_LEVEL_FASTEST => 1; |
|
361 use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9; |
|
362 |
|
363 # internal file attribute bits |
|
364 # Found in Archive::Zip::Member::internalFileAttributes() |
|
365 |
|
366 use constant IFA_TEXT_FILE_MASK => 1; |
|
367 use constant IFA_TEXT_FILE => 1; # file is apparently text |
|
368 use constant IFA_BINARY_FILE => 0; |
|
369 |
|
370 # PKZIP file format miscellaneous constants (for internal use only) |
|
371 use constant SIGNATURE_FORMAT => "V"; |
|
372 use constant SIGNATURE_LENGTH => 4; |
|
373 |
|
374 use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50; |
|
375 use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2"; |
|
376 use constant LOCAL_FILE_HEADER_LENGTH => 26; |
|
377 |
|
378 use constant DATA_DESCRIPTOR_FORMAT => "V3"; |
|
379 use constant DATA_DESCRIPTOR_LENGTH => 12; |
|
380 |
|
381 use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50; |
|
382 use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2"; |
|
383 use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42; |
|
384 |
|
385 use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50; |
|
386 use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING => pack( "V", |
|
387 END_OF_CENTRAL_DIRECTORY_SIGNATURE ); |
|
388 use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v"; |
|
389 use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18; |
|
390 |
|
391 use constant FA_AMIGA => 1; |
|
392 use constant FA_VAX_VMS => 2; |
|
393 use constant FA_VM_CMS => 4; |
|
394 use constant FA_ATARI_ST => 5; |
|
395 use constant FA_OS2_HPFS => 6; |
|
396 use constant FA_MACINTOSH => 7; |
|
397 use constant FA_Z_SYSTEM => 8; |
|
398 use constant FA_CPM => 9; |
|
399 use constant FA_WINDOWS_NTFS => 10; |
|
400 |
|
401 use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1; |
|
402 use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2; |
|
403 use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5; |
|
404 |
|
405 # the rest of these are not supported in this module |
|
406 use constant COMPRESSION_SHRUNK => 1; # file is Shrunk |
|
407 use constant COMPRESSION_REDUCED_1 => 2;# file is Reduced CF=1 |
|
408 use constant COMPRESSION_REDUCED_2 => 3;# file is Reduced CF=2 |
|
409 use constant COMPRESSION_REDUCED_3 => 4;# file is Reduced CF=3 |
|
410 use constant COMPRESSION_REDUCED_4 => 5;# file is Reduced CF=4 |
|
411 use constant COMPRESSION_IMPLODED => 6; # file is Imploded |
|
412 use constant COMPRESSION_TOKENIZED => 7;# reserved for Tokenizing compr. |
|
413 use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating |
|
414 use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10; |
|
415 |
|
416 # ------------------------- end of exportable constants --------------------- |
|
417 |
|
418 =head1 Archive::Zip methods |
|
419 |
|
420 The Archive::Zip class (and its invisible subclass Archive::Zip::Archive) |
|
421 implement generic zip file functionality. |
|
422 |
|
423 Creating a new Archive::Zip object actually makes an Archive::Zip::Archive |
|
424 object, but you don't have to worry about this unless you're subclassing. |
|
425 |
|
426 =cut |
|
427 |
|
428 =head2 Constructor |
|
429 |
|
430 =over 4 |
|
431 |
|
432 =cut |
|
433 |
|
434 use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive'; |
|
435 use constant ZIPMEMBERCLASS => 'Archive::Zip::Member'; |
|
436 |
|
437 #-------------------------------- |
|
438 |
|
439 =item new( [$fileName] ) |
|
440 |
|
441 Make a new, empty zip archive. |
|
442 |
|
443 my $zip = Archive::Zip->new(); |
|
444 |
|
445 If an additional argument is passed, new() will call read() to read the |
|
446 contents of an archive: |
|
447 |
|
448 my $zip = Archive::Zip->new( 'xyz.zip' ); |
|
449 |
|
450 If a filename argument is passed and the read fails for any reason, new |
|
451 will return undef. For this reason, it may be better to call read |
|
452 separately. |
|
453 |
|
454 =cut |
|
455 |
|
456 sub new # Archive::Zip |
|
457 { |
|
458 my $class = shift; |
|
459 return $class->ZIPARCHIVECLASS->new( @_ ); |
|
460 } |
|
461 |
|
462 =back |
|
463 |
|
464 =head2 Utility Methods |
|
465 |
|
466 These Archive::Zip methods may be called as functions or as object |
|
467 methods. Do not call them as class methods: |
|
468 |
|
469 $zip = Archive::Zip->new(); |
|
470 $crc = Archive::Zip::computeCRC32( 'ghijkl' ); # OK |
|
471 $crc = $zip->computeCRC32( 'ghijkl' ); # also OK |
|
472 |
|
473 $crc = Archive::Zip->computeCRC32( 'ghijkl' ); # NOT OK |
|
474 |
|
475 =over 4 |
|
476 |
|
477 =cut |
|
478 |
|
479 #-------------------------------- |
|
480 |
|
481 =item Archive::Zip::computeCRC32( $string [, $crc] ) |
|
482 |
|
483 This is a utility function that uses the Compress::Zlib CRC |
|
484 routine to compute a CRC-32. |
|
485 |
|
486 You can get the CRC of a string: |
|
487 |
|
488 $crc = Archive::Zip::computeCRC32( $string ); |
|
489 |
|
490 Or you can compute the running CRC: |
|
491 |
|
492 $crc = 0; |
|
493 $crc = Archive::Zip::computeCRC32( 'abcdef', $crc ); |
|
494 $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc ); |
|
495 |
|
496 =cut |
|
497 |
|
498 sub computeCRC32 # Archive::Zip |
|
499 { |
|
500 my $data = shift; |
|
501 $data = shift if ref( $data ); # allow calling as an obj method |
|
502 my $crc = shift; |
|
503 return Compress::Zlib::crc32( $data, $crc ); |
|
504 } |
|
505 |
|
506 #-------------------------------- |
|
507 |
|
508 =item Archive::Zip::setChunkSize( $number ) |
|
509 |
|
510 Change chunk size used for reading and writing. |
|
511 Currently, this defaults to 32K. |
|
512 This is not exportable, so you must call it like: |
|
513 |
|
514 Archive::Zip::setChunkSize( 4096 ); |
|
515 |
|
516 or as a method on a zip (though this is a global setting). |
|
517 Returns old chunk size. |
|
518 |
|
519 =cut |
|
520 |
|
521 sub setChunkSize # Archive::Zip |
|
522 { |
|
523 my $chunkSize = shift; |
|
524 $chunkSize = shift if ref( $chunkSize ); # object method on zip? |
|
525 my $oldChunkSize = $Archive::Zip::ChunkSize; |
|
526 $Archive::Zip::ChunkSize = $chunkSize; |
|
527 return $oldChunkSize; |
|
528 } |
|
529 |
|
530 #-------------------------------- |
|
531 |
|
532 =item Archive::Zip::setErrorHandler( \&subroutine ) |
|
533 |
|
534 Change the subroutine called with error strings. |
|
535 This defaults to \&Carp::carp, but you may want to change |
|
536 it to get the error strings. |
|
537 |
|
538 This is not exportable, so you must call it like: |
|
539 |
|
540 Archive::Zip::setErrorHandler( \&myErrorHandler ); |
|
541 |
|
542 If no error handler is passed, resets handler to default. |
|
543 |
|
544 Returns old error handler. |
|
545 |
|
546 Note that if you call Carp::carp or a similar routine |
|
547 or if you're chaining to the default error handler |
|
548 from your error handler, you may want to increment the number |
|
549 of caller levels that are skipped (do not just set it to a number): |
|
550 |
|
551 $Carp::CarpLevel++; |
|
552 |
|
553 =cut |
|
554 |
|
555 sub setErrorHandler (&) # Archive::Zip |
|
556 { |
|
557 my $errorHandler = shift; |
|
558 $errorHandler = \&Carp::carp if ! defined( $errorHandler ); |
|
559 my $oldErrorHandler = $Archive::Zip::ErrorHandler; |
|
560 $Archive::Zip::ErrorHandler = $errorHandler; |
|
561 return $oldErrorHandler; |
|
562 } |
|
563 |
|
564 sub _printError # Archive::Zip |
|
565 { |
|
566 my $string = join( ' ', @_, "\n" ); |
|
567 my $oldCarpLevel = $Carp::CarpLevel; |
|
568 $Carp::CarpLevel += 2; |
|
569 &{ $ErrorHandler }( $string ); |
|
570 $Carp::CarpLevel = $oldCarpLevel; |
|
571 } |
|
572 |
|
573 # This is called on format errors. |
|
574 sub _formatError # Archive::Zip |
|
575 { |
|
576 shift if ref( $_[0] ); |
|
577 _printError( 'format error:', @_ ); |
|
578 return AZ_FORMAT_ERROR; |
|
579 } |
|
580 |
|
581 # This is called on IO errors. |
|
582 sub _ioError # Archive::Zip |
|
583 { |
|
584 shift if ref( $_[0] ); |
|
585 _printError( 'IO error:', @_, ':', $! ); |
|
586 return AZ_IO_ERROR; |
|
587 } |
|
588 |
|
589 # This is called on generic errors. |
|
590 sub _error # Archive::Zip |
|
591 { |
|
592 shift if ref( $_[0] ); |
|
593 _printError( 'error:', @_ ); |
|
594 return AZ_ERROR; |
|
595 } |
|
596 |
|
597 # Called when a subclass should have implemented |
|
598 # something but didn't |
|
599 sub _subclassResponsibility # Archive::Zip |
|
600 { |
|
601 Carp::croak( "subclass Responsibility\n" ); |
|
602 } |
|
603 |
|
604 # Try to set the given file handle or object into binary mode. |
|
605 sub _binmode # Archive::Zip |
|
606 { |
|
607 my $fh = shift; |
|
608 return $fh->can( 'binmode' ) |
|
609 ? $fh->binmode() |
|
610 : binmode( $fh ); |
|
611 } |
|
612 |
|
613 # Attempt to guess whether file handle is seekable. |
|
614 sub _isSeekable # Archive::Zip |
|
615 { |
|
616 my $fh = shift; |
|
617 my ($p0, $p1); |
|
618 my $seekable = |
|
619 ( $p0 = $fh->tell() ) >= 0 |
|
620 && $fh->seek( 1, IO::Seekable::SEEK_CUR ) |
|
621 && ( $p1 = $fh->tell() ) >= 0 |
|
622 && $p1 == $p0 + 1 |
|
623 && $fh->seek( -1, IO::Seekable::SEEK_CUR ) |
|
624 && $fh->tell() == $p0; |
|
625 return $seekable; |
|
626 } |
|
627 |
|
628 # Return an opened IO::Handle |
|
629 # my ( $status, fh ) = _newFileHandle( 'fileName', 'w' ); |
|
630 # Can take a filename, file handle, or ref to GLOB |
|
631 # Or, if given something that is a ref but not an IO::Handle, |
|
632 # passes back the same thing. |
|
633 sub _newFileHandle # Archive::Zip |
|
634 { |
|
635 my $fd = shift; |
|
636 my $status = 1; |
|
637 my $handle = IO::File->new(); |
|
638 |
|
639 if ( ref( $fd ) ) |
|
640 { |
|
641 if ( $fd->isa( 'IO::Handle' ) or $fd->isa( 'GLOB' ) ) |
|
642 { |
|
643 $status = $handle->fdopen( $fd, @_ ); |
|
644 } |
|
645 else |
|
646 { |
|
647 $handle = $fd; |
|
648 } |
|
649 } |
|
650 else |
|
651 { |
|
652 $status = $handle->open( $fd, @_ ); |
|
653 } |
|
654 |
|
655 return ( $status, $handle ); |
|
656 } |
|
657 |
|
658 =back |
|
659 |
|
660 =cut |
|
661 |
|
662 # ---------------------------------------------------------------------- |
|
663 # class Archive::Zip::Archive (concrete) |
|
664 # Generic ZIP archive. |
|
665 # ---------------------------------------------------------------------- |
|
666 package Archive::Zip::Archive; |
|
667 use File::Path; |
|
668 use File::Basename; |
|
669 |
|
670 use vars qw( @ISA ); |
|
671 @ISA = qw( Archive::Zip ); |
|
672 |
|
673 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS |
|
674 :UTILITY_METHODS ) } |
|
675 |
|
676 #-------------------------------- |
|
677 # Note that this returns undef on read errors, else new zip object. |
|
678 |
|
679 sub new # Archive::Zip::Archive |
|
680 { |
|
681 my $class = shift; |
|
682 my $self = bless( { |
|
683 'diskNumber' => 0, |
|
684 'diskNumberWithStartOfCentralDirectory' => 0, |
|
685 'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members |
|
686 'numberOfCentralDirectories' => 0, # shld be # of members |
|
687 'centralDirectorySize' => 0, # must re-compute on write |
|
688 'centralDirectoryOffsetWRTStartingDiskNumber' => 0, # must re-compute |
|
689 'zipfileComment' => '' |
|
690 }, $class ); |
|
691 $self->{'members'} = []; |
|
692 if ( @_ ) |
|
693 { |
|
694 my $status = $self->read( @_ ); |
|
695 return $status == AZ_OK ? $self : undef; |
|
696 } |
|
697 return $self; |
|
698 } |
|
699 |
|
700 =head2 Accessors |
|
701 |
|
702 =over 4 |
|
703 |
|
704 =cut |
|
705 |
|
706 #-------------------------------- |
|
707 |
|
708 =item members() |
|
709 |
|
710 Return a copy of my members array |
|
711 |
|
712 my @members = $zip->members(); |
|
713 |
|
714 =cut |
|
715 |
|
716 sub members # Archive::Zip::Archive |
|
717 { @{ shift->{'members'} } } |
|
718 |
|
719 #-------------------------------- |
|
720 |
|
721 =item numberOfMembers() |
|
722 |
|
723 Return the number of members I have |
|
724 |
|
725 =cut |
|
726 |
|
727 sub numberOfMembers # Archive::Zip::Archive |
|
728 { scalar( shift->members() ) } |
|
729 |
|
730 #-------------------------------- |
|
731 |
|
732 =item memberNames() |
|
733 |
|
734 Return a list of the (internal) file names of my members |
|
735 |
|
736 =cut |
|
737 |
|
738 sub memberNames # Archive::Zip::Archive |
|
739 { |
|
740 my $self = shift; |
|
741 return map { $_->fileName() } $self->members(); |
|
742 } |
|
743 |
|
744 #-------------------------------- |
|
745 |
|
746 =item memberNamed( $string ) |
|
747 |
|
748 Return ref to member whose filename equals given filename or undef |
|
749 |
|
750 =cut |
|
751 |
|
752 sub memberNamed # Archive::Zip::Archive |
|
753 { |
|
754 my ( $self, $fileName ) = @_; |
|
755 my ( $retval ) = grep { $_->fileName() eq $fileName } $self->members(); |
|
756 return $retval; |
|
757 } |
|
758 |
|
759 #-------------------------------- |
|
760 |
|
761 =item membersMatching( $regex ) |
|
762 |
|
763 Return array of members whose filenames match given regular |
|
764 expression in list context. |
|
765 Returns number of matching members in scalar context. |
|
766 |
|
767 my @textFileMembers = $zip->membersMatching( '.*\.txt' ); |
|
768 # or |
|
769 my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' ); |
|
770 |
|
771 =cut |
|
772 |
|
773 sub membersMatching # Archive::Zip::Archive |
|
774 { |
|
775 my ( $self, $pattern ) = @_; |
|
776 return grep { $_->fileName() =~ /$pattern/ } $self->members(); |
|
777 } |
|
778 |
|
779 #-------------------------------- |
|
780 |
|
781 =item diskNumber() |
|
782 |
|
783 Return the disk that I start on. |
|
784 Not used for writing zips, but might be interesting if you read a zip in. |
|
785 This had better be 0, as Archive::Zip does not handle multi-volume archives. |
|
786 |
|
787 =cut |
|
788 |
|
789 sub diskNumber # Archive::Zip::Archive |
|
790 { shift->{'diskNumber'} } |
|
791 |
|
792 #-------------------------------- |
|
793 |
|
794 =item diskNumberWithStartOfCentralDirectory() |
|
795 |
|
796 Return the disk number that holds the beginning of the central directory. |
|
797 Not used for writing zips, but might be interesting if you read a zip in. |
|
798 This had better be 0, as Archive::Zip does not handle multi-volume archives. |
|
799 |
|
800 =cut |
|
801 |
|
802 sub diskNumberWithStartOfCentralDirectory # Archive::Zip::Archive |
|
803 { shift->{'diskNumberWithStartOfCentralDirectory'} } |
|
804 |
|
805 #-------------------------------- |
|
806 |
|
807 =item numberOfCentralDirectoriesOnThisDisk() |
|
808 |
|
809 Return the number of CD structures on this disk. |
|
810 Not used for writing zips, but might be interesting if you read a zip in. |
|
811 |
|
812 =cut |
|
813 |
|
814 sub numberOfCentralDirectoriesOnThisDisk # Archive::Zip::Archive |
|
815 { shift->{'numberOfCentralDirectoriesOnThisDisk'} } |
|
816 |
|
817 #-------------------------------- |
|
818 |
|
819 =item numberOfCentralDirectories() |
|
820 |
|
821 Return the number of CD structures in the whole zip. |
|
822 Not used for writing zips, but might be interesting if you read a zip in. |
|
823 |
|
824 =cut |
|
825 |
|
826 sub numberOfCentralDirectories # Archive::Zip::Archive |
|
827 { shift->{'numberOfCentralDirectories'} } |
|
828 |
|
829 #-------------------------------- |
|
830 |
|
831 =item centralDirectorySize() |
|
832 |
|
833 Returns central directory size, as read from an external zip file. |
|
834 Not used for writing zips, but might be interesting if you read a zip in. |
|
835 |
|
836 =cut |
|
837 |
|
838 sub centralDirectorySize # Archive::Zip::Archive |
|
839 { shift->{'centralDirectorySize'} } |
|
840 |
|
841 #-------------------------------- |
|
842 |
|
843 =item centralDirectoryOffsetWRTStartingDiskNumber() |
|
844 |
|
845 Returns the offset into the zip file where the CD begins. |
|
846 Not used for writing zips, but might be interesting if you read a zip in. |
|
847 |
|
848 =cut |
|
849 |
|
850 sub centralDirectoryOffsetWRTStartingDiskNumber # Archive::Zip::Archive |
|
851 { shift->{'centralDirectoryOffsetWRTStartingDiskNumber'} } |
|
852 |
|
853 #-------------------------------- |
|
854 |
|
855 =item zipfileComment( [$string] ) |
|
856 |
|
857 Get or set the zipfile comment. |
|
858 Returns the old comment. |
|
859 |
|
860 print $zip->zipfileComment(); |
|
861 $zip->zipfileComment( 'New Comment' ); |
|
862 |
|
863 =cut |
|
864 |
|
865 sub zipfileComment # Archive::Zip::Archive |
|
866 { |
|
867 my $self = shift; |
|
868 my $comment = $self->{'zipfileComment'}; |
|
869 if ( @_ ) |
|
870 { |
|
871 $self->{'zipfileComment'} = shift; |
|
872 } |
|
873 return $comment; |
|
874 } |
|
875 |
|
876 =back |
|
877 |
|
878 =head2 Member Operations |
|
879 |
|
880 Various operations on a zip file modify members. |
|
881 When a member is passed as an argument, you can either use a reference |
|
882 to the member itself, or the name of a member. Of course, using the |
|
883 name requires that names be unique within a zip (this is not enforced). |
|
884 |
|
885 =over 4 |
|
886 |
|
887 =cut |
|
888 |
|
889 #-------------------------------- |
|
890 |
|
891 =item removeMember( $memberOrName ) |
|
892 |
|
893 Remove and return the given member, or match its name and remove it. |
|
894 Returns undef if member name doesn't exist in this Zip. |
|
895 No-op if member does not belong to this zip. |
|
896 |
|
897 =cut |
|
898 |
|
899 sub removeMember # Archive::Zip::Archive |
|
900 { |
|
901 my ( $self, $member ) = @_; |
|
902 $member = $self->memberNamed( $member ) if ! ref( $member ); |
|
903 return undef if ! $member; |
|
904 my @newMembers = grep { $_ != $member } $self->members(); |
|
905 $self->{'members'} = \@newMembers; |
|
906 return $member; |
|
907 } |
|
908 |
|
909 #-------------------------------- |
|
910 |
|
911 =item replaceMember( $memberOrName, $newMember ) |
|
912 |
|
913 Remove and return the given member, or match its name and remove it. |
|
914 Replace with new member. |
|
915 Returns undef if member name doesn't exist in this Zip. |
|
916 |
|
917 my $member1 = $zip->removeMember( 'xyz' ); |
|
918 my $member2 = $zip->replaceMember( 'abc', $member1 ); |
|
919 # now, $member2 (named 'abc') is not in $zip, |
|
920 # and $member1 (named 'xyz') is, having taken $member2's place. |
|
921 |
|
922 =cut |
|
923 |
|
924 sub replaceMember # Archive::Zip::Archive |
|
925 { |
|
926 my ( $self, $oldMember, $newMember ) = @_; |
|
927 $oldMember = $self->memberNamed( $oldMember ) if ! ref( $oldMember ); |
|
928 return undef if ! $oldMember; |
|
929 my @newMembers |
|
930 = map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members(); |
|
931 $self->{'members'} = \@newMembers; |
|
932 return $oldMember; |
|
933 } |
|
934 |
|
935 #-------------------------------- |
|
936 |
|
937 =item extractMember( $memberOrName [, $extractedName ] ) |
|
938 |
|
939 Extract the given member, or match its name and extract it. |
|
940 Returns undef if member doesn't exist in this Zip. |
|
941 If optional second arg is given, use it as the name of the |
|
942 extracted member. Otherwise, the internal filename of the member is used |
|
943 as the name of the extracted file or directory. |
|
944 |
|
945 All necessary directories will be created. |
|
946 |
|
947 Returns C<AZ_OK> on success. |
|
948 |
|
949 =cut |
|
950 |
|
951 sub extractMember # Archive::Zip::Archive |
|
952 { |
|
953 my $self = shift; |
|
954 my $member = shift; |
|
955 $member = $self->memberNamed( $member ) if ! ref( $member ); |
|
956 return _error( 'member not found' ) if !$member; |
|
957 my $name = shift; |
|
958 $name = $member->fileName() if not $name; |
|
959 my $dirName = dirname( $name ); |
|
960 mkpath( $dirName ) if ( ! -d $dirName ); |
|
961 return _ioError( "can't create dir $dirName" ) if ( ! -d $dirName ); |
|
962 return $member->extractToFileNamed( $name, @_ ); |
|
963 } |
|
964 |
|
965 #-------------------------------- |
|
966 |
|
967 =item extractMemberWithoutPaths( $memberOrName [, $extractedName ] ) |
|
968 |
|
969 Extract the given member, or match its name and extract it. |
|
970 Does not use path information (extracts into the current directory). |
|
971 Returns undef if member doesn't exist in this Zip. |
|
972 If optional second arg is given, use it as the name of the |
|
973 extracted member (its paths will be deleted too). |
|
974 Otherwise, the internal filename of the member (minus paths) is used |
|
975 as the name of the extracted file or directory. |
|
976 |
|
977 Returns C<AZ_OK> on success. |
|
978 |
|
979 =cut |
|
980 |
|
981 sub extractMemberWithoutPaths # Archive::Zip::Archive |
|
982 { |
|
983 my $self = shift; |
|
984 my $member = shift; |
|
985 $member = $self->memberNamed( $member ) if ! ref( $member ); |
|
986 return _error( 'member not found' ) if !$member; |
|
987 my $name = shift; |
|
988 $name = $member->fileName() if not $name; |
|
989 $name = basename( $name ); |
|
990 return $member->extractToFileNamed( $name, @_ ); |
|
991 } |
|
992 |
|
993 #-------------------------------- |
|
994 |
|
995 =item addMember( $member ) |
|
996 |
|
997 Append a member (possibly from another zip file) to the zip file. |
|
998 Returns the new member. |
|
999 Generally, you will use addFile(), addDirectory(), addString(), or read() |
|
1000 to add members. |
|
1001 |
|
1002 # Move member named 'abc' to end of zip: |
|
1003 my $member = $zip->removeMember( 'abc' ); |
|
1004 $zip->addMember( $member ); |
|
1005 |
|
1006 =cut |
|
1007 |
|
1008 sub addMember # Archive::Zip::Archive |
|
1009 { |
|
1010 my ( $self, $newMember ) = @_; |
|
1011 push( @{ $self->{'members'} }, $newMember ) if $newMember; |
|
1012 return $newMember; |
|
1013 } |
|
1014 |
|
1015 #-------------------------------- |
|
1016 |
|
1017 =item addFile( $fileName [, $newName ] ) |
|
1018 |
|
1019 Append a member whose data comes from an external file, |
|
1020 returning the member or undef. |
|
1021 The member will have its file name set to the name of the external |
|
1022 file, and its desiredCompressionMethod set to COMPRESSION_DEFLATED. |
|
1023 The file attributes and last modification time will be set from the file. |
|
1024 |
|
1025 If the name given does not represent a readable plain file or symbolic link, |
|
1026 undef will be returned. |
|
1027 |
|
1028 The text mode bit will be set if the contents appears to be text (as returned |
|
1029 by the C<-T> perl operator). |
|
1030 |
|
1031 The optional second argument sets the internal file name to |
|
1032 something different than the given $fileName. |
|
1033 |
|
1034 =cut |
|
1035 |
|
1036 sub addFile # Archive::Zip::Archive |
|
1037 { |
|
1038 my $self = shift; |
|
1039 my $fileName = shift; |
|
1040 my $newName = shift; |
|
1041 my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName ); |
|
1042 if (defined($newMember)) |
|
1043 { |
|
1044 $self->addMember( $newMember ); |
|
1045 $newMember->fileName( $newName ) if defined( $newName ); |
|
1046 } |
|
1047 return $newMember; |
|
1048 } |
|
1049 |
|
1050 #-------------------------------- |
|
1051 |
|
1052 =item addString( $stringOrStringRef [, $name] ) |
|
1053 |
|
1054 Append a member created from the given string or string reference. |
|
1055 The name is given by the optional second argument. |
|
1056 Returns the new member. |
|
1057 |
|
1058 The last modification time will be set to now, |
|
1059 and the file attributes will be set to permissive defaults. |
|
1060 |
|
1061 my $member = $zip->addString( 'This is a test', 'test.txt' ); |
|
1062 |
|
1063 =cut |
|
1064 |
|
1065 sub addString # Archive::Zip::Archive |
|
1066 { |
|
1067 my $self = shift; |
|
1068 my $newMember = $self->ZIPMEMBERCLASS->newFromString( @_ ); |
|
1069 return $self->addMember( $newMember ); |
|
1070 } |
|
1071 |
|
1072 #-------------------------------- |
|
1073 |
|
1074 =item addDirectory( $directoryName [, $fileName ] ) |
|
1075 |
|
1076 Append a member created from the given directory name. |
|
1077 The directory name does not have to name an existing directory. |
|
1078 If the named directory exists, the file modification time and permissions |
|
1079 are set from the existing directory, otherwise they are set to now and |
|
1080 permissive default permissions. |
|
1081 The optional second argument sets the name of the archive member |
|
1082 (which defaults to $directoryName) |
|
1083 |
|
1084 Returns the new member. |
|
1085 |
|
1086 =cut |
|
1087 |
|
1088 sub addDirectory # Archive::Zip::Archive |
|
1089 { |
|
1090 my ( $self, $name, $newName ) = @_; |
|
1091 my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name ); |
|
1092 $self->addMember( $newMember ); |
|
1093 $newMember->fileName( $newName ) if defined( $newName ); |
|
1094 return $newMember; |
|
1095 } |
|
1096 |
|
1097 #-------------------------------- |
|
1098 |
|
1099 =item contents( $memberOrMemberName [, $newContents ] ) |
|
1100 |
|
1101 Returns the uncompressed data for a particular member, or undef. |
|
1102 |
|
1103 print "xyz.txt contains " . $zip->contents( 'xyz.txt' ); |
|
1104 |
|
1105 Also can change the contents of a member: |
|
1106 |
|
1107 $zip->contents( 'xyz.txt', 'This is the new contents' ); |
|
1108 |
|
1109 =cut |
|
1110 |
|
1111 sub contents # Archive::Zip::Archive |
|
1112 { |
|
1113 my ( $self, $member, $newContents ) = @_; |
|
1114 $member = $self->memberNamed( $member ) if ! ref( $member ); |
|
1115 return undef if ! $member; |
|
1116 return $member->contents( $newContents ); |
|
1117 } |
|
1118 |
|
1119 #-------------------------------- |
|
1120 |
|
1121 =item writeToFileNamed( $fileName ) |
|
1122 |
|
1123 Write a zip archive to named file. |
|
1124 Returns C<AZ_OK> on success. |
|
1125 |
|
1126 Note that if you use the same name as an existing |
|
1127 zip file that you read in, you will clobber ZipFileMembers. |
|
1128 So instead, write to a different file name, then delete |
|
1129 the original. |
|
1130 |
|
1131 my $status = $zip->writeToFileNamed( 'xx.zip' ); |
|
1132 die "error somewhere" if $status != AZ_OK; |
|
1133 |
|
1134 =cut |
|
1135 |
|
1136 sub writeToFileNamed # Archive::Zip::Archive |
|
1137 { |
|
1138 my $self = shift; |
|
1139 my $fileName = shift; |
|
1140 foreach my $member ( $self->members() ) |
|
1141 { |
|
1142 if ( $member->_usesFileNamed( $fileName ) ) |
|
1143 { |
|
1144 return _error("$fileName is needed by member " |
|
1145 . $member->fileName() |
|
1146 . "; try renaming output file"); |
|
1147 } |
|
1148 } |
|
1149 my ( $status, $fh ) = _newFileHandle( $fileName, 'w' ); |
|
1150 return _ioError( "Can't open $fileName for write" ) if !$status; |
|
1151 my $retval = $self->writeToFileHandle( $fh, 1 ); |
|
1152 $fh->close(); |
|
1153 return $retval; |
|
1154 } |
|
1155 |
|
1156 #-------------------------------- |
|
1157 |
|
1158 =item writeToFileHandle( $fileHandle [, $seekable] ) |
|
1159 |
|
1160 Write a zip archive to a file handle. |
|
1161 Return AZ_OK on success. |
|
1162 |
|
1163 The optional second arg tells whether or not to try to seek backwards |
|
1164 to re-write headers. |
|
1165 If not provided, it is set by testing seekability. This could fail |
|
1166 on some operating systems, though. |
|
1167 |
|
1168 my $fh = IO::File->new( 'someFile.zip', 'w' ); |
|
1169 $zip->writeToFileHandle( $fh ); |
|
1170 |
|
1171 If you pass a file handle that is not seekable (like if you're writing |
|
1172 to a pipe or a socket), pass a false as the second argument: |
|
1173 |
|
1174 my $fh = IO::File->new( '| cat > somefile.zip', 'w' ); |
|
1175 $zip->writeToFileHandle( $fh, 0 ); # fh is not seekable |
|
1176 |
|
1177 =cut |
|
1178 |
|
1179 sub writeToFileHandle # Archive::Zip::Archive |
|
1180 { |
|
1181 my $self = shift; |
|
1182 my $fh = shift; |
|
1183 my $fhIsSeekable = @_ ? shift : _isSeekable( $fh ); |
|
1184 _binmode( $fh ); |
|
1185 |
|
1186 my $offset = 0; |
|
1187 foreach my $member ( $self->members() ) |
|
1188 { |
|
1189 $member->{'writeLocalHeaderRelativeOffset'} = $offset; |
|
1190 my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable ); |
|
1191 $member->endRead(); |
|
1192 return $retval if $retval != AZ_OK; |
|
1193 $offset += $member->_localHeaderSize() + $member->_writeOffset(); |
|
1194 $offset += $member->hasDataDescriptor() ? DATA_DESCRIPTOR_LENGTH : 0; |
|
1195 } |
|
1196 $self->{'writeCentralDirectoryOffset'} = $offset; |
|
1197 return $self->_writeCentralDirectory( $fh ); |
|
1198 } |
|
1199 |
|
1200 # Returns next signature from given file handle, leaves |
|
1201 # file handle positioned afterwards. |
|
1202 # In list context, returns ($status, $signature) |
|
1203 |
|
1204 sub _readSignature # Archive::Zip::Archive |
|
1205 { |
|
1206 my $self = shift; |
|
1207 my $fh = shift; |
|
1208 my $fileName = shift; |
|
1209 my $signatureData; |
|
1210 $fh->read( $signatureData, SIGNATURE_LENGTH ) |
|
1211 or return _ioError( "reading header signature" ); |
|
1212 my $signature = unpack( SIGNATURE_FORMAT, $signatureData ); |
|
1213 my $status = AZ_OK; |
|
1214 if ( $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE |
|
1215 and $signature != LOCAL_FILE_HEADER_SIGNATURE |
|
1216 and $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE ) |
|
1217 { |
|
1218 $status = _formatError( |
|
1219 sprintf( "bad signature: 0x%08x at offset %d in file \"%s\"", |
|
1220 $signature, $fh->tell() - SIGNATURE_LENGTH, $fileName ) ); |
|
1221 } |
|
1222 |
|
1223 return ( $status, $signature ); |
|
1224 } |
|
1225 |
|
1226 # Used only during writing |
|
1227 sub _writeCentralDirectoryOffset # Archive::Zip::Archive |
|
1228 { shift->{'writeCentralDirectoryOffset'} } |
|
1229 |
|
1230 sub _writeEOCDOffset # Archive::Zip::Archive |
|
1231 { shift->{'writeEOCDOffset'} } |
|
1232 |
|
1233 # Expects to have _writeEOCDOffset() set |
|
1234 sub _writeEndOfCentralDirectory # Archive::Zip::Archive |
|
1235 { |
|
1236 my ( $self, $fh ) = @_; |
|
1237 |
|
1238 $fh->write( END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING, SIGNATURE_LENGTH ) |
|
1239 or return _ioError( 'writing EOCD Signature' ); |
|
1240 |
|
1241 my $header = pack( END_OF_CENTRAL_DIRECTORY_FORMAT, |
|
1242 0, # {'diskNumber'}, |
|
1243 0, # {'diskNumberWithStartOfCentralDirectory'}, |
|
1244 $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'}, |
|
1245 $self->numberOfMembers(), # {'numberOfCentralDirectories'}, |
|
1246 $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(), |
|
1247 $self->_writeCentralDirectoryOffset(), |
|
1248 length( $self->zipfileComment() ) |
|
1249 ); |
|
1250 $fh->write( $header, END_OF_CENTRAL_DIRECTORY_LENGTH ) |
|
1251 or return _ioError( 'writing EOCD header' ); |
|
1252 if ( length( $self->zipfileComment() )) |
|
1253 { |
|
1254 $fh->write( $self->zipfileComment(), length( $self->zipfileComment() )) |
|
1255 or return _ioError( 'writing zipfile comment' ); |
|
1256 } |
|
1257 return AZ_OK; |
|
1258 } |
|
1259 |
|
1260 sub _writeCentralDirectory # Archive::Zip::Archive |
|
1261 { |
|
1262 my ( $self, $fh ) = @_; |
|
1263 |
|
1264 my $offset = $self->_writeCentralDirectoryOffset(); |
|
1265 foreach my $member ( $self->members() ) |
|
1266 { |
|
1267 my $status = $member->_writeCentralDirectoryFileHeader( $fh ); |
|
1268 return $status if $status != AZ_OK; |
|
1269 $offset += $member->_centralDirectoryHeaderSize(); |
|
1270 } |
|
1271 $self->{'writeEOCDOffset'} = $offset; |
|
1272 return $self->_writeEndOfCentralDirectory( $fh ); |
|
1273 } |
|
1274 |
|
1275 #-------------------------------- |
|
1276 |
|
1277 =item read( $fileName ) |
|
1278 |
|
1279 Read zipfile headers from a zip file, appending new members. |
|
1280 Returns C<AZ_OK> or error code. |
|
1281 |
|
1282 my $zipFile = Archive::Zip->new(); |
|
1283 my $status = $zipFile->read( '/some/FileName.zip' ); |
|
1284 |
|
1285 =cut |
|
1286 |
|
1287 sub read # Archive::Zip::Archive |
|
1288 { |
|
1289 my $self = shift; |
|
1290 my $fileName = shift; |
|
1291 return _error( 'No filename given' ) if ! $fileName; |
|
1292 my ( $status, $fh ) = _newFileHandle( $fileName, 'r' ); |
|
1293 return _ioError( "opening $fileName for read" ) if !$status; |
|
1294 _binmode( $fh ); |
|
1295 |
|
1296 $status = $self->_findEndOfCentralDirectory( $fh ); |
|
1297 return $status if $status != AZ_OK; |
|
1298 |
|
1299 my $eocdPosition = $fh->tell(); |
|
1300 |
|
1301 $status = $self->_readEndOfCentralDirectory( $fh ); |
|
1302 return $status if $status != AZ_OK; |
|
1303 |
|
1304 $fh->seek( $eocdPosition - $self->centralDirectorySize(), |
|
1305 IO::Seekable::SEEK_SET ) |
|
1306 or return _ioError( "Can't seek $fileName" ); |
|
1307 |
|
1308 for ( ;; ) |
|
1309 { |
|
1310 my $newMember = |
|
1311 $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName ); |
|
1312 my $signature; |
|
1313 ( $status, $signature ) = $self->_readSignature( $fh, $fileName ); |
|
1314 return $status if $status != AZ_OK; |
|
1315 last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE; |
|
1316 $status = $newMember->_readCentralDirectoryFileHeader(); |
|
1317 return $status if $status != AZ_OK; |
|
1318 $status = $newMember->endRead(); |
|
1319 return $status if $status != AZ_OK; |
|
1320 $newMember->_becomeDirectoryIfNecessary(); |
|
1321 push( @{ $self->{'members'} }, $newMember ); |
|
1322 } |
|
1323 |
|
1324 $fh->close(); |
|
1325 return AZ_OK; |
|
1326 } |
|
1327 |
|
1328 # Read EOCD, starting from position before signature. |
|
1329 # Return AZ_OK on success. |
|
1330 sub _readEndOfCentralDirectory # Archive::Zip::Archive |
|
1331 { |
|
1332 my $self = shift; |
|
1333 my $fh = shift; |
|
1334 |
|
1335 # Skip past signature |
|
1336 $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR ) |
|
1337 or return _ioError( "Can't seek past EOCD signature" ); |
|
1338 |
|
1339 my $header = ''; |
|
1340 $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH ) |
|
1341 or return _ioError( "reading end of central directory" ); |
|
1342 |
|
1343 my $zipfileCommentLength; |
|
1344 ( |
|
1345 $self->{'diskNumber'}, |
|
1346 $self->{'diskNumberWithStartOfCentralDirectory'}, |
|
1347 $self->{'numberOfCentralDirectoriesOnThisDisk'}, |
|
1348 $self->{'numberOfCentralDirectories'}, |
|
1349 $self->{'centralDirectorySize'}, |
|
1350 $self->{'centralDirectoryOffsetWRTStartingDiskNumber'}, |
|
1351 $zipfileCommentLength |
|
1352 ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header ); |
|
1353 |
|
1354 if ( $zipfileCommentLength ) |
|
1355 { |
|
1356 my $zipfileComment = ''; |
|
1357 $fh->read( $zipfileComment, $zipfileCommentLength ) |
|
1358 or return _ioError( "reading zipfile comment" ); |
|
1359 $self->{'zipfileComment'} = $zipfileComment; |
|
1360 } |
|
1361 |
|
1362 return AZ_OK; |
|
1363 } |
|
1364 |
|
1365 # Seek in my file to the end, then read backwards until we find the |
|
1366 # signature of the central directory record. Leave the file positioned right |
|
1367 # before the signature. Returns AZ_OK if success. |
|
1368 sub _findEndOfCentralDirectory # Archive::Zip::Archive |
|
1369 { |
|
1370 my $self = shift; |
|
1371 my $fh = shift; |
|
1372 my $data = ''; |
|
1373 $fh->seek( 0, IO::Seekable::SEEK_END ) |
|
1374 or return _ioError( "seeking to end" ); |
|
1375 |
|
1376 my $fileLength = $fh->tell(); |
|
1377 if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) |
|
1378 { |
|
1379 return _formatError( "file is too short" ) |
|
1380 } |
|
1381 |
|
1382 my $seekOffset = 0; |
|
1383 my $pos = -1; |
|
1384 for ( ;; ) |
|
1385 { |
|
1386 $seekOffset += 512; |
|
1387 $seekOffset = $fileLength if ( $seekOffset > $fileLength ); |
|
1388 $fh->seek( -$seekOffset, IO::Seekable::SEEK_END ) |
|
1389 or return _ioError( "seek failed" ); |
|
1390 $fh->read( $data, $seekOffset ) |
|
1391 or return _ioError( "read failed" ); |
|
1392 $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING ); |
|
1393 last if ( $pos > 0 |
|
1394 or $seekOffset == $fileLength |
|
1395 or $seekOffset >= $Archive::Zip::ChunkSize ); |
|
1396 } |
|
1397 |
|
1398 if ( $pos >= 0 ) |
|
1399 { |
|
1400 $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR ) |
|
1401 or return _ioError( "seeking to EOCD" ); |
|
1402 return AZ_OK; |
|
1403 } |
|
1404 else |
|
1405 { |
|
1406 return _formatError( "can't find EOCD signature" ); |
|
1407 } |
|
1408 } |
|
1409 |
|
1410 =back |
|
1411 |
|
1412 =head1 MEMBER OPERATIONS |
|
1413 |
|
1414 =head2 Class Methods |
|
1415 |
|
1416 Several constructors allow you to construct members without adding |
|
1417 them to a zip archive. |
|
1418 |
|
1419 These work the same as the addFile(), addDirectory(), and addString() |
|
1420 zip instance methods described above, but they don't add the new members |
|
1421 to a zip. |
|
1422 |
|
1423 =over 4 |
|
1424 |
|
1425 =cut |
|
1426 |
|
1427 # ---------------------------------------------------------------------- |
|
1428 # class Archive::Zip::Member |
|
1429 # A generic member of an archive ( abstract ) |
|
1430 # ---------------------------------------------------------------------- |
|
1431 package Archive::Zip::Member; |
|
1432 use vars qw( @ISA ); |
|
1433 @ISA = qw ( Archive::Zip ); |
|
1434 |
|
1435 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS |
|
1436 :UTILITY_METHODS ) } |
|
1437 |
|
1438 use Time::Local (); |
|
1439 use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS ); |
|
1440 use File::Path; |
|
1441 use File::Basename; |
|
1442 |
|
1443 use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember'; |
|
1444 use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember'; |
|
1445 use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember'; |
|
1446 use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember'; |
|
1447 |
|
1448 # Unix perms for default creation of files/dirs. |
|
1449 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755; |
|
1450 use constant DEFAULT_FILE_PERMISSIONS => 0100666; |
|
1451 use constant DIRECTORY_ATTRIB => 040000; |
|
1452 use constant FILE_ATTRIB => 0100000; |
|
1453 |
|
1454 # Returns self if successful, else undef |
|
1455 # Assumes that fh is positioned at beginning of central directory file header. |
|
1456 # Leaves fh positioned immediately after file header or EOCD signature. |
|
1457 sub _newFromZipFile # Archive::Zip::Member |
|
1458 { |
|
1459 my $class = shift; |
|
1460 my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile( @_ ); |
|
1461 return $self; |
|
1462 } |
|
1463 |
|
1464 #-------------------------------- |
|
1465 |
|
1466 =item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName] ) |
|
1467 |
|
1468 Construct a new member from the given string. Returns undef on error. |
|
1469 |
|
1470 my $member = Archive::Zip::Member->newFromString( 'This is a test', |
|
1471 'xyz.txt' ); |
|
1472 |
|
1473 =cut |
|
1474 |
|
1475 sub newFromString # Archive::Zip::Member |
|
1476 { |
|
1477 my $class = shift; |
|
1478 my $self = $class->STRINGMEMBERCLASS->_newFromString( @_ ); |
|
1479 return $self; |
|
1480 } |
|
1481 |
|
1482 #-------------------------------- |
|
1483 |
|
1484 =item newFromFile( $fileName ) |
|
1485 |
|
1486 Construct a new member from the given file. Returns undef on error. |
|
1487 |
|
1488 my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' ); |
|
1489 |
|
1490 =cut |
|
1491 |
|
1492 sub newFromFile # Archive::Zip::Member |
|
1493 { |
|
1494 my $class = shift; |
|
1495 my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed( @_ ); |
|
1496 return $self; |
|
1497 } |
|
1498 |
|
1499 #-------------------------------- |
|
1500 |
|
1501 =item newDirectoryNamed( $directoryName ) |
|
1502 |
|
1503 Construct a new member from the given directory. |
|
1504 Returns undef on error. |
|
1505 |
|
1506 my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' ); |
|
1507 |
|
1508 =cut |
|
1509 |
|
1510 sub newDirectoryNamed # Archive::Zip::Member |
|
1511 { |
|
1512 my $class = shift; |
|
1513 my $self = $class->DIRECTORYMEMBERCLASS->_newNamed( @_ ); |
|
1514 return $self; |
|
1515 } |
|
1516 |
|
1517 sub new # Archive::Zip::Member |
|
1518 { |
|
1519 my $class = shift; |
|
1520 my $self = { |
|
1521 'lastModFileDateTime' => 0, |
|
1522 'fileAttributeFormat' => FA_UNIX, |
|
1523 'versionMadeBy' => 20, |
|
1524 'versionNeededToExtract' => 20, |
|
1525 'bitFlag' => 0, |
|
1526 'compressionMethod' => COMPRESSION_STORED, |
|
1527 'desiredCompressionMethod' => COMPRESSION_STORED, |
|
1528 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE, |
|
1529 'internalFileAttributes' => 0, |
|
1530 'externalFileAttributes' => 0, # set later |
|
1531 'fileName' => '', |
|
1532 'cdExtraField' => '', |
|
1533 'localExtraField' => '', |
|
1534 'fileComment' => '', |
|
1535 'crc32' => 0, |
|
1536 'compressedSize' => 0, |
|
1537 'uncompressedSize' => 0, |
|
1538 @_ |
|
1539 }; |
|
1540 bless( $self, $class ); |
|
1541 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS ); |
|
1542 return $self; |
|
1543 } |
|
1544 |
|
1545 sub _becomeDirectoryIfNecessary # Archive::Zip::Member |
|
1546 { |
|
1547 my $self = shift; |
|
1548 $self->_become( DIRECTORYMEMBERCLASS ) |
|
1549 if $self->isDirectory(); |
|
1550 return $self; |
|
1551 } |
|
1552 |
|
1553 # Morph into given class (do whatever cleanup I need to do) |
|
1554 sub _become # Archive::Zip::Member |
|
1555 { |
|
1556 return bless( $_[0], $_[1] ); |
|
1557 } |
|
1558 |
|
1559 =back |
|
1560 |
|
1561 =head2 Simple accessors |
|
1562 |
|
1563 These methods get (and/or set) member attribute values. |
|
1564 |
|
1565 =over 4 |
|
1566 |
|
1567 =cut |
|
1568 |
|
1569 #-------------------------------- |
|
1570 |
|
1571 =item versionMadeBy() |
|
1572 |
|
1573 Gets the field from my member header. |
|
1574 |
|
1575 =cut |
|
1576 |
|
1577 sub versionMadeBy # Archive::Zip::Member |
|
1578 { shift->{'versionMadeBy'} } |
|
1579 |
|
1580 #-------------------------------- |
|
1581 |
|
1582 =item fileAttributeFormat( [$format] ) |
|
1583 |
|
1584 Gets or sets the field from the member header. |
|
1585 These are C<FA_*> values. |
|
1586 |
|
1587 =cut |
|
1588 |
|
1589 sub fileAttributeFormat # Archive::Zip::Member |
|
1590 { |
|
1591 ( $#_ > 0 ) ? ( $_[0]->{'fileAttributeFormat'} = $_[1] ) |
|
1592 : $_[0]->{'fileAttributeFormat'} |
|
1593 } |
|
1594 |
|
1595 #-------------------------------- |
|
1596 |
|
1597 =item versionNeededToExtract() |
|
1598 |
|
1599 Gets the field from my member header. |
|
1600 |
|
1601 =cut |
|
1602 |
|
1603 sub versionNeededToExtract # Archive::Zip::Member |
|
1604 { shift->{'versionNeededToExtract'} } |
|
1605 |
|
1606 #-------------------------------- |
|
1607 |
|
1608 =item bitFlag() |
|
1609 |
|
1610 Gets the general purpose bit field from my member header. |
|
1611 This is where the C<GPBF_*> bits live. |
|
1612 |
|
1613 =cut |
|
1614 |
|
1615 sub bitFlag # Archive::Zip::Member |
|
1616 { shift->{'bitFlag'} } |
|
1617 |
|
1618 #-------------------------------- |
|
1619 |
|
1620 =item compressionMethod() |
|
1621 |
|
1622 Returns my compression method. This is the method that is |
|
1623 currently being used to compress my data. |
|
1624 |
|
1625 This will be COMPRESSION_STORED for added string or file members, |
|
1626 or any of the C<COMPRESSION_*> values for members from a zip file. |
|
1627 However, this module can only handle members whose data is in |
|
1628 COMPRESSION_STORED or COMPRESSION_DEFLATED format. |
|
1629 |
|
1630 =cut |
|
1631 |
|
1632 sub compressionMethod # Archive::Zip::Member |
|
1633 { shift->{'compressionMethod'} } |
|
1634 |
|
1635 #-------------------------------- |
|
1636 |
|
1637 =item desiredCompressionMethod( [$method] ) |
|
1638 |
|
1639 Get or set my desiredCompressionMethod |
|
1640 This is the method that will be used to write. |
|
1641 Returns prior desiredCompressionMethod. |
|
1642 |
|
1643 Only COMPRESSION_DEFLATED or COMPRESSION_STORED are valid arguments. |
|
1644 |
|
1645 Changing to COMPRESSION_STORED will change my desiredCompressionLevel |
|
1646 to 0; changing to COMPRESSION_DEFLATED will change my |
|
1647 desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT. |
|
1648 |
|
1649 =cut |
|
1650 |
|
1651 sub desiredCompressionMethod # Archive::Zip::Member |
|
1652 { |
|
1653 my $self = shift; |
|
1654 my $newDesiredCompressionMethod = shift; |
|
1655 my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'}; |
|
1656 if ( defined( $newDesiredCompressionMethod )) |
|
1657 { |
|
1658 $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod; |
|
1659 if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) |
|
1660 { |
|
1661 $self->{'desiredCompressionLevel'} = 0; |
|
1662 } |
|
1663 elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) |
|
1664 { |
|
1665 $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT; |
|
1666 } |
|
1667 } |
|
1668 return $oldDesiredCompressionMethod; |
|
1669 } |
|
1670 |
|
1671 #-------------------------------- |
|
1672 |
|
1673 =item desiredCompressionLevel( [$method] ) |
|
1674 |
|
1675 Get or set my desiredCompressionLevel |
|
1676 This is the method that will be used to write. |
|
1677 Returns prior desiredCompressionLevel. |
|
1678 |
|
1679 Valid arguments are 0 through 9, COMPRESSION_LEVEL_NONE, |
|
1680 COMPRESSION_LEVEL_DEFAULT, COMPRESSION_LEVEL_BEST_COMPRESSION, and |
|
1681 COMPRESSION_LEVEL_FASTEST. |
|
1682 |
|
1683 0 or COMPRESSION_LEVEL_NONE will change the desiredCompressionMethod |
|
1684 to COMPRESSION_STORED. All other arguments will change the |
|
1685 desiredCompressionMethod to COMPRESSION_DEFLATED. |
|
1686 |
|
1687 =cut |
|
1688 |
|
1689 sub desiredCompressionLevel # Archive::Zip::Member |
|
1690 { |
|
1691 my $self = shift; |
|
1692 my $newDesiredCompressionLevel = shift; |
|
1693 my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'}; |
|
1694 if ( defined( $newDesiredCompressionLevel )) |
|
1695 { |
|
1696 $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel; |
|
1697 $self->{'desiredCompressionMethod'} = ( $newDesiredCompressionLevel |
|
1698 ? COMPRESSION_DEFLATED |
|
1699 : COMPRESSION_STORED ); |
|
1700 } |
|
1701 return $oldDesiredCompressionLevel; |
|
1702 } |
|
1703 |
|
1704 #-------------------------------- |
|
1705 |
|
1706 =item fileName() |
|
1707 |
|
1708 Get or set my internal filename. |
|
1709 Returns the (possibly new) filename. |
|
1710 |
|
1711 Names will have backslashes converted to forward slashes, |
|
1712 and will have multiple consecutive slashes converted to single ones. |
|
1713 |
|
1714 =cut |
|
1715 |
|
1716 sub fileName # Archive::Zip::Member |
|
1717 { |
|
1718 my $self = shift; |
|
1719 my $newName = shift; |
|
1720 if ( $newName ) |
|
1721 { |
|
1722 $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems |
|
1723 $self->{'fileName'} = $newName; |
|
1724 } |
|
1725 return $self->{'fileName'} |
|
1726 } |
|
1727 |
|
1728 #-------------------------------- |
|
1729 |
|
1730 =item lastModFileDateTime() |
|
1731 |
|
1732 Return my last modification date/time stamp in MS-DOS format. |
|
1733 |
|
1734 =cut |
|
1735 |
|
1736 sub lastModFileDateTime # Archive::Zip::Member |
|
1737 { shift->{'lastModFileDateTime'} } |
|
1738 |
|
1739 #-------------------------------- |
|
1740 |
|
1741 =item lastModTime() |
|
1742 |
|
1743 Return my last modification date/time stamp, |
|
1744 converted to unix localtime format. |
|
1745 |
|
1746 print "Mod Time: " . scalar( localtime( $member->lastModTime() ) ); |
|
1747 |
|
1748 =cut |
|
1749 |
|
1750 sub lastModTime # Archive::Zip::Member |
|
1751 { |
|
1752 my $self = shift; |
|
1753 return _dosToUnixTime( $self->lastModFileDateTime() ); |
|
1754 } |
|
1755 |
|
1756 #-------------------------------- |
|
1757 |
|
1758 =item setLastModFileDateTimeFromUnix() |
|
1759 |
|
1760 Set my lastModFileDateTime from the given unix time. |
|
1761 |
|
1762 $member->setLastModFileDateTimeFromUnix( time() ); |
|
1763 |
|
1764 =cut |
|
1765 |
|
1766 sub setLastModFileDateTimeFromUnix # Archive::Zip::Member |
|
1767 { |
|
1768 my $self = shift; |
|
1769 my $time_t = shift; |
|
1770 $self->{'lastModFileDateTime'} = _unixToDosTime( $time_t ); |
|
1771 } |
|
1772 |
|
1773 # Convert DOS date/time format to unix time_t format |
|
1774 # NOT AN OBJECT METHOD! |
|
1775 sub _dosToUnixTime # Archive::Zip::Member |
|
1776 { |
|
1777 my $dt = shift; |
|
1778 |
|
1779 my $year = ( ( $dt >> 25 ) & 0x7f ) + 80; |
|
1780 my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1; |
|
1781 my $mday = ( ( $dt >> 16 ) & 0x1f ); |
|
1782 |
|
1783 my $hour = ( ( $dt >> 11 ) & 0x1f ); |
|
1784 my $min = ( ( $dt >> 5 ) & 0x3f ); |
|
1785 my $sec = ( ( $dt << 1 ) & 0x3e ); |
|
1786 |
|
1787 my $time_t = Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); |
|
1788 return $time_t; |
|
1789 } |
|
1790 |
|
1791 #-------------------------------- |
|
1792 |
|
1793 =item internalFileAttributes() |
|
1794 |
|
1795 Return the internal file attributes field from the zip header. |
|
1796 This is only set for members read from a zip file. |
|
1797 |
|
1798 =cut |
|
1799 |
|
1800 sub internalFileAttributes # Archive::Zip::Member |
|
1801 { shift->{'internalFileAttributes'} } |
|
1802 |
|
1803 #-------------------------------- |
|
1804 |
|
1805 =item externalFileAttributes() |
|
1806 |
|
1807 Return member attributes as read from the ZIP file. |
|
1808 Note that these are NOT UNIX! |
|
1809 |
|
1810 =cut |
|
1811 |
|
1812 sub externalFileAttributes # Archive::Zip::Member |
|
1813 { shift->{'externalFileAttributes'} } |
|
1814 |
|
1815 # Convert UNIX permissions into proper value for zip file |
|
1816 # NOT A METHOD! |
|
1817 sub _mapPermissionsFromUnix # Archive::Zip::Member |
|
1818 { |
|
1819 my $perms = shift; |
|
1820 return $perms << 16; |
|
1821 } |
|
1822 |
|
1823 # Convert ZIP permissions into Unix ones |
|
1824 # NOT A METHOD! |
|
1825 sub _mapPermissionsToUnix # Archive::Zip::Member |
|
1826 { |
|
1827 my $perms = shift; |
|
1828 return $perms >> 16; |
|
1829 } |
|
1830 |
|
1831 #-------------------------------- |
|
1832 |
|
1833 =item unixFileAttributes( [$newAttributes] ) |
|
1834 |
|
1835 Get or set the member's file attributes using UNIX file attributes. |
|
1836 Returns old attributes. |
|
1837 |
|
1838 my $oldAttribs = $member->unixFileAttributes( 0666 ); |
|
1839 |
|
1840 Note that the return value has more than just the file permissions, |
|
1841 so you will have to mask off the lowest bits for comparisions. |
|
1842 |
|
1843 =cut |
|
1844 |
|
1845 sub unixFileAttributes # Archive::Zip::Member |
|
1846 { |
|
1847 my $self = shift; |
|
1848 my $oldPerms = _mapPermissionsToUnix( $self->{'externalFileAttributes'} ); |
|
1849 if ( @_ ) |
|
1850 { |
|
1851 my $perms = shift; |
|
1852 if ( $self->isDirectory() ) |
|
1853 { |
|
1854 $perms &= ~FILE_ATTRIB; |
|
1855 $perms |= DIRECTORY_ATTRIB; |
|
1856 } |
|
1857 else |
|
1858 { |
|
1859 $perms &= ~DIRECTORY_ATTRIB; |
|
1860 $perms |= FILE_ATTRIB; |
|
1861 } |
|
1862 $self->{'externalFileAttributes'} = _mapPermissionsFromUnix( $perms); |
|
1863 } |
|
1864 return $oldPerms; |
|
1865 } |
|
1866 |
|
1867 #-------------------------------- |
|
1868 |
|
1869 =item localExtraField( [$newField] ) |
|
1870 |
|
1871 Gets or sets the extra field that was read from the local header. |
|
1872 This is not set for a member from a zip file until after the |
|
1873 member has been written out. |
|
1874 |
|
1875 The extra field must be in the proper format. |
|
1876 |
|
1877 =cut |
|
1878 |
|
1879 sub localExtraField # Archive::Zip::Member |
|
1880 { |
|
1881 ( $#_ > 0 ) ? ( $_[0]->{'localExtraField'} = $_[1] ) |
|
1882 : $_[0]->{'localExtraField'} |
|
1883 } |
|
1884 |
|
1885 #-------------------------------- |
|
1886 |
|
1887 =item cdExtraField( [$newField] ) |
|
1888 |
|
1889 Gets or sets the extra field that was read from the central directory header. |
|
1890 |
|
1891 The extra field must be in the proper format. |
|
1892 |
|
1893 =cut |
|
1894 |
|
1895 sub cdExtraField # Archive::Zip::Member |
|
1896 { |
|
1897 ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) |
|
1898 : $_[0]->{'cdExtraField'} |
|
1899 } |
|
1900 |
|
1901 #-------------------------------- |
|
1902 |
|
1903 =item extraFields() |
|
1904 |
|
1905 Return both local and CD extra fields, concatenated. |
|
1906 |
|
1907 =cut |
|
1908 |
|
1909 sub extraFields # Archive::Zip::Member |
|
1910 { |
|
1911 my $self = shift; |
|
1912 return $self->localExtraField() . $self->cdExtraField(); |
|
1913 } |
|
1914 |
|
1915 #-------------------------------- |
|
1916 |
|
1917 =item fileComment( [$newComment] ) |
|
1918 |
|
1919 Get or set the member's file comment. |
|
1920 |
|
1921 =cut |
|
1922 |
|
1923 sub fileComment # Archive::Zip::Member |
|
1924 { |
|
1925 ( $#_ > 0 ) ? ( $_[0]->{'fileComment'} = $_[1] ) |
|
1926 : $_[0]->{'fileComment'} |
|
1927 } |
|
1928 |
|
1929 #-------------------------------- |
|
1930 |
|
1931 =item hasDataDescriptor() |
|
1932 |
|
1933 Get or set the data descriptor flag. |
|
1934 If this is set, the local header will not necessarily |
|
1935 have the correct data sizes. Instead, a small structure |
|
1936 will be stored at the end of the member data with these |
|
1937 values. |
|
1938 |
|
1939 This should be transparent in normal operation. |
|
1940 |
|
1941 =cut |
|
1942 |
|
1943 sub hasDataDescriptor # Archive::Zip::Member |
|
1944 { |
|
1945 my $self = shift; |
|
1946 if ( @_ ) |
|
1947 { |
|
1948 my $shouldHave = shift; |
|
1949 if ( $shouldHave ) |
|
1950 { |
|
1951 $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK |
|
1952 } |
|
1953 else |
|
1954 { |
|
1955 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK |
|
1956 } |
|
1957 } |
|
1958 return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK; |
|
1959 } |
|
1960 |
|
1961 #-------------------------------- |
|
1962 |
|
1963 =item crc32() |
|
1964 |
|
1965 Return the CRC-32 value for this member. |
|
1966 This will not be set for members that were constructed from strings |
|
1967 or external files until after the member has been written. |
|
1968 |
|
1969 =cut |
|
1970 |
|
1971 sub crc32 # Archive::Zip::Member |
|
1972 { shift->{'crc32'} } |
|
1973 |
|
1974 #-------------------------------- |
|
1975 |
|
1976 =item crc32String() |
|
1977 |
|
1978 Return the CRC-32 value for this member as an 8 character printable |
|
1979 hex string. This will not be set for members that were constructed |
|
1980 from strings or external files until after the member has been written. |
|
1981 |
|
1982 =cut |
|
1983 |
|
1984 sub crc32String # Archive::Zip::Member |
|
1985 { sprintf( "%08x", shift->{'crc32'} ); } |
|
1986 |
|
1987 #-------------------------------- |
|
1988 |
|
1989 =item compressedSize() |
|
1990 |
|
1991 Return the compressed size for this member. |
|
1992 This will not be set for members that were constructed from strings |
|
1993 or external files until after the member has been written. |
|
1994 |
|
1995 =cut |
|
1996 |
|
1997 sub compressedSize # Archive::Zip::Member |
|
1998 { shift->{'compressedSize'} } |
|
1999 |
|
2000 #-------------------------------- |
|
2001 |
|
2002 =item uncompressedSize() |
|
2003 |
|
2004 Return the uncompressed size for this member. |
|
2005 |
|
2006 =cut |
|
2007 |
|
2008 sub uncompressedSize # Archive::Zip::Member |
|
2009 { shift->{'uncompressedSize'} } |
|
2010 |
|
2011 #-------------------------------- |
|
2012 |
|
2013 =item isEncrypted() |
|
2014 |
|
2015 Return true if this member is encrypted. |
|
2016 The Archive::Zip module does not currently create or extract |
|
2017 encrypted members. |
|
2018 |
|
2019 =cut |
|
2020 |
|
2021 sub isEncrypted # Archive::Zip::Member |
|
2022 { shift->bitFlag() & GPBF_ENCRYPTED_MASK } |
|
2023 |
|
2024 |
|
2025 #-------------------------------- |
|
2026 |
|
2027 =item isTextFile( [$flag] ) |
|
2028 |
|
2029 Returns true if I am a text file. |
|
2030 Also can set the status if given an argument (then returns old state). |
|
2031 Note that this module does not currently do anything with this flag |
|
2032 upon extraction or storage. |
|
2033 That is, bytes are stored in native format whether or not they came |
|
2034 from a text file. |
|
2035 |
|
2036 =cut |
|
2037 |
|
2038 sub isTextFile # Archive::Zip::Member |
|
2039 { |
|
2040 my $self = shift; |
|
2041 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; |
|
2042 if ( @_ ) |
|
2043 { |
|
2044 my $flag = shift; |
|
2045 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; |
|
2046 $self->{'internalFileAttributes'} |= |
|
2047 ( $flag ? IFA_TEXT_FILE : IFA_BINARY_FILE ); |
|
2048 } |
|
2049 return $bit == IFA_TEXT_FILE; |
|
2050 } |
|
2051 |
|
2052 #-------------------------------- |
|
2053 |
|
2054 =item isBinaryFile() |
|
2055 |
|
2056 Returns true if I am a binary file. |
|
2057 Also can set the status if given an argument (then returns old state). |
|
2058 Note that this module does not currently do anything with this flag |
|
2059 upon extraction or storage. |
|
2060 That is, bytes are stored in native format whether or not they came |
|
2061 from a text file. |
|
2062 |
|
2063 =cut |
|
2064 |
|
2065 sub isBinaryFile # Archive::Zip::Member |
|
2066 { |
|
2067 my $self = shift; |
|
2068 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK; |
|
2069 if ( @_ ) |
|
2070 { |
|
2071 my $flag = shift; |
|
2072 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK; |
|
2073 $self->{'internalFileAttributes'} |= |
|
2074 ( $flag ? IFA_BINARY_FILE : IFA_TEXT_FILE ); |
|
2075 } |
|
2076 return $bit == IFA_BINARY_FILE; |
|
2077 } |
|
2078 |
|
2079 #-------------------------------- |
|
2080 |
|
2081 =item extractToFileNamed( $fileName ) |
|
2082 |
|
2083 Extract me to a file with the given name. |
|
2084 The file will be created with default modes. |
|
2085 Directories will be created as needed. |
|
2086 |
|
2087 Returns AZ_OK on success. |
|
2088 |
|
2089 =cut |
|
2090 |
|
2091 sub extractToFileNamed # Archive::Zip::Member |
|
2092 { |
|
2093 my $self = shift; |
|
2094 my $name = shift; |
|
2095 return _error( "encryption unsupported" ) if $self->isEncrypted(); |
|
2096 mkpath( dirname( $name ) ); # croaks on error |
|
2097 my ( $status, $fh ) = _newFileHandle( $name, 'w' ); |
|
2098 return _ioError( "Can't open file $name for write" ) if !$status; |
|
2099 my $retval = $self->extractToFileHandle( $fh ); |
|
2100 $fh->close(); |
|
2101 return $retval; |
|
2102 } |
|
2103 |
|
2104 #-------------------------------- |
|
2105 |
|
2106 =item isDirectory() |
|
2107 |
|
2108 Returns true if I am a directory. |
|
2109 |
|
2110 =cut |
|
2111 |
|
2112 sub isDirectory # Archive::Zip::Member |
|
2113 { return 0 } |
|
2114 |
|
2115 # The following are used when copying data |
|
2116 sub _writeOffset # Archive::Zip::Member |
|
2117 { shift->{'writeOffset'} } |
|
2118 |
|
2119 sub _readOffset # Archive::Zip::Member |
|
2120 { shift->{'readOffset'} } |
|
2121 |
|
2122 sub _writeLocalHeaderRelativeOffset # Archive::Zip::Member |
|
2123 { shift->{'writeLocalHeaderRelativeOffset'} } |
|
2124 |
|
2125 sub _dataEnded # Archive::Zip::Member |
|
2126 { shift->{'dataEnded'} } |
|
2127 |
|
2128 sub _readDataRemaining # Archive::Zip::Member |
|
2129 { shift->{'readDataRemaining'} } |
|
2130 |
|
2131 sub _inflater # Archive::Zip::Member |
|
2132 { shift->{'inflater'} } |
|
2133 |
|
2134 sub _deflater # Archive::Zip::Member |
|
2135 { shift->{'deflater'} } |
|
2136 |
|
2137 # Return the total size of my local header |
|
2138 sub _localHeaderSize # Archive::Zip::Member |
|
2139 { |
|
2140 my $self = shift; |
|
2141 return SIGNATURE_LENGTH |
|
2142 + LOCAL_FILE_HEADER_LENGTH |
|
2143 + length( $self->fileName() ) |
|
2144 + length( $self->localExtraField() ) |
|
2145 } |
|
2146 |
|
2147 # Return the total size of my CD header |
|
2148 sub _centralDirectoryHeaderSize # Archive::Zip::Member |
|
2149 { |
|
2150 my $self = shift; |
|
2151 return SIGNATURE_LENGTH |
|
2152 + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH |
|
2153 + length( $self->fileName() ) |
|
2154 + length( $self->cdExtraField() ) |
|
2155 + length( $self->fileComment() ) |
|
2156 } |
|
2157 |
|
2158 # convert a unix time to DOS date/time |
|
2159 # NOT AN OBJECT METHOD! |
|
2160 sub _unixToDosTime # Archive::Zip::Member |
|
2161 { |
|
2162 my $time_t = shift; |
|
2163 my ( $sec,$min,$hour,$mday,$mon,$year ) = localtime( $time_t ); |
|
2164 my $dt = 0; |
|
2165 $dt += ( $sec >> 1 ); |
|
2166 $dt += ( $min << 5 ); |
|
2167 $dt += ( $hour << 11 ); |
|
2168 $dt += ( $mday << 16 ); |
|
2169 $dt += ( ( $mon + 1 ) << 21 ); |
|
2170 $dt += ( ( $year - 80 ) << 25 ); |
|
2171 return $dt; |
|
2172 } |
|
2173 |
|
2174 # Write my local header to a file handle. |
|
2175 # Stores the offset to the start of the header in my |
|
2176 # writeLocalHeaderRelativeOffset member. |
|
2177 # Returns AZ_OK on success. |
|
2178 sub _writeLocalFileHeader # Archive::Zip::Member |
|
2179 { |
|
2180 my $self = shift; |
|
2181 my $fh = shift; |
|
2182 |
|
2183 my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE ); |
|
2184 $fh->write( $signatureData, SIGNATURE_LENGTH ) |
|
2185 or return _ioError( "writing local header signature" ); |
|
2186 |
|
2187 my $header = pack( LOCAL_FILE_HEADER_FORMAT, |
|
2188 $self->versionNeededToExtract(), |
|
2189 $self->bitFlag(), |
|
2190 $self->desiredCompressionMethod(), |
|
2191 $self->lastModFileDateTime(), |
|
2192 $self->crc32(), |
|
2193 $self->compressedSize(), # may need to be re-written later |
|
2194 $self->uncompressedSize(), |
|
2195 length( $self->fileName() ), |
|
2196 length( $self->localExtraField() ) |
|
2197 ); |
|
2198 |
|
2199 $fh->write( $header, LOCAL_FILE_HEADER_LENGTH ) |
|
2200 or return _ioError( "writing local header" ); |
|
2201 if ( length( $self->fileName() )) |
|
2202 { |
|
2203 $fh->write( $self->fileName(), length( $self->fileName() )) |
|
2204 or return _ioError( "writing local header filename" ); |
|
2205 } |
|
2206 if ( length( $self->localExtraField() )) |
|
2207 { |
|
2208 $fh->write( $self->localExtraField(), length( $self->localExtraField() )) |
|
2209 or return _ioError( "writing local header signature" ); |
|
2210 } |
|
2211 |
|
2212 return AZ_OK; |
|
2213 } |
|
2214 |
|
2215 sub _writeCentralDirectoryFileHeader # Archive::Zip::Member |
|
2216 { |
|
2217 my $self = shift; |
|
2218 my $fh = shift; |
|
2219 |
|
2220 my $sigData = pack( SIGNATURE_FORMAT, |
|
2221 CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE ); |
|
2222 $fh->write( $sigData, SIGNATURE_LENGTH ) |
|
2223 or return _ioError( "writing central directory header signature" ); |
|
2224 |
|
2225 my $fileNameLength = length( $self->fileName() ); |
|
2226 my $extraFieldLength = length( $self->cdExtraField() ); |
|
2227 my $fileCommentLength = length( $self->fileComment() ); |
|
2228 |
|
2229 my $header = pack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, |
|
2230 $self->versionMadeBy(), |
|
2231 $self->fileAttributeFormat(), |
|
2232 $self->versionNeededToExtract(), |
|
2233 $self->bitFlag(), |
|
2234 $self->desiredCompressionMethod(), |
|
2235 $self->lastModFileDateTime(), |
|
2236 $self->crc32(), # these three fields should have been updated |
|
2237 $self->_writeOffset(), # by writing the data stream out |
|
2238 $self->uncompressedSize(), # |
|
2239 $fileNameLength, |
|
2240 $extraFieldLength, |
|
2241 $fileCommentLength, |
|
2242 0, # {'diskNumberStart'}, |
|
2243 $self->internalFileAttributes(), |
|
2244 $self->externalFileAttributes(), |
|
2245 $self->_writeLocalHeaderRelativeOffset() |
|
2246 ); |
|
2247 |
|
2248 $fh->write( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH ) |
|
2249 or return _ioError( "writing central directory header" ); |
|
2250 if ( $fileNameLength ) |
|
2251 { |
|
2252 $fh->write( $self->fileName(), $fileNameLength ) |
|
2253 or return _ioError( "writing central directory header signature" ); |
|
2254 } |
|
2255 if ( $extraFieldLength ) |
|
2256 { |
|
2257 $fh->write( $self->cdExtraField(), $extraFieldLength ) |
|
2258 or return _ioError( "writing central directory extra field" ); |
|
2259 } |
|
2260 if ( $fileCommentLength ) |
|
2261 { |
|
2262 $fh->write( $self->fileComment(), $fileCommentLength ) |
|
2263 or return _ioError( "writing central directory file comment" ); |
|
2264 } |
|
2265 |
|
2266 return AZ_OK; |
|
2267 } |
|
2268 |
|
2269 # This writes a data descriptor to the given file handle. |
|
2270 # Assumes that crc32, writeOffset, and uncompressedSize are |
|
2271 # set correctly (they should be after a write). |
|
2272 # Further, the local file header should have the |
|
2273 # GPBF_HAS_DATA_DESCRIPTOR_MASK bit set. |
|
2274 sub _writeDataDescriptor # Archive::Zip::Member |
|
2275 { |
|
2276 my $self = shift; |
|
2277 my $fh = shift; |
|
2278 my $header = pack( DATA_DESCRIPTOR_FORMAT, |
|
2279 $self->crc32(), |
|
2280 $self->_writeOffset(), |
|
2281 $self->uncompressedSize() |
|
2282 ); |
|
2283 |
|
2284 $fh->write( $header, DATA_DESCRIPTOR_LENGTH ) |
|
2285 or return _ioError( "writing data descriptor" ); |
|
2286 return AZ_OK; |
|
2287 } |
|
2288 |
|
2289 # Re-writes the local file header with new crc32 and compressedSize fields. |
|
2290 # To be called after writing the data stream. |
|
2291 # Assumes that filename and extraField sizes didn't change since last written. |
|
2292 sub _refreshLocalFileHeader # Archive::Zip::Member |
|
2293 { |
|
2294 my $self = shift; |
|
2295 my $fh = shift; |
|
2296 |
|
2297 my $here = $fh->tell(); |
|
2298 $fh->seek( $self->_writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH, |
|
2299 IO::Seekable::SEEK_SET ) |
|
2300 or return _ioError( "seeking to rewrite local header" ); |
|
2301 |
|
2302 my $header = pack( LOCAL_FILE_HEADER_FORMAT, |
|
2303 $self->versionNeededToExtract(), |
|
2304 $self->bitFlag(), |
|
2305 $self->desiredCompressionMethod(), |
|
2306 $self->lastModFileDateTime(), |
|
2307 $self->crc32(), |
|
2308 $self->_writeOffset(), |
|
2309 $self->uncompressedSize(), |
|
2310 length( $self->fileName() ), |
|
2311 length( $self->localExtraField() ) |
|
2312 ); |
|
2313 |
|
2314 $fh->write( $header, LOCAL_FILE_HEADER_LENGTH ) |
|
2315 or return _ioError( "re-writing local header" ); |
|
2316 $fh->seek( $here, IO::Seekable::SEEK_SET ) |
|
2317 or return _ioError( "seeking after rewrite of local header" ); |
|
2318 |
|
2319 return AZ_OK; |
|
2320 } |
|
2321 |
|
2322 =back |
|
2323 |
|
2324 =head2 Low-level member data reading |
|
2325 |
|
2326 It is possible to use lower-level routines to access member |
|
2327 data streams, rather than the extract* methods and contents(). |
|
2328 |
|
2329 For instance, here is how to print the uncompressed contents |
|
2330 of a member in chunks using these methods: |
|
2331 |
|
2332 my ( $member, $status, $bufferRef ); |
|
2333 $member = $zip->memberNamed( 'xyz.txt' ); |
|
2334 $member->desiredCompressionMethod( COMPRESSION_STORED ); |
|
2335 $status = $member->rewindData(); |
|
2336 die "error $status" if $status != AZ_OK; |
|
2337 while ( ! $member->readIsDone() ) |
|
2338 { |
|
2339 ( $bufferRef, $status ) = $member->readChunk(); |
|
2340 die "error $status" if $status != AZ_OK; |
|
2341 # do something with $bufferRef: |
|
2342 print $$bufferRef; |
|
2343 } |
|
2344 $member->endRead(); |
|
2345 |
|
2346 =over 4 |
|
2347 |
|
2348 =cut |
|
2349 |
|
2350 #-------------------------------- |
|
2351 |
|
2352 =item readChunk( [$chunkSize] ) |
|
2353 |
|
2354 This reads the next chunk of given size from the member's data stream and |
|
2355 compresses or uncompresses it as necessary, returning a reference to the bytes |
|
2356 read and a status. |
|
2357 If size argument is not given, defaults to global set by |
|
2358 Archive::Zip::setChunkSize. |
|
2359 Status is AZ_OK on success. Returns C<( \$bytes, $status)>. |
|
2360 |
|
2361 my ( $outRef, $status ) = $self->readChunk(); |
|
2362 print $$outRef if $status != AZ_OK; |
|
2363 |
|
2364 =cut |
|
2365 |
|
2366 sub readChunk # Archive::Zip::Member |
|
2367 { |
|
2368 my ( $self, $chunkSize ) = @_; |
|
2369 |
|
2370 if ( $self->readIsDone() ) |
|
2371 { |
|
2372 $self->endRead(); |
|
2373 my $dummy = ''; |
|
2374 return ( \$dummy, AZ_STREAM_END ); |
|
2375 } |
|
2376 |
|
2377 $chunkSize = $Archive::Zip::ChunkSize if not defined( $chunkSize ); |
|
2378 $chunkSize = $self->_readDataRemaining() |
|
2379 if $chunkSize > $self->_readDataRemaining(); |
|
2380 |
|
2381 my $buffer = ''; |
|
2382 my $outputRef; |
|
2383 my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize ); |
|
2384 return ( \$buffer, $status) if $status != AZ_OK; |
|
2385 |
|
2386 $self->{'readDataRemaining'} -= $bytesRead; |
|
2387 $self->{'readOffset'} += $bytesRead; |
|
2388 |
|
2389 if ( $self->compressionMethod() == COMPRESSION_STORED ) |
|
2390 { |
|
2391 $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} ); |
|
2392 } |
|
2393 |
|
2394 ( $outputRef, $status) = &{$self->{'chunkHandler'}}( $self, \$buffer ); |
|
2395 $self->{'writeOffset'} += length( $$outputRef ); |
|
2396 |
|
2397 $self->endRead() |
|
2398 if $self->readIsDone(); |
|
2399 |
|
2400 return ( $outputRef, $status); |
|
2401 } |
|
2402 |
|
2403 # Read the next raw chunk of my data. Subclasses MUST implement. |
|
2404 # my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize ); |
|
2405 sub _readRawChunk # Archive::Zip::Member |
|
2406 { |
|
2407 my $self = shift; |
|
2408 return $self->_subclassResponsibility(); |
|
2409 } |
|
2410 |
|
2411 # A place holder to catch rewindData errors if someone ignores |
|
2412 # the error code. |
|
2413 sub _noChunk # Archive::Zip::Member |
|
2414 { |
|
2415 my $self = shift; |
|
2416 return ( \undef, _error( "trying to copy chunk when init failed" )); |
|
2417 } |
|
2418 |
|
2419 # Basically a no-op so that I can have a consistent interface. |
|
2420 # ( $outputRef, $status) = $self->_copyChunk( \$buffer ); |
|
2421 sub _copyChunk # Archive::Zip::Member |
|
2422 { |
|
2423 my ( $self, $dataRef ) = @_; |
|
2424 return ( $dataRef, AZ_OK ); |
|
2425 } |
|
2426 |
|
2427 |
|
2428 # ( $outputRef, $status) = $self->_deflateChunk( \$buffer ); |
|
2429 sub _deflateChunk # Archive::Zip::Member |
|
2430 { |
|
2431 my ( $self, $buffer ) = @_; |
|
2432 my ( $out, $status ) = $self->_deflater()->deflate( $buffer ); |
|
2433 |
|
2434 if ( $self->_readDataRemaining() == 0 ) |
|
2435 { |
|
2436 my $extraOutput; |
|
2437 ( $extraOutput, $status ) = $self->_deflater()->flush(); |
|
2438 $out .= $extraOutput; |
|
2439 $self->endRead(); |
|
2440 return ( \$out, AZ_STREAM_END ); |
|
2441 } |
|
2442 elsif ( $status == Z_OK ) |
|
2443 { |
|
2444 return ( \$out, AZ_OK ); |
|
2445 } |
|
2446 else |
|
2447 { |
|
2448 $self->endRead(); |
|
2449 my $retval = _error( 'deflate error', $status); |
|
2450 my $dummy = ''; |
|
2451 return ( \$dummy, $retval ); |
|
2452 } |
|
2453 } |
|
2454 |
|
2455 # ( $outputRef, $status) = $self->_inflateChunk( \$buffer ); |
|
2456 sub _inflateChunk # Archive::Zip::Member |
|
2457 { |
|
2458 my ( $self, $buffer ) = @_; |
|
2459 my ( $out, $status ) = $self->_inflater()->inflate( $buffer ); |
|
2460 my $retval; |
|
2461 $self->endRead() if ( $status != Z_OK ); |
|
2462 if ( $status == Z_OK || $status == Z_STREAM_END ) |
|
2463 { |
|
2464 $retval = ( $status == Z_STREAM_END ) |
|
2465 ? AZ_STREAM_END : AZ_OK; |
|
2466 return ( \$out, $retval ); |
|
2467 } |
|
2468 else |
|
2469 { |
|
2470 $retval = _error( 'inflate error', $status); |
|
2471 my $dummy = ''; |
|
2472 return ( \$dummy, $retval ); |
|
2473 } |
|
2474 } |
|
2475 |
|
2476 #-------------------------------- |
|
2477 |
|
2478 =item rewindData() |
|
2479 |
|
2480 Rewind data and set up for reading data streams or writing zip files. |
|
2481 Can take options for C<inflateInit()> or C<deflateInit()>, |
|
2482 but this isn't likely to be necessary. |
|
2483 Subclass overrides should call this method. |
|
2484 Returns C<AZ_OK> on success. |
|
2485 |
|
2486 =cut |
|
2487 |
|
2488 sub rewindData # Archive::Zip::Member |
|
2489 { |
|
2490 my $self = shift; |
|
2491 my $status; |
|
2492 |
|
2493 # set to trap init errors |
|
2494 $self->{'chunkHandler'} = $self->can( '_noChunk' ); |
|
2495 |
|
2496 # Work around WinZip defect with 0-length DEFLATED files |
|
2497 $self->desiredCompressionMethod( COMPRESSION_STORED ) |
|
2498 if $self->uncompressedSize() == 0; |
|
2499 |
|
2500 # assume that we're going to read the whole file, and compute the CRC anew. |
|
2501 $self->{'crc32'} = 0 if ( $self->compressionMethod() == COMPRESSION_STORED ); |
|
2502 |
|
2503 # These are the only combinations of methods we deal with right now. |
|
2504 if ( $self->compressionMethod() == COMPRESSION_STORED |
|
2505 and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) |
|
2506 { |
|
2507 ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit( |
|
2508 '-Level' => $self->desiredCompressionLevel(), |
|
2509 '-WindowBits' => - MAX_WBITS(), # necessary magic |
|
2510 @_ ); # pass additional options |
|
2511 return _error( 'deflateInit error:', $status ) if $status != Z_OK; |
|
2512 $self->{'chunkHandler'} = $self->can( '_deflateChunk' ); |
|
2513 } |
|
2514 elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED |
|
2515 and $self->desiredCompressionMethod() == COMPRESSION_STORED ) |
|
2516 { |
|
2517 ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit( |
|
2518 '-WindowBits' => - MAX_WBITS(), # necessary magic |
|
2519 @_ ); # pass additional options |
|
2520 return _error( 'inflateInit error:', $status ) if $status != Z_OK; |
|
2521 $self->{'chunkHandler'} = $self->can( '_inflateChunk' ); |
|
2522 } |
|
2523 elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() ) |
|
2524 { |
|
2525 $self->{'chunkHandler'} = $self->can( '_copyChunk' ); |
|
2526 } |
|
2527 else |
|
2528 { |
|
2529 return _error( |
|
2530 sprintf( "Unsupported compression combination: read %d, write %d", |
|
2531 $self->compressionMethod(), |
|
2532 $self->desiredCompressionMethod() ) |
|
2533 ); |
|
2534 } |
|
2535 |
|
2536 $self->{'dataEnded'} = 0; |
|
2537 $self->{'readDataRemaining'} = $self->compressedSize(); |
|
2538 $self->{'readOffset'} = 0; |
|
2539 |
|
2540 return AZ_OK; |
|
2541 } |
|
2542 |
|
2543 #-------------------------------- |
|
2544 |
|
2545 =item endRead() |
|
2546 |
|
2547 Reset the read variables and free the inflater or deflater. |
|
2548 Must be called to close files, etc. |
|
2549 |
|
2550 Returns AZ_OK on success. |
|
2551 |
|
2552 =cut |
|
2553 |
|
2554 sub endRead # Archive::Zip::Member |
|
2555 { |
|
2556 my $self = shift; |
|
2557 delete $self->{'inflater'}; |
|
2558 delete $self->{'deflater'}; |
|
2559 $self->{'dataEnded'} = 1; |
|
2560 $self->{'readDataRemaining'} = 0; |
|
2561 return AZ_OK; |
|
2562 } |
|
2563 |
|
2564 #-------------------------------- |
|
2565 |
|
2566 =item readIsDone() |
|
2567 |
|
2568 Return true if the read has run out of data or errored out. |
|
2569 |
|
2570 =cut |
|
2571 |
|
2572 sub readIsDone # Archive::Zip::Member |
|
2573 { |
|
2574 my $self = shift; |
|
2575 return ( $self->_dataEnded() or ! $self->_readDataRemaining() ); |
|
2576 } |
|
2577 |
|
2578 #-------------------------------- |
|
2579 |
|
2580 =item contents() |
|
2581 |
|
2582 Return the entire uncompressed member data or undef in scalar context. |
|
2583 When called in array context, returns C<( $string, $status )>; status |
|
2584 will be AZ_OK on success: |
|
2585 |
|
2586 my $string = $member->contents(); |
|
2587 # or |
|
2588 my ( $string, $status ) = $member->contents(); |
|
2589 die "error $status" if $status != AZ_OK; |
|
2590 |
|
2591 Can also be used to set the contents of a member (this may change |
|
2592 the class of the member): |
|
2593 |
|
2594 $member->contents( "this is my new contents" ); |
|
2595 |
|
2596 =cut |
|
2597 |
|
2598 sub contents # Archive::Zip::Member |
|
2599 { |
|
2600 my $self = shift; |
|
2601 my $newContents = shift; |
|
2602 if ( defined( $newContents ) ) |
|
2603 { |
|
2604 $self->_become( STRINGMEMBERCLASS ); |
|
2605 return $self->contents( $newContents ); |
|
2606 } |
|
2607 else |
|
2608 { |
|
2609 my $oldCompression = |
|
2610 $self->desiredCompressionMethod( COMPRESSION_STORED ); |
|
2611 my $status = $self->rewindData( @_ ); |
|
2612 if ( $status != AZ_OK ) |
|
2613 { |
|
2614 $self->endRead(); |
|
2615 return $status; |
|
2616 } |
|
2617 my $retval = ''; |
|
2618 while ( $status == AZ_OK ) |
|
2619 { |
|
2620 my $ref; |
|
2621 ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() ); |
|
2622 # did we get it in one chunk? |
|
2623 if ( length( $$ref ) == $self->uncompressedSize() ) |
|
2624 { $retval = $$ref } |
|
2625 else |
|
2626 { $retval .= $$ref } |
|
2627 } |
|
2628 $self->desiredCompressionMethod( $oldCompression ); |
|
2629 $self->endRead(); |
|
2630 $status = AZ_OK if $status == AZ_STREAM_END; |
|
2631 $retval = undef if $status != AZ_OK; |
|
2632 return wantarray ? ( $retval, $status ) : $retval; |
|
2633 } |
|
2634 } |
|
2635 |
|
2636 #-------------------------------- |
|
2637 |
|
2638 =item extractToFileHandle( $fh ) |
|
2639 |
|
2640 Extract (and uncompress, if necessary) my contents to the given file handle. |
|
2641 Return AZ_OK on success. |
|
2642 |
|
2643 =cut |
|
2644 |
|
2645 sub extractToFileHandle # Archive::Zip::Member |
|
2646 { |
|
2647 my $self = shift; |
|
2648 return _error( "encryption unsupported" ) if $self->isEncrypted(); |
|
2649 my $fh = shift; |
|
2650 _binmode( $fh ); |
|
2651 my $oldCompression = $self->desiredCompressionMethod( COMPRESSION_STORED ); |
|
2652 my $status = $self->rewindData( @_ ); |
|
2653 $status = $self->_writeData( $fh ) if $status == AZ_OK; |
|
2654 $self->desiredCompressionMethod( $oldCompression ); |
|
2655 $self->endRead(); |
|
2656 return $status; |
|
2657 } |
|
2658 |
|
2659 # write local header and data stream to file handle |
|
2660 sub _writeToFileHandle # Archive::Zip::Member |
|
2661 { |
|
2662 my $self = shift; |
|
2663 my $fh = shift; |
|
2664 my $fhIsSeekable = shift; |
|
2665 |
|
2666 # Determine if I need to write a data descriptor |
|
2667 # I need to do this if I can't refresh the header |
|
2668 # and I don't know compressed size or crc32 fields. |
|
2669 my $headerFieldsUnknown = ( ( $self->uncompressedSize() > 0 ) |
|
2670 and ( $self->compressionMethod() == COMPRESSION_STORED |
|
2671 or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) ); |
|
2672 |
|
2673 my $shouldWriteDataDescriptor = |
|
2674 ( $headerFieldsUnknown and not $fhIsSeekable ); |
|
2675 |
|
2676 $self->hasDataDescriptor( 1 ) |
|
2677 if ( $shouldWriteDataDescriptor ); |
|
2678 |
|
2679 $self->{'writeOffset'} = 0; |
|
2680 |
|
2681 my $status = $self->rewindData(); |
|
2682 ( $status = $self->_writeLocalFileHeader( $fh ) ) |
|
2683 if $status == AZ_OK; |
|
2684 ( $status = $self->_writeData( $fh ) ) |
|
2685 if $status == AZ_OK; |
|
2686 if ( $status == AZ_OK ) |
|
2687 { |
|
2688 if ( $self->hasDataDescriptor() ) |
|
2689 { |
|
2690 $status = $self->_writeDataDescriptor( $fh ); |
|
2691 } |
|
2692 elsif ( $headerFieldsUnknown ) |
|
2693 { |
|
2694 $status = $self->_refreshLocalFileHeader( $fh ); |
|
2695 } |
|
2696 } |
|
2697 |
|
2698 return $status; |
|
2699 } |
|
2700 |
|
2701 # Copy my (possibly compressed) data to given file handle. |
|
2702 # Returns C<AZ_OK> on success |
|
2703 sub _writeData # Archive::Zip::Member |
|
2704 { |
|
2705 my $self = shift; |
|
2706 my $writeFh = shift; |
|
2707 |
|
2708 return AZ_OK if ( $self->uncompressedSize() == 0 ); |
|
2709 my $status; |
|
2710 my $chunkSize = $Archive::Zip::ChunkSize; |
|
2711 while ( $self->_readDataRemaining() > 0 ) |
|
2712 { |
|
2713 my $outRef; |
|
2714 ( $outRef, $status ) = $self->readChunk( $chunkSize ); |
|
2715 return $status if ( $status != AZ_OK and $status != AZ_STREAM_END ); |
|
2716 |
|
2717 $writeFh->write( $$outRef, length( $$outRef ) ) |
|
2718 or return _ioError( "write error during copy" ); |
|
2719 |
|
2720 last if $status == AZ_STREAM_END; |
|
2721 } |
|
2722 return AZ_OK; |
|
2723 } |
|
2724 |
|
2725 |
|
2726 # Return true if I depend on the named file |
|
2727 sub _usesFileNamed |
|
2728 { |
|
2729 return 0; |
|
2730 } |
|
2731 |
|
2732 # ---------------------------------------------------------------------- |
|
2733 # class Archive::Zip::DirectoryMember |
|
2734 # ---------------------------------------------------------------------- |
|
2735 |
|
2736 package Archive::Zip::DirectoryMember; |
|
2737 use File::Path; |
|
2738 |
|
2739 use vars qw( @ISA ); |
|
2740 @ISA = qw ( Archive::Zip::Member ); |
|
2741 BEGIN { use Archive::Zip qw( :ERROR_CODES :UTILITY_METHODS ) } |
|
2742 |
|
2743 sub _newNamed # Archive::Zip::DirectoryMember |
|
2744 { |
|
2745 my $class = shift; |
|
2746 my $name = shift; |
|
2747 my $self = $class->new( @_ ); |
|
2748 $self->fileName( $name ); |
|
2749 if ( -d $name ) |
|
2750 { |
|
2751 my @stat = stat( _ ); |
|
2752 $self->unixFileAttributes( $stat[2] ); |
|
2753 $self->setLastModFileDateTimeFromUnix( $stat[9] ); |
|
2754 } |
|
2755 else |
|
2756 { |
|
2757 $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS ); |
|
2758 $self->setLastModFileDateTimeFromUnix( time() ); |
|
2759 } |
|
2760 return $self; |
|
2761 } |
|
2762 |
|
2763 sub isDirectory # Archive::Zip::DirectoryMember |
|
2764 { return 1; } |
|
2765 |
|
2766 sub extractToFileNamed # Archive::Zip::DirectoryMember |
|
2767 { |
|
2768 my $self = shift; |
|
2769 my $name = shift; |
|
2770 my $attribs = $self->unixFileAttributes() & 07777; |
|
2771 mkpath( $name, 0, $attribs ); # croaks on error |
|
2772 return AZ_OK; |
|
2773 } |
|
2774 |
|
2775 sub fileName # Archive::Zip::DirectoryMember |
|
2776 { |
|
2777 my $self = shift; |
|
2778 my $newName = shift; |
|
2779 $newName =~ s{/?$}{/} if defined( $newName ); |
|
2780 return $self->SUPER::fileName( $newName ); |
|
2781 } |
|
2782 |
|
2783 =back |
|
2784 |
|
2785 =head1 Archive::Zip::FileMember methods |
|
2786 |
|
2787 The Archive::Zip::FileMember class extends Archive::Zip::Member. |
|
2788 It is the base class for both ZipFileMember and NewFileMember classes. |
|
2789 This class adds an C<externalFileName> and an C<fh> member to keep |
|
2790 track of the external file. |
|
2791 |
|
2792 =over 4 |
|
2793 |
|
2794 =cut |
|
2795 |
|
2796 # ---------------------------------------------------------------------- |
|
2797 # class Archive::Zip::FileMember |
|
2798 # Base class for classes that have file handles |
|
2799 # to external files |
|
2800 # ---------------------------------------------------------------------- |
|
2801 |
|
2802 package Archive::Zip::FileMember; |
|
2803 use vars qw( @ISA ); |
|
2804 @ISA = qw ( Archive::Zip::Member ); |
|
2805 BEGIN { use Archive::Zip qw( :UTILITY_METHODS ) } |
|
2806 |
|
2807 #-------------------------------- |
|
2808 |
|
2809 =item externalFileName() |
|
2810 |
|
2811 Return my external filename. |
|
2812 |
|
2813 =cut |
|
2814 |
|
2815 sub externalFileName # Archive::Zip::FileMember |
|
2816 { shift->{'externalFileName'} } |
|
2817 |
|
2818 #-------------------------------- |
|
2819 |
|
2820 # Return true if I depend on the named file |
|
2821 sub _usesFileNamed |
|
2822 { |
|
2823 my $self = shift; |
|
2824 my $fileName = shift; |
|
2825 return $self->externalFileName eq $fileName; |
|
2826 } |
|
2827 |
|
2828 =item fh() |
|
2829 |
|
2830 Return my read file handle. |
|
2831 Automatically opens file if necessary. |
|
2832 |
|
2833 =cut |
|
2834 |
|
2835 sub fh # Archive::Zip::FileMember |
|
2836 { |
|
2837 my $self = shift; |
|
2838 $self->_openFile() if ! $self->{'fh'}; |
|
2839 return $self->{'fh'}; |
|
2840 } |
|
2841 |
|
2842 # opens my file handle from my file name |
|
2843 sub _openFile # Archive::Zip::FileMember |
|
2844 { |
|
2845 my $self = shift; |
|
2846 my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' ); |
|
2847 if ( !$status ) |
|
2848 { |
|
2849 _ioError( "Can't open", $self->externalFileName() ); |
|
2850 return undef; |
|
2851 } |
|
2852 $self->{'fh'} = $fh; |
|
2853 _binmode( $fh ); |
|
2854 return $fh; |
|
2855 } |
|
2856 |
|
2857 # Closes my file handle |
|
2858 sub _closeFile # Archive::Zip::FileMember |
|
2859 { |
|
2860 my $self = shift; |
|
2861 $self->{'fh'} = undef; |
|
2862 } |
|
2863 |
|
2864 # Make sure I close my file handle |
|
2865 sub endRead # Archive::Zip::FileMember |
|
2866 { |
|
2867 my $self = shift; |
|
2868 $self->_closeFile(); |
|
2869 return $self->SUPER::endRead( @_ ); |
|
2870 } |
|
2871 |
|
2872 sub _become # Archive::Zip::FileMember |
|
2873 { |
|
2874 my $self = shift; |
|
2875 my $newClass = shift; |
|
2876 return $self if ref( $self ) eq $newClass; |
|
2877 delete( $self->{'externalFileName'} ); |
|
2878 delete( $self->{'fh'} ); |
|
2879 return $self->SUPER::_become( $newClass ); |
|
2880 } |
|
2881 |
|
2882 # ---------------------------------------------------------------------- |
|
2883 # class Archive::Zip::NewFileMember |
|
2884 # Used when adding a pre-existing file to an archive |
|
2885 # ---------------------------------------------------------------------- |
|
2886 |
|
2887 package Archive::Zip::NewFileMember; |
|
2888 use vars qw( @ISA ); |
|
2889 @ISA = qw ( Archive::Zip::FileMember ); |
|
2890 |
|
2891 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :UTILITY_METHODS ) } |
|
2892 |
|
2893 # Given a file name, set up for eventual writing. |
|
2894 sub _newFromFileNamed # Archive::Zip::NewFileMember |
|
2895 { |
|
2896 my $class = shift; |
|
2897 my $fileName = shift; |
|
2898 return undef if ! ( -r $fileName && ( -f _ || -l _ ) ); |
|
2899 my $self = $class->new( @_ ); |
|
2900 $self->fileName( $fileName ); |
|
2901 $self->{'externalFileName'} = $fileName; |
|
2902 $self->{'compressionMethod'} = COMPRESSION_STORED; |
|
2903 my @stat = stat( _ ); |
|
2904 $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7]; |
|
2905 $self->desiredCompressionMethod( ( $self->compressedSize() > 0 ) |
|
2906 ? COMPRESSION_DEFLATED |
|
2907 : COMPRESSION_STORED ); |
|
2908 $self->unixFileAttributes( $stat[2] ); |
|
2909 $self->setLastModFileDateTimeFromUnix( $stat[9] ); |
|
2910 $self->isTextFile( -T _ ); |
|
2911 return $self; |
|
2912 } |
|
2913 |
|
2914 sub rewindData # Archive::Zip::NewFileMember |
|
2915 { |
|
2916 my $self = shift; |
|
2917 |
|
2918 my $status = $self->SUPER::rewindData( @_ ); |
|
2919 return $status if $status != AZ_OK; |
|
2920 |
|
2921 return AZ_IO_ERROR if ! $self->fh(); |
|
2922 $self->fh()->clearerr(); |
|
2923 $self->fh()->seek( 0, IO::Seekable::SEEK_SET ) |
|
2924 or return _ioError( "rewinding", $self->externalFileName() ); |
|
2925 return AZ_OK; |
|
2926 } |
|
2927 |
|
2928 # Return bytes read. Note that first parameter is a ref to a buffer. |
|
2929 # my $data; |
|
2930 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); |
|
2931 sub _readRawChunk # Archive::Zip::NewFileMember |
|
2932 { |
|
2933 my ( $self, $dataRef, $chunkSize ) = @_; |
|
2934 return ( 0, AZ_OK ) if ( ! $chunkSize ); |
|
2935 my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize ) |
|
2936 or return ( 0, _ioError( "reading data" ) ); |
|
2937 return ( $bytesRead, AZ_OK ); |
|
2938 } |
|
2939 |
|
2940 # If I already exist, extraction is a no-op. |
|
2941 sub extractToFileNamed # Archive::Zip::NewFileMember |
|
2942 { |
|
2943 my $self = shift; |
|
2944 my $name = shift; |
|
2945 if ( $name eq $self->fileName() and -r $name ) |
|
2946 { |
|
2947 return AZ_OK; |
|
2948 } |
|
2949 else |
|
2950 { |
|
2951 return $self->SUPER::extractToFileNamed( $name, @_ ); |
|
2952 } |
|
2953 } |
|
2954 |
|
2955 =back |
|
2956 |
|
2957 =head1 Archive::Zip::ZipFileMember methods |
|
2958 |
|
2959 The Archive::Zip::ZipFileMember class represents members that have |
|
2960 been read from external zip files. |
|
2961 |
|
2962 =over 4 |
|
2963 |
|
2964 =cut |
|
2965 |
|
2966 # ---------------------------------------------------------------------- |
|
2967 # class Archive::Zip::ZipFileMember |
|
2968 # This represents a member in an existing zip file on disk. |
|
2969 # ---------------------------------------------------------------------- |
|
2970 |
|
2971 package Archive::Zip::ZipFileMember; |
|
2972 use vars qw( @ISA ); |
|
2973 @ISA = qw ( Archive::Zip::FileMember ); |
|
2974 |
|
2975 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS |
|
2976 :UTILITY_METHODS ) } |
|
2977 |
|
2978 # Create a new Archive::Zip::ZipFileMember |
|
2979 # given a filename and optional open file handle |
|
2980 sub _newFromZipFile # Archive::Zip::ZipFileMember |
|
2981 { |
|
2982 my $class = shift; |
|
2983 my $fh = shift; |
|
2984 my $externalFileName = shift; |
|
2985 my $self = $class->new( |
|
2986 'crc32' => 0, |
|
2987 'diskNumberStart' => 0, |
|
2988 'localHeaderRelativeOffset' => 0, |
|
2989 'dataOffset' => 0, # localHeaderRelativeOffset + header length |
|
2990 @_ |
|
2991 ); |
|
2992 $self->{'externalFileName'} = $externalFileName; |
|
2993 $self->{'fh'} = $fh; |
|
2994 return $self; |
|
2995 } |
|
2996 |
|
2997 sub isDirectory # Archive::Zip::FileMember |
|
2998 { |
|
2999 my $self = shift; |
|
3000 return ( substr( $self->fileName(), -1, 1 ) eq '/' |
|
3001 and $self->uncompressedSize() == 0 ); |
|
3002 } |
|
3003 |
|
3004 # Because I'm going to delete the file handle, read the local file |
|
3005 # header if the file handle is seekable. If it isn't, I assume that |
|
3006 # I've already read the local header. |
|
3007 # Return ( $status, $self ) |
|
3008 |
|
3009 sub _become # Archive::Zip::ZipFileMember |
|
3010 { |
|
3011 my $self = shift; |
|
3012 my $newClass = shift; |
|
3013 return $self if ref( $self ) eq $newClass; |
|
3014 |
|
3015 my $status = AZ_OK; |
|
3016 |
|
3017 if ( _isSeekable( $self->fh() ) ) |
|
3018 { |
|
3019 my $here = $self->fh()->tell(); |
|
3020 $status = $self->fh()->seek( |
|
3021 $self->localHeaderRelativeOffset() + SIGNATURE_LENGTH, |
|
3022 IO::Seekable::SEEK_SET ); |
|
3023 if ( ! $status ) |
|
3024 { |
|
3025 $self->fh()->seek( $here ); |
|
3026 _ioError( "seeking to local header" ); |
|
3027 return $self; |
|
3028 } |
|
3029 $self->_readLocalFileHeader(); |
|
3030 $self->fh()->seek( $here, IO::Seekable::SEEK_SET ); |
|
3031 } |
|
3032 |
|
3033 delete( $self->{'diskNumberStart'} ); |
|
3034 delete( $self->{'localHeaderRelativeOffset'} ); |
|
3035 delete( $self->{'dataOffset'} ); |
|
3036 |
|
3037 return $self->SUPER::_become( $newClass ); |
|
3038 } |
|
3039 |
|
3040 #-------------------------------- |
|
3041 |
|
3042 =item diskNumberStart() |
|
3043 |
|
3044 Returns the disk number that my local header resides |
|
3045 in. Had better be 0. |
|
3046 |
|
3047 =cut |
|
3048 |
|
3049 sub diskNumberStart # Archive::Zip::ZipFileMember |
|
3050 { shift->{'diskNumberStart'} } |
|
3051 |
|
3052 #-------------------------------- |
|
3053 |
|
3054 =item localHeaderRelativeOffset() |
|
3055 |
|
3056 Returns the offset into the zip file where my local header is. |
|
3057 |
|
3058 =cut |
|
3059 |
|
3060 sub localHeaderRelativeOffset # Archive::Zip::ZipFileMember |
|
3061 { shift->{'localHeaderRelativeOffset'} } |
|
3062 |
|
3063 #-------------------------------- |
|
3064 |
|
3065 =item dataOffset() |
|
3066 |
|
3067 Returns the offset from the beginning of the zip file to |
|
3068 my data. |
|
3069 |
|
3070 =cut |
|
3071 |
|
3072 sub dataOffset # Archive::Zip::ZipFileMember |
|
3073 { shift->{'dataOffset'} } |
|
3074 |
|
3075 # Skip local file header, updating only extra field stuff. |
|
3076 # Assumes that fh is positioned before signature. |
|
3077 sub _skipLocalFileHeader # Archive::Zip::ZipFileMember |
|
3078 { |
|
3079 my $self = shift; |
|
3080 my $header; |
|
3081 $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH ) |
|
3082 or return _ioError( "reading local file header" ); |
|
3083 my $fileNameLength; |
|
3084 my $extraFieldLength; |
|
3085 ( undef, # $self->{'versionNeededToExtract'}, |
|
3086 undef, # $self->{'bitFlag'}, |
|
3087 undef, # $self->{'compressionMethod'}, |
|
3088 undef, # $self->{'lastModFileDateTime'}, |
|
3089 undef, # $crc32, |
|
3090 undef, # $compressedSize, |
|
3091 undef, # $uncompressedSize, |
|
3092 $fileNameLength, |
|
3093 $extraFieldLength ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header ); |
|
3094 |
|
3095 if ( $fileNameLength ) |
|
3096 { |
|
3097 $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR ) |
|
3098 or return _ioError( "skipping local file name" ); |
|
3099 } |
|
3100 |
|
3101 if ( $extraFieldLength ) |
|
3102 { |
|
3103 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength ) |
|
3104 or return _ioError( "reading local extra field" ); |
|
3105 } |
|
3106 |
|
3107 $self->{'dataOffset'} = $self->fh()->tell(); |
|
3108 |
|
3109 return AZ_OK; |
|
3110 } |
|
3111 |
|
3112 # Read from a local file header into myself. Returns AZ_OK if successful. |
|
3113 # Assumes that fh is positioned after signature. |
|
3114 # Note that crc32, compressedSize, and uncompressedSize will be 0 if |
|
3115 # GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag. |
|
3116 |
|
3117 sub _readLocalFileHeader # Archive::Zip::ZipFileMember |
|
3118 { |
|
3119 my $self = shift; |
|
3120 my $header; |
|
3121 $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH ) |
|
3122 or return _ioError( "reading local file header" ); |
|
3123 my $fileNameLength; |
|
3124 my $crc32; |
|
3125 my $compressedSize; |
|
3126 my $uncompressedSize; |
|
3127 my $extraFieldLength; |
|
3128 ( $self->{'versionNeededToExtract'}, |
|
3129 $self->{'bitFlag'}, |
|
3130 $self->{'compressionMethod'}, |
|
3131 $self->{'lastModFileDateTime'}, |
|
3132 $crc32, |
|
3133 $compressedSize, |
|
3134 $uncompressedSize, |
|
3135 $fileNameLength, |
|
3136 $extraFieldLength ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header ); |
|
3137 |
|
3138 if ( $fileNameLength ) |
|
3139 { |
|
3140 my $fileName; |
|
3141 $self->fh()->read( $fileName, $fileNameLength ) |
|
3142 or return _ioError( "reading local file name" ); |
|
3143 $self->fileName( $fileName ); |
|
3144 } |
|
3145 |
|
3146 if ( $extraFieldLength ) |
|
3147 { |
|
3148 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength ) |
|
3149 or return _ioError( "reading local extra field" ); |
|
3150 } |
|
3151 |
|
3152 $self->{'dataOffset'} = $self->fh()->tell(); |
|
3153 |
|
3154 # Don't trash these fields from the CD if we already have them. |
|
3155 if ( not $self->hasDataDescriptor() ) |
|
3156 { |
|
3157 $self->{'crc32'} = $crc32; |
|
3158 $self->{'compressedSize'} = $compressedSize; |
|
3159 $self->{'uncompressedSize'} = $uncompressedSize; |
|
3160 } |
|
3161 |
|
3162 # We ignore data descriptors (we don't read them, |
|
3163 # and we compute elsewhere whether we need to write them ). |
|
3164 # And, we have the necessary data from the CD header. |
|
3165 # So mark this entry as not having a data descriptor. |
|
3166 $self->hasDataDescriptor( 0 ); |
|
3167 |
|
3168 return AZ_OK; |
|
3169 } |
|
3170 |
|
3171 |
|
3172 # Read a Central Directory header. Return AZ_OK on success. |
|
3173 # Assumes that fh is positioned right after the signature. |
|
3174 |
|
3175 sub _readCentralDirectoryFileHeader # Archive::Zip::ZipFileMember |
|
3176 { |
|
3177 my $self = shift; |
|
3178 my $fh = $self->fh(); |
|
3179 my $header = ''; |
|
3180 $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH ) |
|
3181 or return _ioError( "reading central dir header" ); |
|
3182 my ( $fileNameLength, $extraFieldLength, $fileCommentLength ); |
|
3183 ( |
|
3184 $self->{'versionMadeBy'}, |
|
3185 $self->{'fileAttributeFormat'}, |
|
3186 $self->{'versionNeededToExtract'}, |
|
3187 $self->{'bitFlag'}, |
|
3188 $self->{'compressionMethod'}, |
|
3189 $self->{'lastModFileDateTime'}, |
|
3190 $self->{'crc32'}, |
|
3191 $self->{'compressedSize'}, |
|
3192 $self->{'uncompressedSize'}, |
|
3193 $fileNameLength, |
|
3194 $extraFieldLength, |
|
3195 $fileCommentLength, |
|
3196 $self->{'diskNumberStart'}, |
|
3197 $self->{'internalFileAttributes'}, |
|
3198 $self->{'externalFileAttributes'}, |
|
3199 $self->{'localHeaderRelativeOffset'} |
|
3200 ) = unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header ); |
|
3201 |
|
3202 if ( $fileNameLength ) |
|
3203 { |
|
3204 $fh->read( $self->{'fileName'}, $fileNameLength ) |
|
3205 or return _ioError( "reading central dir filename" ); |
|
3206 } |
|
3207 if ( $extraFieldLength ) |
|
3208 { |
|
3209 $fh->read( $self->{'cdExtraField'}, $extraFieldLength ) |
|
3210 or return _ioError( "reading central dir extra field" ); |
|
3211 } |
|
3212 if ( $fileCommentLength ) |
|
3213 { |
|
3214 $fh->read( $self->{'fileComment'}, $fileCommentLength ) |
|
3215 or return _ioError( "reading central dir file comment" ); |
|
3216 } |
|
3217 |
|
3218 $self->desiredCompressionMethod( $self->compressionMethod() ); |
|
3219 |
|
3220 return AZ_OK; |
|
3221 } |
|
3222 |
|
3223 sub rewindData # Archive::Zip::ZipFileMember |
|
3224 { |
|
3225 my $self = shift; |
|
3226 |
|
3227 my $status = $self->SUPER::rewindData( @_ ); |
|
3228 return $status if $status != AZ_OK; |
|
3229 |
|
3230 return AZ_IO_ERROR if ! $self->fh(); |
|
3231 |
|
3232 $self->fh()->clearerr(); |
|
3233 |
|
3234 # Seek to local file header. |
|
3235 # The only reason that I'm doing this this way is that the extraField |
|
3236 # length seems to be different between the CD header and the LF header. |
|
3237 $self->fh()->seek( $self->localHeaderRelativeOffset() + SIGNATURE_LENGTH, |
|
3238 IO::Seekable::SEEK_SET ) |
|
3239 or return _ioError( "seeking to local header" ); |
|
3240 |
|
3241 # skip local file header |
|
3242 $status = $self->_skipLocalFileHeader(); |
|
3243 return $status if $status != AZ_OK; |
|
3244 |
|
3245 # Seek to beginning of file data |
|
3246 $self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET ) |
|
3247 or return _ioError( "seeking to beginning of file data" ); |
|
3248 |
|
3249 return AZ_OK; |
|
3250 } |
|
3251 |
|
3252 # Return bytes read. Note that first parameter is a ref to a buffer. |
|
3253 # my $data; |
|
3254 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); |
|
3255 sub _readRawChunk # Archive::Zip::ZipFileMember |
|
3256 { |
|
3257 my ( $self, $dataRef, $chunkSize ) = @_; |
|
3258 return ( 0, AZ_OK ) |
|
3259 if ( ! $chunkSize ); |
|
3260 my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize ) |
|
3261 or return ( 0, _ioError( "reading data" ) ); |
|
3262 return ( $bytesRead, AZ_OK ); |
|
3263 } |
|
3264 |
|
3265 # ---------------------------------------------------------------------- |
|
3266 # class Archive::Zip::StringMember ( concrete ) |
|
3267 # A Zip member whose data lives in a string |
|
3268 # ---------------------------------------------------------------------- |
|
3269 |
|
3270 package Archive::Zip::StringMember; |
|
3271 use vars qw( @ISA ); |
|
3272 @ISA = qw ( Archive::Zip::Member ); |
|
3273 |
|
3274 BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES ) } |
|
3275 |
|
3276 # Create a new string member. Default is COMPRESSION_STORED. |
|
3277 # Can take a ref to a string as well. |
|
3278 sub _newFromString # Archive::Zip::StringMember |
|
3279 { |
|
3280 my $class = shift; |
|
3281 my $string = shift; |
|
3282 my $name = shift; |
|
3283 my $self = $class->new( @_ ); |
|
3284 $self->contents( $string ); |
|
3285 $self->fileName( $name ) if defined( $name ); |
|
3286 # Set the file date to now |
|
3287 $self->setLastModFileDateTimeFromUnix( time() ); |
|
3288 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS ); |
|
3289 return $self; |
|
3290 } |
|
3291 |
|
3292 sub _become # Archive::Zip::StringMember |
|
3293 { |
|
3294 my $self = shift; |
|
3295 my $newClass = shift; |
|
3296 return $self if ref( $self ) eq $newClass; |
|
3297 delete( $self->{'contents'} ); |
|
3298 return $self->SUPER::_become( $newClass ); |
|
3299 } |
|
3300 |
|
3301 # Get or set my contents. Note that we do not call the superclass |
|
3302 # version of this, because it calls us. |
|
3303 sub contents # Archive::Zip::StringMember |
|
3304 { |
|
3305 my $self = shift; |
|
3306 my $string = shift; |
|
3307 if ( defined( $string ) ) |
|
3308 { |
|
3309 $self->{'contents'} = ( ref( $string ) eq 'SCALAR' ) |
|
3310 ? $$string |
|
3311 : $string; |
|
3312 $self->{'uncompressedSize'} |
|
3313 = $self->{'compressedSize'} |
|
3314 = length( $self->{'contents'} ); |
|
3315 $self->{'compressionMethod'} = COMPRESSION_STORED; |
|
3316 } |
|
3317 return $self->{'contents'}; |
|
3318 } |
|
3319 |
|
3320 # Return bytes read. Note that first parameter is a ref to a buffer. |
|
3321 # my $data; |
|
3322 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize ); |
|
3323 sub _readRawChunk # Archive::Zip::StringMember |
|
3324 { |
|
3325 my ( $self, $dataRef, $chunkSize ) = @_; |
|
3326 $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize ); |
|
3327 return ( length( $$dataRef ), AZ_OK ); |
|
3328 } |
|
3329 |
|
3330 1; |
|
3331 __END__ |
|
3332 |
|
3333 =back |
|
3334 |
|
3335 =head1 AUTHOR |
|
3336 |
|
3337 Ned Konz, perl@bike-nomad.com |
|
3338 |
|
3339 =head1 COPYRIGHT |
|
3340 |
|
3341 Copyright (c) 2000 Ned Konz. All rights reserved. This program is free |
|
3342 software; you can redistribute it and/or modify it under the same terms |
|
3343 as Perl itself. |
|
3344 |
|
3345 =head1 SEE ALSO |
|
3346 |
|
3347 L<Compress::Zlib> |
|
3348 |
|
3349 =cut |
|
3350 |
|
3351 # vim: ts=4 sw=4 columns=80 |