Codebase list libarchive-zip-perl / 5007c2b
[svn-inject] Installing original source of libarchive-zip-perl Ernesto Hernández-Novich 14 years ago
51 changed file(s) with 8551 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+229
-0
Changes less more
0 Revision history for Perl extension Archive::Zip.
1
2 1.18 Wed 25 Oct 2006 - Adam Kennedy
3 - Changing to a production version for final release
4 - No other changes of any kind
5
6 1.17_05 Tue 19 Sep 2006 - Adam Kennedy
7 - Seperated the classes from the main file into seperate packages.
8 - Merged the Zip.pod into the main Zip.pm file.
9 - Applied default Perl::Tidy to all of the source files, to improve
10 the readability and maintainability of the files.
11 - Added license in Makefile.PL
12 - Added some additional entries to the realclean files
13
14 1.17_03 Sat 16 Sep 2006 - Adam Kennedy
15 - Adding dependency on File::Which to deal with problems on systems
16 that lack zip and unzip programs. This really should be a build-time
17 dependency only, but ExtUtils::MakeMaker lacks that capability.
18 - Builds and tests cleanly on Win32 now.
19
20 1.17_02 Sun 7 May 2006 - Adam Kennedy
21 - Renamed the test scripts to the more conventional 01_name.t style
22 - Upgraded all test scripts from Test.pm to Test::More (removing Test.pm dependency)
23 - Various other miscellaneous cleanups of the test scripts
24 - Removed MANIFEST and pod.t from repository (will be auto-generated)
25 - Some cleaning up of the POD documentation for readability
26 - Added SUPPORT section to docs
27 - Merged external TODO file into the POD as a more-common TO DO section
28 - Added a BUGS section to the docs
29
30 1.17_01 Sun 30 Apr 2006 - Adam Kennedy
31 - Imported Archive::Zip into http://svn.phase-n.com/svn/cpan/ orphanage.
32 If you have a CPAN login and have released a module, ask ADAMK about an
33 account and you can repair your bug directly in the repository.
34 - Removed the revision comments from the old CVS repository
35 - DOS DateTime Format doesn't support dates before 1980 and goes crazy when
36 decoding back to unix time. If we don't get passed a time at all
37 (0 or undef) we now throw an error.
38 - DOS DateTime Format doesn't support dates before 1980, so if we find any
39 we warn and use Jan 1 12:01pm 1980 if we encounter any
40 - Win32 doesn't support directory modification times.
41 Tentatively use the current time as the mod-time to prevent sending
42 null times to the unix2dos converter (and the resulting error)
43 - Reformat the expected empty zip warning in the output to add a note that
44 the warning is entirely normal. Would be nice if some time later we can
45 suppress it altogether, but I don't have the cross-platform STDERR-fu
46 without adding a dependency to IPC::Run3 (which would be bad).
47 - Adding a proper $VERSION to all classes, and synchronising them to the
48 same value.
49 - Adding a BEGIN block around the require 5.003_96 so it works at
50 compile-time instead of post-compile.
51 - Moved crc32 to bin/crc32 in line with package layout conventions
52
53 1.16 Mon Jul 04 12:49:30 CDT 2005
54 - Grrrr...removed test that fails when installing under CPANPLUS.
55
56 1.15 Wed Jun 22 10:24:25 CDT 2005
57 - added fix for RT #12771 Minor nit: warning in Archive::Zip::DirectoryMember::contents()
58 - added fix for RT #13327 Formatting problem in Archive::Zip::Tree manpage
59
60 1.15_02 Sat Mar 12 09:16:30 CST 2005
61 - fixed dates in previous entry!
62 - began the process of migrating from the monolithic t/test.t to
63 smaller scripts using Test::More.
64 - started work on improving Archive::Zip's test coverage. Coverage
65 is now up to just over 80%.
66 - added error handling to writeToFileHandle
67 - fixed small bug in extractMember from previous version
68
69 1.15_01 Wed Mar 9 22:26:52 CST 2005
70 - added fix for RT #11818 extractMember method corrupts archive
71 - added t/pod.t to test for pod correctness
72
73 1.10 Thu Mar 25 06:24:17 PST 2004
74 - Fixed documentation of setErrorHandler()
75 - Fixed link to Japanese translation of docs
76 - Added Compress::Zlib Bufsize patch from Yeasah Pell that was supposed to
77 have been added in 1.02
78 - Fixed problems with backup filenames for zips with no extension
79 - Fixed problems with undef volume names in _asLocalName()
80
81 1.09 Wed Nov 26 17:43:49 PST 2003
82 - Fixed handling of inserted garbage (as from viruses)
83 - Always check for local header signatures before using them
84 - Added updateMember() and updateTree() functions
85 - Added examples/mailZip.pl
86 - Added examples/updateTree.pl
87 - Fixed some potential but unreported bugs with function parameters like '0'
88 - Removed stray warn() call
89 - Caught undef second arg to replaceMember()
90 - Fixed test suite run with spaces in build dir name (ticket 4214)
91
92 1.08 Tue Oct 21 07:01:29 PDT 2003
93 - test noise fix from Michael Schwern (ticket 4174)
94 - FAQ NAME fix from Michael Schwern (ticket 4175)
95
96 1.07 Mon Oct 20 06:48:41 PDT 2003
97 - Added file attribute code by Maurice Aubrey
98 - Added FAQ about RedHat 9
99 - Added check for empty filenames
100
101 1.06 Thu Jul 17 11:06:18 PDT 2003
102 - Fixed seek use with IO::Scalar and IO::String
103 - Fixed use of binmode with pseudo-file handles
104 - Removed qr{} form for older Perl versions
105 - Changed rel2abs logic in _asLocalName() if there is a volume
106 - Fixed errors with making directories in extractMember() when none provided
107 - Return AZ_OK in extractMemberWithoutPaths() if member is a directory
108 - Fixed problem in extractTree with blank directory becoming "." prefix
109 - Added examples/writeScalar2.pl to show how to use IO::String as destination of Zip write
110 - Edited docs and FAQ to recommend against using absolute path names in zip files.
111
112 1.05 Wed Sep 11 12:31:20 PDT 2002
113 - fixed untaint from 1.04
114
115 1.04 Wed Sep 11 07:22:04 PDT 2002
116 - added untaint of lastModFileDateTime
117
118 1.03 Mon Sep 2 20:42:43 PDT 2002
119 - Removed dependency on IO::Scalar
120 - Set required version of File::Spec to 0.8
121 - Removed tests of examples that needed IO::Scalar
122 - Added binmode() call to read/writeScalar examples
123 - Fixed addTree() for 5.005 compatibility (still untested with 5.004)
124 - Fixed mkdir() calls for 5.005
125 - Clarified documentation of tree operations
126
127 1.02 Fri Aug 23 17:07:22 PDT 2002
128 - Many changes for cross-platform use (use File::Spec everywhere)
129 - Separated POD from Perl
130 - Moved Archive::Zip::Tree contents into Archive::Zip
131 A::Z::Tree is now deprecated and will warn with -w
132 - Reorganized docs
133 - Added FAQ
134 - Added chunkSize() call to report current chunk size
135 and added C::Z BufSize patch from Yeasah Pell.
136 - Added fileName() to report last read zip file name
137 - Added capability to prepend data, like for SFX files
138 - Added examples/selfex.pl for self-extracting archives creation
139 - Added examples/zipcheck.pl for validity testing
140 - Made extractToFileNamed() set access/modification times
141 - Added t/testTree.t to test A::Z::Tree
142 - Fix/speed up memberNamed()
143 - Added Archive::Zip::MemberRead by Sreeji K. Das
144 - Added tempFile(), tempName()
145 - Added overwrite() and overwriteAs() to allow read/modify/write of zip
146 - added examples/updateZip.pl to show how to read/modify/write
147
148 1.01 Tue Apr 30 10:34:44 PDT 2002
149 - Changed mkpath call for directories to work with BSD/OS
150 - Changed tests to work with BSD/OS
151
152 1.00 Sun Apr 28 2002
153 - Added several examples:
154 - examples/calcSizes.pl
155 How to find out how big a zip file will be before writing it
156 - examples/readScalar.pl
157 shows how to use IO::Scalar as the source of a zip read
158 - examples/unzipAll.pl
159 uses Archive::Zip::Tree to unzip an entire zip
160 - examples/writeScalar.pl
161 shows how to use IO::Scalar as the destination of a zip write
162 - examples/zipGrep.pl
163 Searches for text in zip files
164 - Changed required version of Compress::Zlib to 1.08
165 - Added detection and repair of zips with added garbage (as caused by
166 the Sircam worm)
167 - Added more documentation for FAQ-type questions, though few seem to
168 actually read the documentation.
169 - Fixed problem with stat vs lstat
170 - Changed version number to 1.00 for PHB compatibility
171
172 0.12 Wed May 23 17:48:21 PDT 2001
173 - Added writeScalar.pl and readScalar.pl to show use of IO::Scalar
174 - Fixed docs
175 - Fixed bug with EOCD signature on block boundary
176 - Made it work with IO::Scalar as file handles
177 - added readFromFileHandle()
178 - remove guess at seekability for Windows compatibility
179
180 0.11 Tue Jan 9 11:40:10 PST 2001
181 - Added examples/ziprecent.pl (by Rudi Farkas)
182 - Fixed up documentation in Archive::Zip::Tree
183 - Added to documentation in Archive::Zip::Tree
184 - Fixed bugs in Archive::Zip::Tree that kept predicates from working
185 - Detected file not existing errors in addFile
186
187 0.10 Tue Aug 8 13:50:19 PDT 2000
188 - Several bug fixes
189 - More robust new file handle logic can (again)
190 take opened file handles
191 - Detect attempts to overwrite zip file when members
192 depend on it
193
194 0.09 Tue May 9 13:27:35 PDT 2000
195 - Added fix for bug in contents()
196 - removed system("rm") call in t/test.t for Windows.
197
198 0.08 March 27 2000 (unreleased)
199 - Fixed documentation
200 - Used IO::File instead of FileHandle, allowed for use of almost anything as
201 a file handle.
202 - Extra filenames can be passed to extractMember(),
203 extractMemberWithoutPaths(), addFile(), addDirectory()
204 - Added work-around for WinZip bug with 0-length DEFLATED files
205 - Added Archive::Zip::Tree module for adding/extracting hierarchies
206
207 0.07 Fri Mar 24 10:26:51 PST 2000
208 - Added copyright
209 - Added desiredCompressionLevel() and documentation
210 - Made writeToFileHandle() detect seekability by default
211 - Allowed Archive::Zip->new() to take filename for read()
212 - Added crc32String() to Archive::Zip::Member
213 - Changed requirement in Makefile.PL to Compress::Zip
214 version 1.06 or later (bug in earlier versions can truncate data)
215 - Moved BufferedFileHandle and MockFileHandle into
216 Archive::Zip namespace
217 - Allowed changing error printing routine
218 - Factored out reading of signatures
219 - Made re-read of local header for directory members
220 depend on file handle seekability
221 - Added ability to change member contents
222 - Fixed a possible truncation bug in contents() method
223
224 0.06 Tue Mar 21 15:28:22 PST 2000
225 - first release to CPAN
226
227 0.01 Sun Mar 12 18:59:55 2000
228 - original version; created by h2xs 1.19
+43
-0
INSTALL less more
0 To make and test, do the following:
1 perl Makefile.PL
2 make
3 make test
4
5 To copy the libs and docs to the right places,
6 do this (as superuser or administrator):
7 make install
8
9 If you're using Windows, you probably have to first get nmake to make this
10 work. If you have the ActiveState distribution, read the part about installing
11 modules from CPAN.
12
13 Then:
14 perl Makefile.PL
15 nmake
16 nmake test
17 nmake install
18
19
20 If you don't have the Info-Zip tools zip and unzip installed, you may
21 get warnings from "make test" or "nmake test". Don't worry about these.
22
23 Actually, if you're using ActiveState's ActivePerl on Windows
24 you should first check for up to date .PPM versions and use their PPM tool
25 to install them.
26
27 If you are having install problems on RedHat 8 or 9 with Perl 5.8.0, please
28 read this (from the FAQ in lib/Archive/Zip/FAQ.pod):
29
30 Q: Archive::Zip won't install on my RedHat 9 system! It's broke!
31
32 A: This has become something of a FAQ. Basically, RedHat broke some
33 versions of Perl by setting LANG to UTF8. They apparently have a fixed
34 version out as an update.
35
36 You might try running CPAN or creating your Makefile after exporting the
37 LANG environment variable as
38
39 "LANG=C"
40
41 <https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
42
+378
-0
LICENSE less more
0
1 Terms of Perl itself
2
3 a) the GNU General Public License as published by the Free
4 Software Foundation; either version 1, or (at your option) any
5 later version, or
6 b) the "Artistic License"
7
8 ----------------------------------------------------------------------------
9
10 The General Public License (GPL)
11 Version 2, June 1991
12
13 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave,
14 Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute
15 verbatim copies of this license document, but changing it is not allowed.
16
17 Preamble
18
19 The licenses for most software are designed to take away your freedom to share
20 and change it. By contrast, the GNU General Public License is intended to
21 guarantee your freedom to share and change free software--to make sure the
22 software is free for all its users. This General Public License applies to most of
23 the Free Software Foundation's software and to any other program whose
24 authors commit to using it. (Some other Free Software Foundation software is
25 covered by the GNU Library General Public License instead.) You can apply it to
26 your programs, too.
27
28 When we speak of free software, we are referring to freedom, not price. Our
29 General Public Licenses are designed to make sure that you have the freedom
30 to distribute copies of free software (and charge for this service if you wish), that
31 you receive source code or can get it if you want it, that you can change the
32 software or use pieces of it in new free programs; and that you know you can do
33 these things.
34
35 To protect your rights, we need to make restrictions that forbid anyone to deny
36 you these rights or to ask you to surrender the rights. These restrictions
37 translate to certain responsibilities for you if you distribute copies of the
38 software, or if you modify it.
39
40 For example, if you distribute copies of such a program, whether gratis or for a
41 fee, you must give the recipients all the rights that you have. You must make
42 sure that they, too, receive or can get the source code. And you must show
43 them these terms so they know their rights.
44
45 We protect your rights with two steps: (1) copyright the software, and (2) offer
46 you this license which gives you legal permission to copy, distribute and/or
47 modify the software.
48
49 Also, for each author's protection and ours, we want to make certain that
50 everyone understands that there is no warranty for this free software. If the
51 software is modified by someone else and passed on, we want its recipients to
52 know that what they have is not the original, so that any problems introduced by
53 others will not reflect on the original authors' reputations.
54
55 Finally, any free program is threatened constantly by software patents. We wish
56 to avoid the danger that redistributors of a free program will individually obtain
57 patent licenses, in effect making the program proprietary. To prevent this, we
58 have made it clear that any patent must be licensed for everyone's free use or
59 not licensed at all.
60
61 The precise terms and conditions for copying, distribution and modification
62 follow.
63
64 GNU GENERAL PUBLIC LICENSE
65 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND
66 MODIFICATION
67
68 0. This License applies to any program or other work which contains a notice
69 placed by the copyright holder saying it may be distributed under the terms of
70 this General Public License. The "Program", below, refers to any such program
71 or work, and a "work based on the Program" means either the Program or any
72 derivative work under copyright law: that is to say, a work containing the
73 Program or a portion of it, either verbatim or with modifications and/or translated
74 into another language. (Hereinafter, translation is included without limitation in
75 the term "modification".) Each licensee is addressed as "you".
76
77 Activities other than copying, distribution and modification are not covered by
78 this License; they are outside its scope. The act of running the Program is not
79 restricted, and the output from the Program is covered only if its contents
80 constitute a work based on the Program (independent of having been made by
81 running the Program). Whether that is true depends on what the Program does.
82
83 1. You may copy and distribute verbatim copies of the Program's source code as
84 you receive it, in any medium, provided that you conspicuously and appropriately
85 publish on each copy an appropriate copyright notice and disclaimer of warranty;
86 keep intact all the notices that refer to this License and to the absence of any
87 warranty; and give any other recipients of the Program a copy of this License
88 along with the Program.
89
90 You may charge a fee for the physical act of transferring a copy, and you may at
91 your option offer warranty protection in exchange for a fee.
92
93 2. You may modify your copy or copies of the Program or any portion of it, thus
94 forming a work based on the Program, and copy and distribute such
95 modifications or work under the terms of Section 1 above, provided that you also
96 meet all of these conditions:
97
98 a) You must cause the modified files to carry prominent notices stating that you
99 changed the files and the date of any change.
100
101 b) You must cause any work that you distribute or publish, that in whole or in
102 part contains or is derived from the Program or any part thereof, to be licensed
103 as a whole at no charge to all third parties under the terms of this License.
104
105 c) If the modified program normally reads commands interactively when run, you
106 must cause it, when started running for such interactive use in the most ordinary
107 way, to print or display an announcement including an appropriate copyright
108 notice and a notice that there is no warranty (or else, saying that you provide a
109 warranty) and that users may redistribute the program under these conditions,
110 and telling the user how to view a copy of this License. (Exception: if the
111 Program itself is interactive but does not normally print such an announcement,
112 your work based on the Program is not required to print an announcement.)
113
114 These requirements apply to the modified work as a whole. If identifiable
115 sections of that work are not derived from the Program, and can be reasonably
116 considered independent and separate works in themselves, then this License,
117 and its terms, do not apply to those sections when you distribute them as
118 separate works. But when you distribute the same sections as part of a whole
119 which is a work based on the Program, the distribution of the whole must be on
120 the terms of this License, whose permissions for other licensees extend to the
121 entire whole, and thus to each and every part regardless of who wrote it.
122
123 Thus, it is not the intent of this section to claim rights or contest your rights to
124 work written entirely by you; rather, the intent is to exercise the right to control
125 the distribution of derivative or collective works based on the Program.
126
127 In addition, mere aggregation of another work not based on the Program with the
128 Program (or with a work based on the Program) on a volume of a storage or
129 distribution medium does not bring the other work under the scope of this
130 License.
131
132 3. You may copy and distribute the Program (or a work based on it, under
133 Section 2) in object code or executable form under the terms of Sections 1 and 2
134 above provided that you also do one of the following:
135
136 a) Accompany it with the complete corresponding machine-readable source
137 code, which must be distributed under the terms of Sections 1 and 2 above on a
138 medium customarily used for software interchange; or,
139
140 b) Accompany it with a written offer, valid for at least three years, to give any
141 third party, for a charge no more than your cost of physically performing source
142 distribution, a complete machine-readable copy of the corresponding source
143 code, to be distributed under the terms of Sections 1 and 2 above on a medium
144 customarily used for software interchange; or,
145
146 c) Accompany it with the information you received as to the offer to distribute
147 corresponding source code. (This alternative is allowed only for noncommercial
148 distribution and only if you received the program in object code or executable
149 form with such an offer, in accord with Subsection b above.)
150
151 The source code for a work means the preferred form of the work for making
152 modifications to it. For an executable work, complete source code means all the
153 source code for all modules it contains, plus any associated interface definition
154 files, plus the scripts used to control compilation and installation of the
155 executable. However, as a special exception, the source code distributed need
156 not include anything that is normally distributed (in either source or binary form)
157 with the major components (compiler, kernel, and so on) of the operating system
158 on which the executable runs, unless that component itself accompanies the
159 executable.
160
161 If distribution of executable or object code is made by offering access to copy
162 from a designated place, then offering equivalent access to copy the source
163 code from the same place counts as distribution of the source code, even though
164 third parties are not compelled to copy the source along with the object code.
165
166 4. You may not copy, modify, sublicense, or distribute the Program except as
167 expressly provided under this License. Any attempt otherwise to copy, modify,
168 sublicense or distribute the Program is void, and will automatically terminate
169 your rights under this License. However, parties who have received copies, or
170 rights, from you under this License will not have their licenses terminated so long
171 as such parties remain in full compliance.
172
173 5. You are not required to accept this License, since you have not signed it.
174 However, nothing else grants you permission to modify or distribute the Program
175 or its derivative works. These actions are prohibited by law if you do not accept
176 this License. Therefore, by modifying or distributing the Program (or any work
177 based on the Program), you indicate your acceptance of this License to do so,
178 and all its terms and conditions for copying, distributing or modifying the
179 Program or works based on it.
180
181 6. Each time you redistribute the Program (or any work based on the Program),
182 the recipient automatically receives a license from the original licensor to copy,
183 distribute or modify the Program subject to these terms and conditions. You
184 may not impose any further restrictions on the recipients' exercise of the rights
185 granted herein. You are not responsible for enforcing compliance by third parties
186 to this License.
187
188 7. If, as a consequence of a court judgment or allegation of patent infringement
189 or for any other reason (not limited to patent issues), conditions are imposed on
190 you (whether by court order, agreement or otherwise) that contradict the
191 conditions of this License, they do not excuse you from the conditions of this
192 License. If you cannot distribute so as to satisfy simultaneously your obligations
193 under this License and any other pertinent obligations, then as a consequence
194 you may not distribute the Program at all. For example, if a patent license would
195 not permit royalty-free redistribution of the Program by all those who receive
196 copies directly or indirectly through you, then the only way you could satisfy
197 both it and this License would be to refrain entirely from distribution of the
198 Program.
199
200 If any portion of this section is held invalid or unenforceable under any particular
201 circumstance, the balance of the section is intended to apply and the section as
202 a whole is intended to apply in other circumstances.
203
204 It is not the purpose of this section to induce you to infringe any patents or other
205 property right claims or to contest validity of any such claims; this section has
206 the sole purpose of protecting the integrity of the free software distribution
207 system, which is implemented by public license practices. Many people have
208 made generous contributions to the wide range of software distributed through
209 that system in reliance on consistent application of that system; it is up to the
210 author/donor to decide if he or she is willing to distribute software through any
211 other system and a licensee cannot impose that choice.
212
213 This section is intended to make thoroughly clear what is believed to be a
214 consequence of the rest of this License.
215
216 8. If the distribution and/or use of the Program is restricted in certain countries
217 either by patents or by copyrighted interfaces, the original copyright holder who
218 places the Program under this License may add an explicit geographical
219 distribution limitation excluding those countries, so that distribution is permitted
220 only in or among countries not thus excluded. In such case, this License
221 incorporates the limitation as if written in the body of this License.
222
223 9. The Free Software Foundation may publish revised and/or new versions of the
224 General Public License from time to time. Such new versions will be similar in
225 spirit to the present version, but may differ in detail to address new problems or
226 concerns.
227
228 Each version is given a distinguishing version number. If the Program specifies a
229 version number of this License which applies to it and "any later version", you
230 have the option of following the terms and conditions either of that version or of
231 any later version published by the Free Software Foundation. If the Program does
232 not specify a version number of this License, you may choose any version ever
233 published by the Free Software Foundation.
234
235 10. If you wish to incorporate parts of the Program into other free programs
236 whose distribution conditions are different, write to the author to ask for
237 permission. For software which is copyrighted by the Free Software Foundation,
238 write to the Free Software Foundation; we sometimes make exceptions for this.
239 Our decision will be guided by the two goals of preserving the free status of all
240 derivatives of our free software and of promoting the sharing and reuse of
241 software generally.
242
243 NO WARRANTY
244
245 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS
246 NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
247 APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE
248 COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM
249 "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR
250 IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
251 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
252 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
253 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE,
254 YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
255 CORRECTION.
256
257 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED
258 TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY
259 WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS
260 PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
261 GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
262 ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM
263 (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
264 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
265 PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY
266 OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS
267 BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
268
269 END OF TERMS AND CONDITIONS
270
271
272 ----------------------------------------------------------------------------
273
274 The Artistic License
275
276 Preamble
277
278 The intent of this document is to state the conditions under which a Package
279 may be copied, such that the Copyright Holder maintains some semblance of
280 artistic control over the development of the package, while giving the users of the
281 package the right to use and distribute the Package in a more-or-less customary
282 fashion, plus the right to make reasonable modifications.
283
284 Definitions:
285
286 - "Package" refers to the collection of files distributed by the Copyright
287 Holder, and derivatives of that collection of files created through textual
288 modification.
289 - "Standard Version" refers to such a Package if it has not been modified,
290 or has been modified in accordance with the wishes of the Copyright
291 Holder.
292 - "Copyright Holder" is whoever is named in the copyright or copyrights for
293 the package.
294 - "You" is you, if you're thinking about copying or distributing this Package.
295 - "Reasonable copying fee" is whatever you can justify on the basis of
296 media cost, duplication charges, time of people involved, and so on. (You
297 will not be required to justify it to the Copyright Holder, but only to the
298 computing community at large as a market that must bear the fee.)
299 - "Freely Available" means that no fee is charged for the item itself, though
300 there may be fees involved in handling the item. It also means that
301 recipients of the item may redistribute it under the same conditions they
302 received it.
303
304 1. You may make and give away verbatim copies of the source form of the
305 Standard Version of this Package without restriction, provided that you duplicate
306 all of the original copyright notices and associated disclaimers.
307
308 2. You may apply bug fixes, portability fixes and other modifications derived from
309 the Public Domain or from the Copyright Holder. A Package modified in such a
310 way shall still be considered the Standard Version.
311
312 3. You may otherwise modify your copy of this Package in any way, provided
313 that you insert a prominent notice in each changed file stating how and when
314 you changed that file, and provided that you do at least ONE of the following:
315
316 a) place your modifications in the Public Domain or otherwise
317 make them Freely Available, such as by posting said modifications
318 to Usenet or an equivalent medium, or placing the modifications on
319 a major archive site such as ftp.uu.net, or by allowing the
320 Copyright Holder to include your modifications in the Standard
321 Version of the Package.
322
323 b) use the modified Package only within your corporation or
324 organization.
325
326 c) rename any non-standard executables so the names do not
327 conflict with standard executables, which must also be provided,
328 and provide a separate manual page for each non-standard
329 executable that clearly documents how it differs from the Standard
330 Version.
331
332 d) make other distribution arrangements with the Copyright Holder.
333
334 4. You may distribute the programs of this Package in object code or executable
335 form, provided that you do at least ONE of the following:
336
337 a) distribute a Standard Version of the executables and library
338 files, together with instructions (in the manual page or equivalent)
339 on where to get the Standard Version.
340
341 b) accompany the distribution with the machine-readable source of
342 the Package with your modifications.
343
344 c) accompany any non-standard executables with their
345 corresponding Standard Version executables, giving the
346 non-standard executables non-standard names, and clearly
347 documenting the differences in manual pages (or equivalent),
348 together with instructions on where to get the Standard Version.
349
350 d) make other distribution arrangements with the Copyright Holder.
351
352 5. You may charge a reasonable copying fee for any distribution of this Package.
353 You may charge any fee you choose for support of this Package. You may not
354 charge a fee for this Package itself. However, you may distribute this Package in
355 aggregate with other (possibly commercial) programs as part of a larger
356 (possibly commercial) software distribution provided that you do not advertise
357 this Package as a product of your own.
358
359 6. The scripts and library files supplied as input to or produced as output from
360 the programs of this Package do not automatically fall under the copyright of this
361 Package, but belong to whomever generated them, and may be sold
362 commercially, and may be aggregated with this Package.
363
364 7. C or perl subroutines supplied by you and linked into this Package shall not
365 be considered part of this Package.
366
367 8. The name of the Copyright Holder may not be used to endorse or promote
368 products derived from this software without specific prior written permission.
369
370 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
371 IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
372 WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
373 PURPOSE.
374
375 The End
376
377
+53
-0
MANIFEST less more
0 bin/crc32
1 Changes
2 docs/appnote.iz
3 docs/Appnote.txt
4 docs/Archive-Zip.pdf
5 docs/ideas.txt
6 examples/calcSizes.pl
7 examples/copy.pl
8 examples/extract.pl
9 examples/mailZip.pl
10 examples/mfh.pl
11 examples/readScalar.pl
12 examples/selfex.pl
13 examples/unzipAll.pl
14 examples/updateTree.pl
15 examples/updateZip.pl
16 examples/writeScalar.pl
17 examples/writeScalar2.pl
18 examples/zip.pl
19 examples/zipcheck.pl
20 examples/zipGrep.pl
21 examples/zipinfo.pl
22 examples/ziprecent.pl
23 examples/ziptest.pl
24 INSTALL
25 lib/Archive/Zip.pm
26 lib/Archive/Zip/Archive.pm
27 lib/Archive/Zip/BufferedFileHandle.pm
28 lib/Archive/Zip/DirectoryMember.pm
29 lib/Archive/Zip/FAQ.pod
30 lib/Archive/Zip/FileMember.pm
31 lib/Archive/Zip/Member.pm
32 lib/Archive/Zip/MemberRead.pm
33 lib/Archive/Zip/MockFileHandle.pm
34 lib/Archive/Zip/NewFileMember.pm
35 lib/Archive/Zip/StringMember.pm
36 lib/Archive/Zip/Tree.pm
37 lib/Archive/Zip/ZipFileMember.pm
38 LICENSE
39 Makefile.PL
40 MANIFEST This list of files
41 README
42 t/01_compile.t
43 t/02_main.t
44 t/03_ex.t
45 t/04_readmember.t
46 t/05_tree.t
47 t/06_update.t
48 t/99_author.t
49 t/badjpeg/expected.jpg
50 t/badjpeg/source.zip
51 t/common.pl
52 META.yml Module meta-data (added by MakeMaker)
+27
-0
META.yml less more
0 --- #YAML:1.0
1 name: Archive-Zip
2 version: 1.18
3 abstract: Provide an interface to ZIP archive files.
4 license: perl
5 generated_by: ExtUtils::MakeMaker version 6.31
6 distribution_type: module
7 requires:
8 Carp: 0
9 Compress::Zlib: 1.14
10 File::Basename: 0
11 File::Copy: 0
12 File::Find: 0
13 File::Path: 0
14 File::Spec: 0.80
15 File::Temp: 0
16 File::Which: 0.05
17 IO::File: 0
18 IO::Handle: 0
19 IO::Seekable: 0
20 Test::More: 0.42
21 Time::Local: 0
22 meta-spec:
23 url: http://module-build.sourceforge.net/META-spec-v1.2.html
24 version: 1.2
25 author:
26 - Ned Konz <perl@bike-nomad.com>
+45
-0
Makefile.PL less more
0 require 5.003_96;
1
2 use Config;
3 use ExtUtils::MakeMaker;
4
5 WriteMakefile(
6 NAME => 'Archive::Zip',
7 VERSION_FROM => 'lib/Archive/Zip.pm', # finds $VERSION
8 ($] < 5.005 ? () :
9 (
10 BINARY_LOCATION => $Config{'archname'} . "/\$(DISTVNAME)-PPD.tar\$(SUFFIX)",
11 AUTHOR => 'Ned Konz <perl@bike-nomad.com>',
12 ABSTRACT_FROM => 'lib/Archive/Zip.pm',
13 )),
14 PREREQ_PM => {
15 'Compress::Zlib' => '1.14',
16 'Carp' => 0,
17 # 'Data::Dumper' => 0, # examples/zipinfo.pl
18 'File::Path' => 0,
19 'File::Find' => 0,
20 'File::Basename' => 0,
21 'File::Spec' => '0.80', # need splitpath()
22 'File::Copy' => 0,
23 'File::Temp' => 0,
24 'File::Which' => '0.05', # Should really be build_requires
25 # 'Getopt::Std' => 0, # examples/extract.pl
26 'IO::File' => 0,
27 'IO::Handle' => 0,
28 'IO::Seekable' => 0,
29 'Test::More' => '0.42',
30 'Time::Local' => 0,
31 },
32 EXE_FILES => [ 'bin/crc32' ],
33 clean => {
34 FILES => 'test.log testdir/* testdir/ extracted/testdir/* extracted/testdir extracted/ testin.zip testout.zip test2.zip'
35 },
36 dist => {
37 COMPRESS => 'gzip',
38 SUFFIX => '.gz',
39 ZIP => 'zip',
40 ZIPFLAGS => '-r'
41 },
42 ($ExtUtils::MakeMaker::VERSION ge '6.30_00'?
43 ('LICENSE' => 'perl', ) : ()),
44 );
+28
-0
README less more
0 The Archive::Zip module allows a Perl program to create, manipulate,
1 read, and write Zip archive files.
2
3 Zip archives can be created, or you can read from existing zip files.
4 Once created, they can be written to files, streams, or strings.
5
6 Members can be added, removed, extracted, replaced, rearranged, and
7 enumerated. They can also be renamed or have their dates, comments, or
8 other attributes queried or modified. Their data can be compressed or
9 uncompressed as needed. Members can be created from members in existing
10 Zip files, or from existing directories, files, or strings.
11
12 This module uses the Compress::Zlib library to read and write the
13 compressed streams inside the files.
14
15 Examples and helper libraries are given to show how:
16 * zip files can be written to strings
17 * zip files can be written in chunks to arbitrary functions
18
19 Documentation will be installed as man pages for:
20 Archive::Zip
21 Archive::Zip::FAQ
22 Archive::Zip::Tree
23 Archive::Zip::MemberRead
24
25 Copyright (c) 2000-2003 Ned Konz. All rights reserved. This program is free
26 software; you can redistribute it and/or modify it under the same terms
27 as Perl itself.
+28
-0
bin/crc32 less more
0 #! /usr/bin/perl -w
1 # computes and prints to stdout the CRC-32 values of the given files
2 use lib qw( blib/lib lib );
3 use Archive::Zip;
4 use FileHandle;
5
6 my $totalFiles = scalar(@ARGV);
7 foreach my $file (@ARGV) {
8 if ( -d $file ) {
9 warn "$0: ${file}: Is a directory\n";
10 next;
11 }
12 my $fh = FileHandle->new();
13 if ( !$fh->open( $file, 'r' ) ) {
14 warn "$0: $!\n";
15 next;
16 }
17 binmode($fh);
18 my $buffer;
19 my $bytesRead;
20 my $crc = 0;
21 while ( $bytesRead = $fh->read( $buffer, 32768 ) ) {
22 $crc = Archive::Zip::computeCRC32( $buffer, $crc );
23 }
24 printf( "%08x", $crc );
25 print("\t$file") if ( $totalFiles > 1 );
26 print("\n");
27 }
docs/Archive-Zip.pdf less more
Binary diff not shown
+150
-0
docs/ideas.txt less more
0 Newsgroups: comp.lang.perl.modules
1 Subject: Best form for allowing module extension?
2 Reply-To:
3 Followup-To:
4 Keywords:
5 Summary:
6
7 I am writing a module (Archive::Zip) that implements the basic read and
8 write functionality for Zip archive files. These files have provisions
9 for extensions for specific platforms: each member has an 'extra field'
10 that can contain OS-specific (or, indeed, any member-specific) data. The
11 overall format of this data is specified (<Header ID>, <count>, <data>),
12 but the actual contents depends on the Header ID.
13
14 Because I'm only working in a couple of operating environments, and
15 because I'm not trying to write a full "unzip" or "PKZIP" replacement, I
16 don't really want to try to interpret all of these formats.
17
18 From the PKWARE Appnote.txt file:
19
20 The current Header ID mappings defined by PKWARE are:
21
22 0x0007 AV Info
23 0x0009 OS/2
24 0x000a NTFS
25 0x000c VAX/VMS
26 0x000d Unix
27 0x000f Patch Descriptor
28
29 Several third party mappings commonly used are:
30
31 0x4b46 FWKCS MD5 (see below)
32 0x07c8 Macintosh
33 0x4341 Acorn/SparkFS
34 0x4453 Windows NT security descriptor (binary ACL)
35 0x4704 VM/CMS
36 0x470f MVS
37 0x4c41 OS/2 access control list (text ACL)
38 0x4d49 Info-ZIP VMS (VAX or Alpha)
39 0x5455 extended timestamp
40 0x5855 Info-ZIP Unix (original, also OS/2, NT, etc)
41 0x6542 BeOS/BeBox
42 0x756e ASi Unix
43 0x7855 Info-ZIP Unix (new)
44 0xfd4a SMS/QDOS
45
46 I want to make it easy for other people to provide this support without
47 changing my code.
48
49 Note that not all of these extensions have anything to do with file
50 permissions, although it may be helpful to provide one or more hooks for
51 extracting files:
52
53 * supply OS-specific filename
54 * open file for write (set permissions)
55 * after closing file (to set ownership, timestamps, etc.)
56
57 I can provide generic support for these extra fields, so that each
58 member can have 0 or more extra fields, each with a type tag and
59 uninterpreted data.
60
61 I have seen File::Spec and File::Spec::Unix, etc., and don't think that
62 this scheme is appropriate, since you could have a zip file that was
63 produced on one operating system being extracted by another.
64
65 Also, it is possible to have multiple types of extra fields in a single
66 zip file.
67
68 What I have thought about is this: a user who wants to interpret the
69 extended information in the zip members can include the appropriate
70 extension modules:
71
72 # ==================== in user's code ====================
73 use Archive::Zip; # basic functionality
74 use Archive::Zip::Unix; # to interpret Unix file permissions, etc.
75 use Archive::Zip::MD5; # to interpret MD5 extended info
76
77 my $zip = Archive::Zip->new();
78 $zip->read('ZIPFILE.ZIP');
79 foreach my $member ($zip->members())
80 {
81 foreach my $extraField ($member->extraFields())
82 {
83 print $extraField->info() . "\n";
84 }
85
86 $member->extract();
87 }
88 # ==================== end user's code ====================
89
90 I can make an extensible class for writers of OS-specific modules to
91 inherit from:
92
93 # ==================== in my code ====================
94 package Archive::Zip::ExtraField;
95 my %Handlers;
96
97 # Each subclass must call this with their class name and tag ID.
98 sub registerType
99 {
100 my ($class, $tag) = @_;
101 $Handlers{ $tag } = $class;
102 }
103
104 # Overrideable methods
105 sub info
106 {
107 my $self = shift;
108 ref($self) . " " . $self->{tag} . " " . $self->{dataLength};
109 }
110
111 # Provide OS-specific name if any or undef
112 sub preferredFileName { undef }
113
114 # Returns numeric arg for open() call or undef
115 sub openPermissions { undef }
116
117 # Hook for doing things after file is extracted
118 # Called as: $extraField->afterClosingExtractedFile($fileName)
119 sub afterClosingExtractedFile { }
120
121 package Archive::Zip::Member;
122
123 # return array of extra fields
124 sub extraFields() { ... }
125
126 sub extract
127 {
128 my $self = shift;
129 my ($preferredFileName) =
130 grep { $_ }
131 (map { $_->preferredFileName() } $self->extraFields());
132 my $fileName = $preferredFileName || $self->fileName();
133 # ... similar things for open permissions ...
134 my $fh = FileHandle->new($fileName, $openPermissions);
135 # ... extract data to fh ...
136 $fh->close();
137 map { $_->afterClosingExtractedFile($fileName) }
138 $self->extraFields();
139 }
140 # ==================== end my code ====================
141
142
143 Does this seem like a good way to go? Any other suggestions?
144
145 --
146 Ned Konz
147 currently: Stanwood, WA
148 email: ned@bike-nomad.com
149 homepage: http://www.bike-nomad.com
+31
-0
examples/calcSizes.pl less more
0 # Example of how to compute compressed sizes
1 # $Revision: 1.2 $
2 use strict;
3 use Archive::Zip qw(:ERROR_CODES);
4 use File::Spec;
5 my $zip = Archive::Zip->new();
6 my $blackHoleDevice = File::Spec->devnull();
7
8 $zip->addFile($_) foreach (<*.pl>);
9
10 # Write and throw the data away.
11 # after members are written, the writeOffset will be set
12 # to the compressed size.
13 $zip->writeToFileNamed($blackHoleDevice);
14
15 my $totalSize = 0;
16 my $totalCompressedSize = 0;
17 foreach my $member ($zip->members())
18 {
19 $totalSize += $member->uncompressedSize;
20 $totalCompressedSize += $member->_writeOffset;
21 print "Member ", $member->externalFileName,
22 " size=", $member->uncompressedSize,
23 ", writeOffset=", $member->_writeOffset,
24 ", compressed=", $member->compressedSize,
25 "\n";
26 }
27
28 print "Total Size=", $totalSize, ", total compressed=", $totalCompressedSize, "\n";
29
30 $zip->writeToFileNamed('test.zip');
+17
-0
examples/copy.pl less more
0 # Copies a zip file to another.
1 # Usage:
2 # perl copy.pl input.zip output.zip
3 # $Revision: 1.4 $
4
5 use Archive::Zip qw(:ERROR_CODES);
6
7 die "usage: perl copy.pl input.zip output.zip\n"
8 if scalar(@ARGV) != 2;
9
10 my $zip = Archive::Zip->new();
11
12 my $status = $zip->read($ARGV[0]);
13 die("read $ARGV[0] failed: $status\n") if $status != AZ_OK;
14
15 $status = $zip->writeToFileNamed($ARGV[1]);
16 die("writeToFileNamed $ARGV[1] failed: $status\n") if $status != AZ_OK;
+40
-0
examples/extract.pl less more
0 #!/bin/perl -w
1 # Extracts the named files into 'extractTest' subdir
2 # usage:
3 # perl extract.pl [-j] zipfile.zip filename [...]
4 # if -j option given, discards paths.
5 #
6 # $Revision: 1.5 $
7 #
8 use strict;
9
10 my $dirName = 'extractTest';
11
12 use vars qw( $opt_j );
13 use Archive::Zip qw(:ERROR_CODES);
14 use Getopt::Std;
15
16 $opt_j = 0;
17 getopts('j');
18
19 if (@ARGV < 2)
20 {
21 die <<EOF
22 usage: perl extract.pl [-j] zipfile.zip filename [...]
23 if -j option given, discards paths.
24 EOF
25 }
26
27 my $zip = Archive::Zip->new();
28 my $zipName = shift(@ARGV);
29 my $status = $zip->read( $zipName );
30 die "Read of $zipName failed\n" if $status != AZ_OK;
31
32 foreach my $memberName (@ARGV)
33 {
34 print "Extracting $memberName\n";
35 $status = $opt_j
36 ? $zip->extractMemberWithoutPaths($memberName)
37 : $zip->extractMember($memberName);
38 die "Extracting $memberName from $zipName failed\n" if $status != AZ_OK;
39 }
+67
-0
examples/mailZip.pl less more
0 #!/usr/bin/perl -w
1 # Requires the following to be installed:
2 # File::Path
3 # File::Spec
4 # IO::Scalar, ... from the IO-stringy distribution
5 # MIME::Base64
6 # MIME::QuotedPrint
7 # Net::SMTP
8 # Mail::Internet, ... from the MailTools distribution.
9 # MIME::Tools
10
11 use strict;
12 use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
13 use IO::Scalar;
14 use MIME::Entity; # part of MIME::Tools package
15
16 my $zipContents = '';
17 my $SH = IO::Scalar->new( \$zipContents );
18
19 my $zip = Archive::Zip->new();
20 my $member;
21
22 # add a string as a member:
23 my $stringMember = '<html><head></head><body><h1>Testing</h1></body></html>';
24 $member = $zip->addString($stringMember, 'whatever.html');
25 # $member->desiredCompressionMethod(COMPRESSION_STORED);
26
27 # write it to the scalar
28 my $status = $zip->writeToFileHandle($SH);
29 $SH->close;
30
31 print STDERR "zip is ". length($zipContents). " bytes long\n";
32
33 ### Create an entity:
34 my $top = MIME::Entity->build(
35 Type => 'multipart/mixed',
36 From => 'ned@bike-nomad.com',
37 To => 'billnevin@tricom.net',
38 Subject => "Your zip",
39 );
40
41 # attach the message
42 $top->attach(
43 Encoding => '7bit',
44 Data => "here is the zip you ordered\n"
45 );
46
47 # attach the zip
48 $top->attach(
49 Data => \$zipContents,
50 Type => "application/x-zip",
51 Encoding => "base64",
52 Disposition => 'attachment',
53 Filename => 'your.zip'
54 );
55
56 # attach this code
57 $top->attach(
58 Encoding => '8bit',
59 Type => 'text/plain',
60 Path => $0,
61 # Data => 'whatever',
62 Disposition => 'inline'
63 );
64
65 # and print it out to stdout
66 $top->print( \*STDOUT );
+29
-0
examples/mfh.pl less more
0 # Prints messages on every chunk write.
1 # Usage:
2 # perl mfh.pl zipfile.zip
3 # $Revision: 1.4 $
4 use strict;
5 use Archive::Zip qw(:ERROR_CODES);
6 use Archive::Zip::MockFileHandle;
7
8 package NedsFileHandle;
9 use vars qw(@ISA);
10 @ISA = qw( Archive::Zip::MockFileHandle );
11
12 sub writeHook
13 {
14 my $self = shift;
15 my $bytes = shift;
16 my $length = length($bytes);
17 printf "write %d bytes (position now %d)\n", $length, $self->tell();
18 return $length;
19 }
20
21 package main;
22
23 my $zip = Archive::Zip->new();
24 my $status = $zip->read($ARGV[0]);
25 exit $status if $status != AZ_OK;
26
27 my $fh = NedsFileHandle->new();
28 $zip->writeToFileHandle($fh, 0);
+26
-0
examples/readScalar.pl less more
0 #!/usr/bin/perl -w
1 # Demonstrates reading a zip from an IO::Scalar
2 # $Revision: 1.4 $
3 use strict;
4 use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
5 use IO::Scalar;
6 use IO::File;
7
8 # test reading from a scalar
9 my $file = IO::File->new('testin.zip', 'r');
10 my $zipContents;
11 binmode($file);
12 $file->read($zipContents, 20000);
13 $file->close();
14 printf "Read %d bytes\n", length($zipContents);
15
16 my $SH = IO::Scalar->new(\$zipContents);
17
18 my $zip = Archive::Zip->new();
19 $zip->readFromFileHandle( $SH );
20 my $member = $zip->addString('c' x 300, 'bunchOfCs.txt');
21 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
22 $member = $zip->addString('d' x 300, 'bunchOfDs.txt');
23 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
24
25 $zip->writeToFileNamed('test2.zip');
+68
-0
examples/selfex.pl less more
0 #/usr/bin/perl -w
1 #
2 # Shows one way to write a self-extracting archive file.
3 # This is not intended for production use, and it always extracts to a
4 # subdirectory with a fixed name.
5 # Plus, it requires Perl and A::Z to be installed first.
6 #
7 # In general, you want to provide a stub that is platform-specific.
8 # You can use 'unzipsfx' that it provided with the Info-Zip unzip program.
9 # Get this from http://www.info-zip.org .
10 #
11 # $Revision: 1.6 $
12 #
13 use strict;
14
15 use Archive::Zip;
16 use IO::File;
17
18 # Make a self-extracting Zip file.
19
20 die "usage: $0 sfxname file [...]\n" unless @ARGV > 1;
21
22 my $outputName = shift();
23
24 my $zip = Archive::Zip->new();
25
26 foreach my $file (@ARGV)
27 {
28 $zip->addFileOrDirectory($file);
29 }
30
31 my $fh = IO::File->new( $outputName, O_CREAT | O_WRONLY | O_TRUNC, 0777 )
32 or die "Can't open $outputName\: $!\n";
33 binmode($fh);
34
35 # add self-extracting Perl code
36
37 while (<DATA>)
38 {
39 $fh->print($_)
40 }
41
42 $zip->writeToFileHandle($fh);
43
44 $fh->close();
45
46 # below the __DATA__ line is the extraction stub:
47 __DATA__
48 #!/usr/local/bin/perl
49 # Self-extracting Zip file extraction stub
50 # Copyright (C) 2002 Ned Konz
51
52 use Archive::Zip qw(:ERROR_CODES);
53 use IO::File;
54 use File::Spec;
55
56 my $dir = 'extracted';
57 my $zip = Archive::Zip->new();
58 my $fh = IO::File->new($0) or die "Can't open $0\: $!\n";
59 die "Zip read error\n" unless $zip->readFromFileHandle($fh) == AZ_OK;
60
61 (mkdir($dir, 0777) or die "Can't create directory $dir\: $!\n") unless -d $dir;
62
63 for my $member ( $zip->members )
64 {
65 $member->extractToFileNamed( File::Spec->catfile($dir,$member->fileName) );
66 }
67 __DATA__
+30
-0
examples/unzipAll.pl less more
0 #!/bin/perl -w
1 # Extracts all files from the given zip
2 # $Revision: 1.3 $
3 # usage:
4 # perl unzipAll.pl [-j] zipfile.zip
5 # if -j option given, discards paths.
6 #
7 use strict;
8
9 use vars qw( $opt_j );
10 use Archive::Zip qw(:ERROR_CODES);
11 use Getopt::Std;
12
13 $opt_j = 0;
14 getopts('j');
15
16 if (@ARGV < 1)
17 {
18 die <<EOF
19 usage: perl $0 [-j] zipfile.zip
20 if -j option given, discards paths.
21 EOF
22 }
23
24 my $zip = Archive::Zip->new();
25 my $zipName = shift(@ARGV);
26 my $status = $zip->read( $zipName );
27 die "Read of $zipName failed\n" if $status != AZ_OK;
28
29 $zip->extractTree();
+35
-0
examples/updateTree.pl less more
0 # Shows how to update a Zip in place using a temp file.
1 #
2 # usage:
3 # perl [-m] examples/updateTree.pl zipfile.zip dirname
4 #
5 # -m means to mirror
6 #
7 # $Id: updateTree.pl,v 1.2 2003/11/27 17:03:51 ned Exp $
8 #
9 use Archive::Zip qw(:ERROR_CODES);
10
11 my $mirror = 0;
12 if ( $ARGV[0] eq '-m' ) { shift; $mirror = 1; }
13
14 my $zipName = shift || die 'must provide a zip name';
15 my $dirName = shift || die 'must provide a directory name';
16
17 # Read the zip
18 my $zip = Archive::Zip->new();
19
20 if ( -f $zipName )
21 {
22 die "can't read $zipName\n" unless $zip->read($zipName) == AZ_OK;
23
24 # Update the zip
25 $zip->updateTree($dirName, undef, undef, $mirror);
26
27 # Now the zip is updated. Write it back via a temp file.
28 exit( $zip->overwrite() );
29 }
30 else # new zip
31 {
32 $zip->addTree($dirName);
33 exit( $zip->writeToFileNamed($zipName) );
34 }
+42
-0
examples/updateZip.pl less more
0 # Shows how to update a Zip in place using a temp file.
1 # $Revision: 1.1 $
2 #
3 use Archive::Zip qw(:ERROR_CODES);
4 use File::Copy();
5
6 my $zipName = shift || die 'must provide a zip name';
7 my @fileNames = @ARGV;
8 die 'must provide file names' unless scalar(@fileNames);
9
10 # Read the zip
11 my $zip = Archive::Zip->new();
12 die "can't read $zipName\n" unless $zip->read($zipName) == AZ_OK;
13
14 # Update the zip
15 foreach my $file (@fileNames)
16 {
17 $zip->removeMember($file);
18 if ( -r $file )
19 {
20 if ( -f $file )
21 {
22 $zip->addFile($file) or die "Can't add $file to zip!\n";
23 }
24 elsif ( -d $file )
25 {
26 $zip->addDirectory($file) or die "Can't add $file to zip!\n";
27 }
28 else
29 {
30 warn "Don't know how to add $file\n";
31 }
32 }
33 else
34 {
35 warn "Can't read $file\n";
36 }
37 }
38
39 # Now the zip is updated. Write it back via a temp file.
40
41 exit( $zip->overwrite() );
+22
-0
examples/writeScalar.pl less more
0 #!/usr/bin/perl -w
1 use strict;
2 use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
3 use IO::Scalar;
4 use IO::File;
5
6 # test writing to a scalar
7 my $zipContents = '';
8 my $SH = IO::Scalar->new(\$zipContents);
9
10 my $zip = Archive::Zip->new();
11 my $member = $zip->addString('a' x 300, 'bunchOfAs.txt');
12 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
13 $member = $zip->addString('b' x 300, 'bunchOfBs.txt');
14 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
15 my $status = $zip->writeToFileHandle( $SH );
16
17 my $file = IO::File->new('test.zip', 'w');
18 binmode($file);
19 $file->print($zipContents);
20 $file->close();
21
+22
-0
examples/writeScalar2.pl less more
0 #!/usr/bin/perl -w
1 use strict;
2 use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
3 use IO::String;
4 use IO::File;
5
6 # test writing to a scalar
7 my $zipContents = '';
8 my $SH = IO::String->new($zipContents);
9
10 my $zip = Archive::Zip->new();
11 my $member = $zip->addString('a' x 300, 'bunchOfAs.txt');
12 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
13 $member = $zip->addString('b' x 300, 'bunchOfBs.txt');
14 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
15 my $status = $zip->writeToFileHandle( $SH );
16
17 my $file = IO::File->new('test.zip', 'w');
18 binmode($file);
19 $file->print($zipContents);
20 $file->close();
21
+30
-0
examples/zip.pl less more
0 #!/bin/perl -w
1 # Creates a zip file, adding the given directories and files.
2 # Usage:
3 # perl zip.pl zipfile.zip file [...]
4
5 use strict;
6 use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
7
8 die "usage: $0 zipfile.zip file [...]\n"
9 if (scalar(@ARGV) < 2);
10
11 my $zipName = shift(@ARGV);
12 my $zip = Archive::Zip->new();
13
14 foreach my $memberName (map { glob } @ARGV)
15 {
16 if (-d $memberName )
17 {
18 warn "Can't add tree $memberName\n"
19 if $zip->addTree( $memberName, $memberName ) != AZ_OK;
20 }
21 else
22 {
23 $zip->addFile( $memberName )
24 or warn "Can't add file $memberName\n";
25 }
26 }
27
28 my $status = $zip->writeToFileNamed($zipName);
29 exit $status;
+57
-0
examples/zipGrep.pl less more
0 #!/usr/bin/perl -w
1 # This program searches for the given Perl regular expression in a Zip archive.
2 # Archive is assumed to contain text files.
3 # By Ned Konz, perl@bike-nomad.com
4 # Usage:
5 # perl zipGrep.pl 'pattern' myZip.zip
6 #
7 use strict;
8 use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
9
10 if ( @ARGV != 2 )
11 {
12 print <<EOF;
13 This program searches for the given Perl regular expression in a Zip archive.
14 Archive is assumed to contain text files.
15 Usage:
16 perl $0 'pattern' myZip.zip
17 EOF
18 exit 1;
19 }
20
21 my $pattern = shift;
22 $pattern = qr{$pattern}; # compile the regular expression
23 my $zipName = shift;
24
25 my $zip = Archive::Zip->new();
26 if ( $zip->read($zipName) != AZ_OK )
27 {
28 die "Read error reading $zipName\n";
29 }
30
31 foreach my $member ( $zip->members() )
32 {
33 my ( $bufferRef, $status, $lastChunk );
34 my $memberName = $member->fileName();
35 my $lineNumber = 1;
36 $lastChunk = '';
37 $member->desiredCompressionMethod(COMPRESSION_STORED);
38 $status = $member->rewindData();
39 die "rewind error $status" if $status != AZ_OK;
40
41 while ( !$member->readIsDone() )
42 {
43 ( $bufferRef, $status ) = $member->readChunk();
44 die "readChunk error $status"
45 if $status != AZ_OK && $status != AZ_STREAM_END;
46
47 my $buffer = $lastChunk . $$bufferRef;
48 while ( $buffer =~ m{(.*$pattern.*\n)}mg )
49 {
50 print "$memberName:$1";
51 }
52 ($lastChunk) = $$bufferRef =~ m{([^\n\r]+)\z};
53 }
54
55 $member->endRead();
56 }
+39
-0
examples/zipcheck.pl less more
0 #!/bin/perl -w
1 # usage: valid zipname.zip
2 # exits with non-zero status if invalid zip
3 # status = 1: invalid arguments
4 # status = 2: generic error somewhere
5 # status = 3: format error
6 # status = 4: IO error
7 use strict;
8 use Archive::Zip qw(:ERROR_CODES);
9 use IO::Handle;
10 use File::Spec;
11
12 # instead of stack dump:
13 Archive::Zip::setErrorHandler( sub { warn shift() } );
14
15 my $nullFileName = File::Spec->devnull();
16 my $zip = Archive::Zip->new();
17 my $zipName = shift(@ARGV) || exit 1;
18 eval
19 {
20 my $status = $zip->read( $zipName );
21 exit $status if $status != AZ_OK;
22 };
23 if ($@) { warn 'error reading zip:', $@, "\n"; exit 2 }
24
25 eval
26 {
27 foreach my $member ($zip->members)
28 {
29 my $fh = IO::File->new();
30 $fh->open(">$nullFileName") || die "can't open $nullFileName\: $!\n";
31 my $status = $member->extractToFileHandle($fh);
32 if ($status != AZ_OK)
33 {
34 warn "Extracting ", $member->fileName(), " from $zipName failed\n";
35 exit $status;
36 }
37 }
38 }
+147
-0
examples/zipinfo.pl less more
0 #! /usr/bin/perl -w
1 # Print out information about a ZIP file.
2 # Note that this buffers the entire file into memory!
3 # usage:
4 # perl examples/zipinfo.pl zipfile.zip
5
6 use strict;
7
8 use Data::Dumper ();
9 use FileHandle;
10 use Archive::Zip qw(:ERROR_CODES :CONSTANTS :PKZIP_CONSTANTS);
11 use Archive::Zip::BufferedFileHandle;
12
13 $| = 1;
14
15 ### Workaround for a bug in version of Data::Dumper bundled
16 ### with some versions of Perl, which causes warnings when
17 ### calling ->Seen below.
18 if ( defined &Data::Dumper::init_refaddr_format ) {
19 Data::Dumper::init_refaddr_format();
20 }
21
22 # use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING;
23 use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE_STRING => pack( SIGNATURE_FORMAT,
24 CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
25 use constant LOCAL_FILE_HEADER_SIGNATURE_STRING => pack( SIGNATURE_FORMAT,
26 LOCAL_FILE_HEADER_SIGNATURE );
27
28 $Data::Dumper::Useqq = 1; # enable double-quotes for string values
29 $Data::Dumper::Indent = 1;
30
31 my $zip = Archive::Zip->new();
32 my $zipFileName = shift(@ARGV);
33
34 my $fh = Archive::Zip::BufferedFileHandle->new();
35 $fh->readFromFile($zipFileName) or exit($!);
36
37 my $status = $zip->_findEndOfCentralDirectory($fh);
38 die("can't find EOCD\n") if $status != AZ_OK;
39
40 my $eocdPosition = $fh->tell( );
41
42 $status = $zip->_readEndOfCentralDirectory($fh);
43 die("can't read EOCD\n") if $status != AZ_OK;
44
45 my $zipDumper = Data::Dumper->new([$zip], ['ZIP']);
46 $zipDumper->Seen({ ref($fh), $fh });
47 print $zipDumper->Dump(), "\n";
48
49 my $expectedEOCDPosition = $zip->centralDirectoryOffsetWRTStartingDiskNumber()
50 + $zip->centralDirectorySize();
51
52 my $eocdOffset = $zip->{eocdOffset} = $eocdPosition - $expectedEOCDPosition;
53
54 if ($eocdOffset)
55 {
56 printf "Expected EOCD at %d (0x%x) but found it at %d (0x%x)\n",
57 ($expectedEOCDPosition) x 2, ($eocdPosition) x 2;
58 }
59 else
60 {
61 printf("Found EOCD at %d (0x%x)\n\n", ($eocdPosition) x 2);
62 }
63
64 my $contents = $fh->contents();
65 my $offset = $eocdPosition + $eocdOffset - 1;
66 my $cdPos;
67 my @members;
68 my $numberOfMembers = $zip->numberOfCentralDirectoriesOnThisDisk();
69 foreach my $n (0 .. $numberOfMembers - 1)
70 {
71 my $index = $numberOfMembers - $n;
72 $cdPos = rindex($contents,
73 CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE_STRING, $offset);
74 if ($cdPos < 0)
75 {
76 print "No central directory found for member #$index\n";
77 last;
78 }
79 else
80 {
81 print "Found central directory for member #$index at $cdPos\n";
82 $fh->seek($cdPos + SIGNATURE_LENGTH, 0); # SEEK_SET
83 my $newMember = $zip->ZIPMEMBERCLASS->_newFromZipFile(
84 $fh, "($zipFileName)" );
85 $status = $newMember->_readCentralDirectoryFileHeader();
86 if ($status != AZ_OK and $status != AZ_STREAM_END)
87 {
88 printf "read CD header status=%d\n", $status;
89 last;
90 }
91 unshift(@members, $newMember);
92
93 my $memberDumper = Data::Dumper->new([$newMember], ['CDMEMBER' . $index ]);
94 $memberDumper->Seen({ ref($fh), $fh });
95 print $memberDumper->Dump(), "\n";
96 }
97 $offset = $cdPos - 1;
98 }
99
100 if ($cdPos >= 0 and
101 $cdPos != $zip->centralDirectoryOffsetWRTStartingDiskNumber())
102 {
103 printf "Expected to find central directory at %d (0x%x), but found it at %d (0x%x)\n",
104 ($zip->centralDirectoryOffsetWRTStartingDiskNumber()) x 2,
105 ($cdPos) x 2;
106 }
107
108 print "\n";
109
110 # Now read the local headers
111
112 foreach my $n (0 .. $#members)
113 {
114 my $member = $members[$n];
115 $fh->seek($member->localHeaderRelativeOffset() + $eocdOffset + SIGNATURE_LENGTH, 0);
116 $status = $member->_readLocalFileHeader();
117 if ($status != AZ_OK and $status != AZ_STREAM_END)
118 {
119 printf "member %d read header status=%d\n", $n+1, $status;
120 last;
121 }
122
123 my $memberDumper = Data::Dumper->new([$member], ['LHMEMBER' . ($n + 1)]);
124 $memberDumper->Seen({ ref($fh), $fh });
125 print $memberDumper->Dump(), "\n";
126
127 my $endOfMember = $member->localHeaderRelativeOffset()
128 + $member->_localHeaderSize()
129 + $member->compressedSize();
130
131 if ($endOfMember > $cdPos
132 or ($n < $#members and
133 $endOfMember > $members[$n+1]->localHeaderRelativeOffset()))
134 {
135 print "Error: ";
136 }
137 printf("End of member: %d, CD at %d", $endOfMember, $cdPos);
138 if ( $n < $#members )
139 {
140 printf(", next member starts at %d",
141 $members[$n+1]->localHeaderRelativeOffset());
142 }
143 print("\n\n");
144 }
145
146 # vim: ts=4 sw=4
+329
-0
examples/ziprecent.pl less more
0 #!/usr/bin/perl -w
1 # Makes a zip file of the most recent files in a specified directory.
2 # By Rudi Farkas, rudif@bluemail.ch, 9 December 2000
3 # Usage:
4 # ziprecent <dir> -d <ageDays> [-e <ext> ...]> [-h] [-msvc] [-q] [<zippath>]
5 # Zips files in source directory and its subdirectories
6 # whose file extension is in specified extensions (default: any extension).
7 # -d <days> max age (days) for files to be zipped (default: 1 day)
8 # <dir> source directory
9 # -e <ext> one or more space-separated extensions
10 # -h print help text and exit
11 # -msvc may be given instead of -e and will zip all msvc source files
12 # -q query only (list files but don't zip)
13 # <zippath>.zip path to zipfile to be created (or updated if it exists)
14 #
15 # $Revision: 1.2 $
16
17 use strict;
18
19 use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
20 use Cwd;
21 use File::Basename;
22 use File::Copy;
23 use File::Find;
24 use File::Path;
25
26 # argument and variable defaults
27 #
28 my $maxFileAgeDays = 1;
29 my $defaultzipdir = 'h:/zip/_homework';
30 my ($sourcedir, $zipdir, $zippath, @extensions, $query);
31
32
33 # usage
34 #
35 my $scriptname = basename $0;
36 my $usage = <<ENDUSAGE;
37 $scriptname <dir> -d <ageDays> [-e <ext> ...]> [-h] [-msvc] [-q] [<zippath>]
38 Zips files in source directory and its subdirectories
39 whose file extension is in specified extensions (default: any extension).
40 -d <days> max age (days) for files to be zipped (default: 1 day)
41 <dir> source directory
42 -e <ext> one or more space-separated extensions
43 -h print help text and exit
44 -msvc may be given instead of -e and will zip all msvc source files
45 -q query only (list files but don't zip)
46 <zippath>.zip path to zipfile to be created (or updated if it exists)
47 ENDUSAGE
48
49
50 # parse arguments
51 #
52 while (@ARGV) {
53 my $arg = shift;
54
55 if ($arg eq '-d') {
56 $maxFileAgeDays = shift;
57 $maxFileAgeDays = 0.0 if $maxFileAgeDays < 0.0;
58 }
59 elsif ($arg eq '-e') {
60 while ($ARGV[0] && $ARGV[0] !~ /^-/) {
61 push @extensions, shift;
62 }
63 }
64 elsif ($arg eq '-msvc') {
65 push @extensions, qw / bmp c cpp def dlg dsp dsw h ico idl mak odl rc rc2 rgs /;
66 }
67 elsif ($arg eq '-q') {
68 $query = 1;
69 }
70 elsif ($arg eq '-h') {
71 print STDERR $usage;
72 exit;
73 }
74 elsif (-d $arg) {
75 $sourcedir = $arg;
76 }
77 elsif ($arg eq '-z') {
78 if ($ARGV[0]) {
79 $zipdir = shift;
80 }
81 }
82 elsif ($arg =~ /\.zip$/) {
83 $zippath = $arg;
84 }
85 else {
86 errorExit("Unknown option or argument: $arg");
87 }
88 }
89
90 # process arguments
91 #
92 errorExit("Please specify an existing source directory") unless defined($sourcedir) && -d $sourcedir;
93
94 my $extensions;
95 if (@extensions) {
96 $extensions = join "|", @extensions;
97 }
98 else {
99 $extensions = ".*";
100 }
101
102 # change '\' to '/' (avoids trouble in substitution on Win2k)
103 #
104 $sourcedir =~ s|\\|/|g;
105 $zippath =~ s|\\|/|g if defined($zippath);
106
107
108 # find files
109 #
110 my @files;
111 cwd $sourcedir;
112 find(\&listFiles, $sourcedir);
113 printf STDERR "Found %d file(s)\n", scalar @files;
114
115
116 # exit ?
117 #
118 exit if $query;
119 exit if @files <= 0;
120
121
122 # prepare zip directory
123 #
124 if (defined($zippath)) {
125 # deduce directory from zip path
126 $zipdir = dirname($zippath);
127 $zipdir = '.' unless length $zipdir;
128 }
129 else {
130 $zipdir= $defaultzipdir;
131 }
132
133 # make sure that zip directory exists
134 #
135 mkpath $zipdir unless -d $zipdir;
136 -d $zipdir or die "Can't find/make directory $zipdir\n";
137
138
139
140 # create the zip object
141 #
142 my $zip = Archive::Zip->new();
143
144
145 # read-in the existing zip file if any
146 #
147 if (defined $zippath && -f $zippath) {
148 my $status = $zip->read($zippath);
149 warn "Read $zippath failed\n" if $status != AZ_OK;
150 }
151
152 # add files
153 #
154 foreach my $memberName (@files)
155 {
156 if (-d $memberName )
157 {
158 warn "Can't add tree $memberName\n"
159 if $zip->addTree( $memberName, $memberName ) != AZ_OK;
160 }
161 else
162 {
163 $zip->addFile( $memberName )
164 or warn "Can't add file $memberName\n";
165 }
166 }
167
168
169 # prepare the new zip path
170 #
171 my $newzipfile = genfilename();
172 my $newzippath = "$zipdir/$newzipfile";
173
174
175 # write the new zip file
176 #
177 my $status = $zip->writeToFileNamed($newzippath);
178 if ($status == AZ_OK) {
179 # rename (and overwrite the old zip file if any)?
180 #
181 if (defined $zippath) {
182 my $res = rename $newzippath, $zippath;
183 if ($res) {
184 print STDERR "Updated file $zippath\n";
185 }
186 else {
187 print STDERR "Created file $newzippath, failed to rename to $zippath\n";
188 }
189 }
190 else {
191 print STDERR "Created file $newzippath\n";
192 }
193 }
194 else {
195 print STDERR "Failed to create file $newzippath\n";
196 }
197
198
199
200 # subroutines
201 #
202
203 sub listFiles {
204 if (/\.($extensions)$/) {
205 cwd $File::Find::dir;
206 return if -d $File::Find::name; # skip directories
207 my $fileagedays = fileAgeDays($_);
208 if ($fileagedays < $maxFileAgeDays) {
209 printf STDERR "$File::Find::name (%.3g)\n", $fileagedays;
210 (my $filename = $File::Find::name) =~ s/^[a-zA-Z]://; # remove the leading drive letter:
211 push @files, $filename;
212 }
213 }
214 }
215
216 sub errorExit {
217 printf STDERR "*** %s ***\n$usage\n", shift;
218 exit;
219 }
220
221 sub mtime {
222 (stat shift)[9];
223 }
224
225 sub fileAgeDays {
226 (time() - mtime(shift)) / 86400;
227 }
228
229 sub genfilename {
230 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
231 sprintf "%04d%02d%02d-%02d%02d%02d.zip", $year+1900, $mon+1, $mday, $hour, $min, $sec;
232 }
233
234 __END__
235
236 =head1 NAME
237
238 ziprecent.pl
239
240 =head1 SYNOPSIS
241
242 ziprecent h:/myperl
243
244 ziprecent h:/myperl -e pl pm -d 365
245
246 ziprecent h:/myperl -q
247
248 ziprecent h:/myperl h:/temp/zip/file1.zip
249
250
251 =head1 DESCRIPTION
252
253 =over 4
254
255 This script helps to collect recently modified files in a source directory
256 into a zip file (new or existing).
257
258 It uses Archive::Zip.
259
260 =item C< ziprecent h:/myperl >
261
262 Lists and zips all files more recent than 1 day (24 hours)
263 in directory h:/myperl and it's subdirectories,
264 and places the zip file into default zip directory.
265 The generated zip file name is based on local time (e.g. 20001208-231237.zip).
266
267
268 =item C< ziprecent h:/myperl -e pl pm -d 365 >
269
270 Zips only .pl and .pm files more recent than one year.
271
272
273 =item C< ziprecent h:/myperl -msvc >
274
275 Zips source files found in a typical MSVC project.
276
277
278 =item C< ziprecent h:/myperl -q >
279
280 Lists files that should be zipped.
281
282
283 =item C< ziprecent h:/myperl h:/temp/zip/file1.zip >
284
285 Updates file named h:/temp/zip/file1.zip
286 (overwrites an existing file if writable).
287
288
289 =item C< ziprecent -h >
290
291 Prints the help text and exits.
292
293 ziprecent.pl <dir> -d <days> [-e <ext> ...]> [-h] [-msvc] [-q] [<zippath>]
294 Zips files in source directory and its subdirectories
295 whose file extension is in specified extensions (default: any extension).
296 -d <days> max age (days) for files to be zipped (default: 1 day)
297 <dir> source directory
298 -e <ext> one or more space-separated extensions
299 -h print help text and exit
300 -msvc may be given instead of -e and will zip all msvc source files
301 -q query only (list files but don't zip)
302 <zippath>.zip path to zipfile to be created (or updated if it exists)
303
304 =back
305
306
307 =head1 BUGS
308
309 Tested only on Win2k.
310
311 Does not handle filenames without extension.
312
313 Does not accept more than one source directory (workaround: invoke separately
314 for each directory, specifying the same zip file).
315
316
317 =head1 AUTHOR
318
319 Rudi Farkas rudif@lecroy.com rudif@bluemail.ch
320
321 =head1 SEE ALSO
322
323 perl ;-)
324
325 =cut
326
327
328
+82
-0
examples/ziptest.pl less more
0 #!/bin/perl -w
1 # $Revision: 1.7 $
2 # Lists the zipfile given as a first argument and tests CRC's.
3 # Usage:
4 # perl ziptest.pl zipfile.zip
5
6 use strict;
7
8 use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
9
10 package CRCComputingFileHandle;
11 use Archive::Zip::MockFileHandle;
12
13 use vars qw( @ISA );
14 @ISA = qw( Archive::Zip::MockFileHandle );
15
16 my $crc;
17
18 sub writeHook
19 {
20 my $self = shift;
21 my $bytes = shift;
22 my $length = length($bytes);
23 $crc = Archive::Zip::computeCRC32($bytes, $crc);
24 }
25
26 sub resetCRC { $crc = 0 }
27
28 sub crc { $crc }
29
30 package main;
31
32 die "usage: $0 zipfile.zip\n"
33 if (scalar(@ARGV) != 1);
34
35 my $zip = Archive::Zip->new();
36 my $status = $zip->read( $ARGV[0] );
37 exit $status if $status != AZ_OK;
38
39 print " Length Size Last Modified CRC-32 Name\n";
40 print "-------- -------- ------------------------ -------- ----\n";
41
42 my $fh = CRCComputingFileHandle->new();
43 my @errors;
44
45 foreach my $member ($zip->members())
46 {
47 my $compressedSize = $member->compressedSize();
48 $fh->resetCRC();
49 $member->desiredCompressionMethod(COMPRESSION_STORED);
50 $status = $member->extractToFileHandle($fh);
51 exit $status if $status != AZ_OK;
52 my $crc = $fh->crc();
53
54 my $ct = scalar(localtime($member->lastModTime()));
55 chomp($ct);
56
57 printf("%8d %8d %s %08x %s\n",
58 $member->uncompressedSize(),
59 $compressedSize,
60 $ct,
61 $member->crc32(),
62 $member->fileName()
63 );
64
65 if ($member->crc32() != $crc)
66 {
67 push(@errors,
68 sprintf("Member %s CRC error: file says %08x computed: %08x\n",
69 $member->fileName(), $member->crc32(), $crc));
70 }
71 }
72
73 if (scalar(@errors))
74 {
75 print join("\n", @errors);
76 die "CRC errors found\n";
77 }
78 else
79 {
80 print "All CRCs check OK\n";
81 }
+786
-0
lib/Archive/Zip/Archive.pm less more
0 package Archive::Zip::Archive;
1
2 # Represents a generic ZIP archive
3
4 use strict;
5 use File::Path;
6 use File::Find ();
7 use File::Spec ();
8 use File::Copy ();
9 use File::Basename;
10 use Cwd;
11
12 use vars qw( $VERSION @ISA );
13
14 BEGIN {
15 $VERSION = '1.18';
16 @ISA = qw( Archive::Zip );
17 }
18
19 use Archive::Zip qw(
20 :CONSTANTS
21 :ERROR_CODES
22 :PKZIP_CONSTANTS
23 :UTILITY_METHODS
24 );
25
26 # Note that this returns undef on read errors, else new zip object.
27
28 sub new {
29 my $class = shift;
30 my $self = bless(
31 {
32 'diskNumber' => 0,
33 'diskNumberWithStartOfCentralDirectory' => 0,
34 'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
35 'numberOfCentralDirectories' => 0, # shld be # of members
36 'centralDirectorySize' => 0, # must re-compute on write
37 'centralDirectoryOffsetWRTStartingDiskNumber' =>
38 0, # must re-compute
39 'writeEOCDOffset' => 0,
40 'writeCentralDirectoryOffset' => 0,
41 'zipfileComment' => '',
42 'eocdOffset' => 0,
43 'fileName' => ''
44 },
45 $class
46 );
47 $self->{'members'} = [];
48 if (@_) {
49 my $status = $self->read(@_);
50 return $status == AZ_OK ? $self : undef;
51 }
52 return $self;
53 }
54
55 sub members {
56 @{ shift->{'members'} };
57 }
58
59 sub numberOfMembers {
60 scalar( shift->members() );
61 }
62
63 sub memberNames {
64 my $self = shift;
65 return map { $_->fileName() } $self->members();
66 }
67
68 # return ref to member with given name or undef
69 sub memberNamed {
70 my ( $self, $fileName ) = @_;
71 foreach my $member ( $self->members() ) {
72 return $member if $member->fileName() eq $fileName;
73 }
74 return undef;
75 }
76
77 sub membersMatching {
78 my ( $self, $pattern ) = @_;
79 return grep { $_->fileName() =~ /$pattern/ } $self->members();
80 }
81
82 sub diskNumber {
83 shift->{'diskNumber'};
84 }
85
86 sub diskNumberWithStartOfCentralDirectory {
87 shift->{'diskNumberWithStartOfCentralDirectory'};
88 }
89
90 sub numberOfCentralDirectoriesOnThisDisk {
91 shift->{'numberOfCentralDirectoriesOnThisDisk'};
92 }
93
94 sub numberOfCentralDirectories {
95 shift->{'numberOfCentralDirectories'};
96 }
97
98 sub centralDirectorySize {
99 shift->{'centralDirectorySize'};
100 }
101
102 sub centralDirectoryOffsetWRTStartingDiskNumber {
103 shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
104 }
105
106 sub zipfileComment {
107 my $self = shift;
108 my $comment = $self->{'zipfileComment'};
109 if (@_) {
110 $self->{'zipfileComment'} = pack( 'C0a*', shift() ); # avoid unicode
111 }
112 return $comment;
113 }
114
115 sub eocdOffset {
116 shift->{'eocdOffset'};
117 }
118
119 # Return the name of the file last read.
120 sub fileName {
121 shift->{'fileName'};
122 }
123
124 sub removeMember {
125 my ( $self, $member ) = @_;
126 $member = $self->memberNamed($member) unless ref($member);
127 return undef unless $member;
128 my @newMembers = grep { $_ != $member } $self->members();
129 $self->{'members'} = \@newMembers;
130 return $member;
131 }
132
133 sub replaceMember {
134 my ( $self, $oldMember, $newMember ) = @_;
135 $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
136 return undef unless $oldMember;
137 return undef unless $newMember;
138 my @newMembers =
139 map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
140 $self->{'members'} = \@newMembers;
141 return $oldMember;
142 }
143
144 sub extractMember {
145 my $self = shift;
146 my $member = shift;
147 $member = $self->memberNamed($member) unless ref($member);
148 return _error('member not found') unless $member;
149 my $originalSize = $member->compressedSize();
150 my $name = shift; # local FS name if given
151 my ( $volumeName, $dirName, $fileName );
152 if ( defined($name) ) {
153 ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
154 $dirName = File::Spec->catpath( $volumeName, $dirName, '' );
155 }
156 else {
157 $name = $member->fileName();
158 ( $dirName = $name ) =~ s{[^/]*$}{};
159 $dirName = Archive::Zip::_asLocalName($dirName);
160 $name = Archive::Zip::_asLocalName($name);
161 }
162 if ( $dirName && !-d $dirName ) {
163 mkpath($dirName);
164 return _ioError("can't create dir $dirName") if ( !-d $dirName );
165 }
166 my $rc = $member->extractToFileNamed( $name, @_ );
167
168 # TODO refactor this fix into extractToFileNamed()
169 $member->{'compressedSize'} = $originalSize;
170 return $rc;
171 }
172
173 sub extractMemberWithoutPaths {
174 my $self = shift;
175 my $member = shift;
176 $member = $self->memberNamed($member) unless ref($member);
177 return _error('member not found') unless $member;
178 my $originalSize = $member->compressedSize();
179 return AZ_OK if $member->isDirectory();
180 my $name = shift;
181 unless ($name) {
182 $name = $member->fileName();
183 $name =~ s{.*/}{}; # strip off directories, if any
184 $name = Archive::Zip::_asLocalName($name);
185 }
186 my $rc = $member->extractToFileNamed( $name, @_ );
187 $member->{'compressedSize'} = $originalSize;
188 return $rc;
189 }
190
191 sub addMember {
192 my ( $self, $newMember ) = @_;
193 push( @{ $self->{'members'} }, $newMember ) if $newMember;
194 return $newMember;
195 }
196
197 sub addFile {
198 my $self = shift;
199 my $fileName = shift;
200 my $newName = shift;
201 my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
202 $self->addMember($newMember) if defined($newMember);
203 return $newMember;
204 }
205
206 sub addString {
207 my $self = shift;
208 my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
209 return $self->addMember($newMember);
210 }
211
212 sub addDirectory {
213 my ( $self, $name, $newName ) = @_;
214 my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
215 $self->addMember($newMember);
216 return $newMember;
217 }
218
219 # add either a file or a directory.
220
221 sub addFileOrDirectory {
222 my ( $self, $name, $newName ) = @_;
223 if ( -f $name ) {
224 ( $newName =~ s{/$}{} ) if $newName;
225 return $self->addFile( $name, $newName );
226 }
227 elsif ( -d $name ) {
228 ( $newName =~ s{[^/]$}{&/} ) if $newName;
229 return $self->addDirectory( $name, $newName );
230 }
231 else {
232 return _error("$name is neither a file nor a directory");
233 }
234 }
235
236 sub contents {
237 my ( $self, $member, $newContents ) = @_;
238 return _error('No member name given') unless $member;
239 $member = $self->memberNamed($member) unless ref($member);
240 return undef unless $member;
241 return $member->contents($newContents);
242 }
243
244 sub writeToFileNamed {
245 my $self = shift;
246 my $fileName = shift; # local FS format
247 foreach my $member ( $self->members() ) {
248 if ( $member->_usesFileNamed($fileName) ) {
249 return _error( "$fileName is needed by member "
250 . $member->fileName()
251 . "; consider using overwrite() or overwriteAs() instead." );
252 }
253 }
254 my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
255 return _ioError("Can't open $fileName for write") unless $status;
256 my $retval = $self->writeToFileHandle( $fh, 1 );
257 $fh->close();
258 $fh = undef;
259
260 return $retval;
261 }
262
263 # It is possible to write data to the FH before calling this,
264 # perhaps to make a self-extracting archive.
265 sub writeToFileHandle {
266 my $self = shift;
267 my $fh = shift;
268 return _error('No filehandle given') unless $fh;
269 return _ioError('filehandle not open') unless $fh->opened();
270
271 my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
272 _binmode($fh);
273
274 # Find out where the current position is.
275 my $offset = $fhIsSeekable ? $fh->tell() : 0;
276 $offset = 0 if $offset < 0;
277
278 foreach my $member ( $self->members() ) {
279 my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
280 $member->endRead();
281 return $retval if $retval != AZ_OK;
282 $offset += $member->_localHeaderSize() + $member->_writeOffset();
283 $offset +=
284 $member->hasDataDescriptor()
285 ? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
286 : 0;
287
288 # changed this so it reflects the last successful position
289 $self->{'writeCentralDirectoryOffset'} = $offset;
290 }
291 return $self->writeCentralDirectory($fh);
292 }
293
294 # Write zip back to the original file,
295 # as safely as possible.
296 # Returns AZ_OK if successful.
297 sub overwrite {
298 my $self = shift;
299 return $self->overwriteAs( $self->{'fileName'} );
300 }
301
302 # Write zip to the specified file,
303 # as safely as possible.
304 # Returns AZ_OK if successful.
305 sub overwriteAs {
306 my $self = shift;
307 my $zipName = shift;
308 return _error("no filename in overwriteAs()") unless defined($zipName);
309
310 my ( $fh, $tempName ) = Archive::Zip::tempFile();
311 return _error( "Can't open temp file", $! ) unless $fh;
312
313 ( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
314
315 my $status = $self->writeToFileHandle($fh);
316 $fh->close();
317 $fh = undef;
318
319 if ( $status != AZ_OK ) {
320 unlink($tempName);
321 _printError("Can't write to $tempName");
322 return $status;
323 }
324
325 my $err;
326
327 # rename the zip
328 if ( -f $zipName && !rename( $zipName, $backupName ) ) {
329 $err = $!;
330 unlink($tempName);
331 return _error( "Can't rename $zipName as $backupName", $err );
332 }
333
334 # move the temp to the original name (possibly copying)
335 unless ( File::Copy::move( $tempName, $zipName ) ) {
336 $err = $!;
337 rename( $backupName, $zipName );
338 unlink($tempName);
339 return _error( "Can't move $tempName to $zipName", $err );
340 }
341
342 # unlink the backup
343 if ( -f $backupName && !unlink($backupName) ) {
344 $err = $!;
345 return _error( "Can't unlink $backupName", $err );
346 }
347
348 return AZ_OK;
349 }
350
351 # Used only during writing
352 sub _writeCentralDirectoryOffset {
353 shift->{'writeCentralDirectoryOffset'};
354 }
355
356 sub _writeEOCDOffset {
357 shift->{'writeEOCDOffset'};
358 }
359
360 # Expects to have _writeEOCDOffset() set
361 sub _writeEndOfCentralDirectory {
362 my ( $self, $fh ) = @_;
363
364 $fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
365 or return _ioError('writing EOCD Signature');
366 my $zipfileCommentLength = length( $self->zipfileComment() );
367
368 my $header = pack(
369 END_OF_CENTRAL_DIRECTORY_FORMAT,
370 0, # {'diskNumber'},
371 0, # {'diskNumberWithStartOfCentralDirectory'},
372 $self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
373 $self->numberOfMembers(), # {'numberOfCentralDirectories'},
374 $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
375 $self->_writeCentralDirectoryOffset(),
376 $zipfileCommentLength
377 );
378 $fh->print($header)
379 or return _ioError('writing EOCD header');
380 if ($zipfileCommentLength) {
381 $fh->print( $self->zipfileComment() )
382 or return _ioError('writing zipfile comment');
383 }
384 return AZ_OK;
385 }
386
387 # $offset can be specified to truncate a zip file.
388 sub writeCentralDirectory {
389 my ( $self, $fh, $offset ) = @_;
390
391 if ( defined($offset) ) {
392 $self->{'writeCentralDirectoryOffset'} = $offset;
393 $fh->seek( $offset, IO::Seekable::SEEK_SET )
394 or return _ioError('seeking to write central directory');
395 }
396 else {
397 $offset = $self->_writeCentralDirectoryOffset();
398 }
399
400 foreach my $member ( $self->members() ) {
401 my $status = $member->_writeCentralDirectoryFileHeader($fh);
402 return $status if $status != AZ_OK;
403 $offset += $member->_centralDirectoryHeaderSize();
404 $self->{'writeEOCDOffset'} = $offset;
405 }
406 return $self->_writeEndOfCentralDirectory($fh);
407 }
408
409 sub read {
410 my $self = shift;
411 my $fileName = shift;
412 return _error('No filename given') unless $fileName;
413 my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
414 return _ioError("opening $fileName for read") unless $status;
415
416 $status = $self->readFromFileHandle( $fh, $fileName );
417 return $status if $status != AZ_OK;
418
419 $fh->close();
420 $self->{'fileName'} = $fileName;
421 return AZ_OK;
422 }
423
424 sub readFromFileHandle {
425 my $self = shift;
426 my $fh = shift;
427 my $fileName = shift;
428 $fileName = $fh unless defined($fileName);
429 return _error('No filehandle given') unless $fh;
430 return _ioError('filehandle not open') unless $fh->opened();
431
432 _binmode($fh);
433 $self->{'fileName'} = "$fh";
434
435 # TODO: how to support non-seekable zips?
436 return _error('file not seekable')
437 unless _isSeekable($fh);
438
439 $fh->seek( 0, 0 ); # rewind the file
440
441 my $status = $self->_findEndOfCentralDirectory($fh);
442 return $status if $status != AZ_OK;
443
444 my $eocdPosition = $fh->tell();
445
446 $status = $self->_readEndOfCentralDirectory($fh);
447 return $status if $status != AZ_OK;
448
449 $fh->seek( $eocdPosition - $self->centralDirectorySize(),
450 IO::Seekable::SEEK_SET )
451 or return _ioError("Can't seek $fileName");
452
453 # Try to detect garbage at beginning of archives
454 # This should be 0
455 $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
456 - $self->centralDirectoryOffsetWRTStartingDiskNumber();
457
458 for ( ; ; ) {
459 my $newMember =
460 $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
461 $self->eocdOffset() );
462 my $signature;
463 ( $status, $signature ) = _readSignature( $fh, $fileName );
464 return $status if $status != AZ_OK;
465 last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
466 $status = $newMember->_readCentralDirectoryFileHeader();
467 return $status if $status != AZ_OK;
468 $status = $newMember->endRead();
469 return $status if $status != AZ_OK;
470 $newMember->_becomeDirectoryIfNecessary();
471 push( @{ $self->{'members'} }, $newMember );
472 }
473
474 return AZ_OK;
475 }
476
477 # Read EOCD, starting from position before signature.
478 # Return AZ_OK on success.
479 sub _readEndOfCentralDirectory {
480 my $self = shift;
481 my $fh = shift;
482
483 # Skip past signature
484 $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
485 or return _ioError("Can't seek past EOCD signature");
486
487 my $header = '';
488 my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
489 if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH ) {
490 return _ioError("reading end of central directory");
491 }
492
493 my $zipfileCommentLength;
494 (
495 $self->{'diskNumber'},
496 $self->{'diskNumberWithStartOfCentralDirectory'},
497 $self->{'numberOfCentralDirectoriesOnThisDisk'},
498 $self->{'numberOfCentralDirectories'},
499 $self->{'centralDirectorySize'},
500 $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
501 $zipfileCommentLength
502 ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
503
504 if ($zipfileCommentLength) {
505 my $zipfileComment = '';
506 $bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
507 if ( $bytesRead != $zipfileCommentLength ) {
508 return _ioError("reading zipfile comment");
509 }
510 $self->{'zipfileComment'} = $zipfileComment;
511 }
512
513 return AZ_OK;
514 }
515
516 # Seek in my file to the end, then read backwards until we find the
517 # signature of the central directory record. Leave the file positioned right
518 # before the signature. Returns AZ_OK if success.
519 sub _findEndOfCentralDirectory {
520 my $self = shift;
521 my $fh = shift;
522 my $data = '';
523 $fh->seek( 0, IO::Seekable::SEEK_END )
524 or return _ioError("seeking to end");
525
526 my $fileLength = $fh->tell();
527 if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) {
528 return _formatError("file is too short");
529 }
530
531 my $seekOffset = 0;
532 my $pos = -1;
533 for ( ; ; ) {
534 $seekOffset += 512;
535 $seekOffset = $fileLength if ( $seekOffset > $fileLength );
536 $fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
537 or return _ioError("seek failed");
538 my $bytesRead = $fh->read( $data, $seekOffset );
539 if ( $bytesRead != $seekOffset ) {
540 return _ioError("read failed");
541 }
542 $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
543 last
544 if ( $pos >= 0
545 or $seekOffset == $fileLength
546 or $seekOffset >= $Archive::Zip::ChunkSize );
547 }
548
549 if ( $pos >= 0 ) {
550 $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
551 or return _ioError("seeking to EOCD");
552 return AZ_OK;
553 }
554 else {
555 return _formatError("can't find EOCD signature");
556 }
557 }
558
559 # Used to avoid taint problems when chdir'ing.
560 # Not intended to increase security in any way; just intended to shut up the -T
561 # complaints. If your Cwd module is giving you unreliable returns from cwd()
562 # you have bigger problems than this.
563 sub _untaintDir {
564 my $dir = shift;
565 $dir =~ m/\A(.+)\z/s;
566 return $1;
567 }
568
569 sub addTree {
570 my $self = shift;
571 my $root = shift or return _error("root arg missing in call to addTree()");
572 my $dest = shift;
573 $dest = '' unless defined($dest);
574 my $pred = shift || sub { -r };
575 my @files;
576 my $startDir = _untaintDir( cwd() );
577
578 return _error( 'undef returned by _untaintDir on cwd ', cwd() )
579 unless $startDir;
580
581 # This avoids chdir'ing in Find, in a way compatible with older
582 # versions of File::Find.
583 my $wanted = sub {
584 local $main::_ = $File::Find::name;
585 my $dir = _untaintDir($File::Find::dir);
586 chdir($startDir);
587 push( @files, $File::Find::name ) if (&$pred);
588 chdir($dir);
589 };
590
591 File::Find::find( $wanted, $root );
592
593 my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
594 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
595
596 $dest = _asZipDirName( $dest, 1 ); # with trailing slash
597
598 foreach my $fileName (@files) {
599 my $isDir = -d $fileName;
600
601 # normalize, remove leading ./
602 my $archiveName = _asZipDirName( $fileName, $isDir );
603 if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
604 else { $archiveName =~ s{$pattern}{$dest} }
605 next if $archiveName =~ m{^\.?/?$}; # skip current dir
606 my $member = $isDir
607 ? $self->addDirectory( $fileName, $archiveName )
608 : $self->addFile( $fileName, $archiveName );
609 return _error("add $fileName failed in addTree()") if !$member;
610 }
611 return AZ_OK;
612 }
613
614 sub addTreeMatching {
615 my $self = shift;
616 my $root = shift
617 or return _error("root arg missing in call to addTreeMatching()");
618 my $dest = shift;
619 $dest = '' unless defined($dest);
620 my $pattern = shift
621 or return _error("pattern missing in call to addTreeMatching()");
622 my $pred = shift;
623 my $matcher =
624 $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
625 return $self->addTree( $root, $dest, $matcher );
626 }
627
628 # $zip->extractTree( $root, $dest [, $volume] );
629 #
630 # $root and $dest are Unix-style.
631 # $volume is in local FS format.
632 #
633 sub extractTree {
634 my $self = shift;
635 my $root = shift; # Zip format
636 $root = '' unless defined($root);
637 my $dest = shift; # Zip format
638 $dest = './' unless defined($dest);
639 my $volume = shift; # optional
640 my $pattern = "^\Q$root";
641 my @members = $self->membersMatching($pattern);
642
643 foreach my $member (@members) {
644 my $fileName = $member->fileName(); # in Unix format
645 $fileName =~ s{$pattern}{$dest}; # in Unix format
646 # convert to platform format:
647 $fileName = Archive::Zip::_asLocalName( $fileName, $volume );
648 my $status = $member->extractToFileNamed($fileName);
649 return $status if $status != AZ_OK;
650 }
651 return AZ_OK;
652 }
653
654 # $zip->updateMember( $memberOrName, $fileName );
655 # Returns (possibly updated) member, if any; undef on errors.
656
657 sub updateMember {
658 my $self = shift;
659 my $oldMember = shift;
660 my $fileName = shift;
661
662 if ( !defined($fileName) ) {
663 _error("updateMember(): missing fileName argument");
664 return undef;
665 }
666
667 my @newStat = stat($fileName);
668 if ( !@newStat ) {
669 _ioError("Can't stat $fileName");
670 return undef;
671 }
672
673 my $isDir = -d _;
674
675 my $memberName;
676
677 if ( ref($oldMember) ) {
678 $memberName = $oldMember->fileName();
679 }
680 else {
681 $oldMember = $self->memberNamed( $memberName = $oldMember )
682 || $self->memberNamed( $memberName =
683 _asZipDirName( $oldMember, $isDir ) );
684 }
685
686 unless ( defined($oldMember)
687 && $oldMember->lastModTime() == $newStat[9]
688 && $oldMember->isDirectory() == $isDir
689 && ( $isDir || ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
690 {
691
692 # create the new member
693 my $newMember = $isDir
694 ? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
695 : $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
696
697 unless ( defined($newMember) ) {
698 _error("creation of member $fileName failed in updateMember()");
699 return undef;
700 }
701
702 # replace old member or append new one
703 if ( defined($oldMember) ) {
704 $self->replaceMember( $oldMember, $newMember );
705 }
706 else { $self->addMember($newMember); }
707
708 return $newMember;
709 }
710
711 return $oldMember;
712 }
713
714 # $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
715 #
716 # This takes the same arguments as addTree, but first checks to see
717 # whether the file or directory already exists in the zip file.
718 #
719 # If the fourth argument $mirror is true, then delete all my members
720 # if corresponding files weren't found.
721
722 sub updateTree {
723 my $self = shift;
724 my $root = shift
725 or return _error("root arg missing in call to updateTree()");
726 my $dest = shift;
727 $dest = '' unless defined($dest);
728 $dest = _asZipDirName( $dest, 1 );
729 my $pred = shift || sub { -r };
730 my $mirror = shift;
731
732 my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
733 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
734
735 my @files;
736 my $startDir = _untaintDir( cwd() );
737
738 return _error( 'undef returned by _untaintDir on cwd ', cwd() )
739 unless $startDir;
740
741 # This avoids chdir'ing in Find, in a way compatible with older
742 # versions of File::Find.
743 my $wanted = sub {
744 local $main::_ = $File::Find::name;
745 my $dir = _untaintDir($File::Find::dir);
746 chdir($startDir);
747 push( @files, $File::Find::name ) if (&$pred);
748 chdir($dir);
749 };
750
751 File::Find::find( $wanted, $root );
752
753 # Now @files has all the files that I could potentially be adding to
754 # the zip. Only add the ones that are necessary.
755 # For each file (updated or not), add its member name to @done.
756 my %done;
757 foreach my $fileName (@files) {
758 my @newStat = stat($fileName);
759 my $isDir = -d _;
760
761 # normalize, remove leading ./
762 my $memberName = _asZipDirName( $fileName, $isDir );
763 if ( $memberName eq $rootZipName ) { $memberName = $dest }
764 else { $memberName =~ s{$pattern}{$dest} }
765 next if $memberName =~ m{^\.?/?$}; # skip current dir
766
767 $done{$memberName} = 1;
768 my $changedMember = $self->updateMember( $memberName, $fileName );
769 return _error("updateTree failed to update $fileName")
770 unless ref($changedMember);
771 }
772
773 # @done now has the archive names corresponding to all the found files.
774 # If we're mirroring, delete all those members that aren't in @done.
775 if ($mirror) {
776 foreach my $member ( $self->members() ) {
777 $self->removeMember($member)
778 unless $done{ $member->fileName() };
779 }
780 }
781
782 return AZ_OK;
783 }
784
785 1;
+131
-0
lib/Archive/Zip/BufferedFileHandle.pm less more
0 package Archive::Zip::BufferedFileHandle;
1
2 # File handle that uses a string internally and can seek
3 # This is given as a demo for getting a zip file written
4 # to a string.
5 # I probably should just use IO::Scalar instead.
6 # Ned Konz, March 2000
7
8 use strict;
9 use IO::File;
10 use Carp;
11
12 use vars qw{$VERSION};
13
14 BEGIN {
15 $VERSION = '1.18';
16 $VERSION = eval $VERSION;
17 }
18
19 sub new {
20 my $class = shift || __PACKAGE__;
21 $class = ref($class) || $class;
22 my $self = bless(
23 {
24 content => '',
25 position => 0,
26 size => 0
27 },
28 $class
29 );
30 return $self;
31 }
32
33 # Utility method to read entire file
34 sub readFromFile {
35 my $self = shift;
36 my $fileName = shift;
37 my $fh = IO::File->new( $fileName, "r" );
38 CORE::binmode($fh);
39 if ( !$fh ) {
40 Carp::carp("Can't open $fileName: $!\n");
41 return undef;
42 }
43 local $/ = undef;
44 $self->{content} = <$fh>;
45 $self->{size} = length( $self->{content} );
46 return $self;
47 }
48
49 sub contents {
50 my $self = shift;
51 if (@_) {
52 $self->{content} = shift;
53 $self->{size} = length( $self->{content} );
54 }
55 return $self->{content};
56 }
57
58 sub binmode { 1 }
59
60 sub close { 1 }
61
62 sub opened { 1 }
63
64 sub eof {
65 my $self = shift;
66 return $self->{position} >= $self->{size};
67 }
68
69 sub seek {
70 my $self = shift;
71 my $pos = shift;
72 my $whence = shift;
73
74 # SEEK_SET
75 if ( $whence == 0 ) { $self->{position} = $pos; }
76
77 # SEEK_CUR
78 elsif ( $whence == 1 ) { $self->{position} += $pos; }
79
80 # SEEK_END
81 elsif ( $whence == 2 ) { $self->{position} = $self->{size} + $pos; }
82 else { return 0; }
83
84 return 1;
85 }
86
87 sub tell { return shift->{position}; }
88
89 # Copy my data to given buffer
90 sub read {
91 my $self = shift;
92 my $buf = \( $_[0] );
93 shift;
94 my $len = shift;
95 my $offset = shift || 0;
96
97 $$buf = '' if not defined($$buf);
98 my $bytesRead =
99 ( $self->{position} + $len > $self->{size} )
100 ? ( $self->{size} - $self->{position} )
101 : $len;
102 substr( $$buf, $offset, $bytesRead ) =
103 substr( $self->{content}, $self->{position}, $bytesRead );
104 $self->{position} += $bytesRead;
105 return $bytesRead;
106 }
107
108 # Copy given buffer to me
109 sub write {
110 my $self = shift;
111 my $buf = \( $_[0] );
112 shift;
113 my $len = shift;
114 my $offset = shift || 0;
115
116 $$buf = '' if not defined($$buf);
117 my $bufLen = length($$buf);
118 my $bytesWritten =
119 ( $offset + $len > $bufLen )
120 ? $bufLen - $offset
121 : $len;
122 substr( $self->{content}, $self->{position}, $bytesWritten ) =
123 substr( $$buf, $offset, $bytesWritten );
124 $self->{size} = length( $self->{content} );
125 return $bytesWritten;
126 }
127
128 sub clearerr() { 1 }
129
130 1;
+82
-0
lib/Archive/Zip/DirectoryMember.pm less more
0 package Archive::Zip::DirectoryMember;
1
2 use strict;
3 use File::Path;
4
5 use vars qw( $VERSION @ISA );
6
7 BEGIN {
8 $VERSION = '1.18';
9 @ISA = qw( Archive::Zip::Member );
10 }
11
12 use Archive::Zip qw(
13 :ERROR_CODES
14 :UTILITY_METHODS
15 );
16
17 sub _newNamed {
18 my $class = shift;
19 my $fileName = shift; # FS name
20 my $newName = shift; # Zip name
21 $newName = _asZipDirName($fileName) unless $newName;
22 my $self = $class->new(@_);
23 $self->{'externalFileName'} = $fileName;
24 $self->fileName($newName);
25
26 if ( -e $fileName ) {
27
28 # -e does NOT do a full stat, so we need to do one now
29 if ( -d _ ) {
30 my @stat = stat(_);
31 $self->unixFileAttributes( $stat[2] );
32 my $mod_t = $stat[9];
33 if ( $^O eq 'MSWin32' and !$mod_t ) {
34 $mod_t = time();
35 }
36 $self->setLastModFileDateTimeFromUnix($mod_t);
37
38 }
39 else { # hmm.. trying to add a non-directory?
40 _error( $fileName, ' exists but is not a directory' );
41 return undef;
42 }
43 }
44 else {
45 $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
46 $self->setLastModFileDateTimeFromUnix( time() );
47 }
48 return $self;
49 }
50
51 sub externalFileName {
52 shift->{'externalFileName'};
53 }
54
55 sub isDirectory {
56 return 1;
57 }
58
59 sub extractToFileNamed {
60 my $self = shift;
61 my $name = shift; # local FS name
62 my $attribs = $self->unixFileAttributes() & 07777;
63 mkpath( $name, 0, $attribs ); # croaks on error
64 utime( $self->lastModTime(), $self->lastModTime(), $name );
65 return AZ_OK;
66 }
67
68 sub fileName {
69 my $self = shift;
70 my $newName = shift;
71 $newName =~ s{/?$}{/} if defined($newName);
72 return $self->SUPER::fileName($newName);
73 }
74
75 # So people don't get too confused. This way it looks like the problem
76 # is in their code...
77 sub contents {
78 return wantarray ? ( undef, AZ_OK ) : undef;
79 }
80
81 1;
+467
-0
lib/Archive/Zip/FAQ.pod less more
0
1 =head1 NAME
2
3
4 Archive::Zip::FAQ - Answers to a few frequently asked questions about Archive::Zip
5
6 =head1 DESCRIPTION
7
8
9 It seems that I keep answering the same questions over and over again. I
10 assume that this is because my documentation is deficient, rather than that
11 people don't read the documentation.
12
13
14 So this FAQ is an attempt to cut down on the number of personal answers I have
15 to give. At least I can now say "You I<did> read the FAQ, right?".
16
17
18 The questions are not in any particular order. The answers assume the current
19 version of Archive::Zip; some of the answers depend on newly added/fixed
20 functionality.
21
22 =head1 Install problems on RedHat 8 or 9 with Perl 5.8.0
23
24
25 B<Q:> Archive::Zip won't install on my RedHat 9 system! It's broke!
26
27
28 B<A:> This has become something of a FAQ.
29 Basically, RedHat broke some versions of Perl by setting LANG to UTF8.
30 They apparently have a fixed version out as an update.
31
32 You might try running CPAN or creating your Makefile after exporting the LANG
33 environment variable as
34
35 C<LANG=C>
36
37 L<https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
38
39
40 =head1 Why is my zip file so big?
41
42
43 B<Q:> My zip file is actually bigger than what I stored in it! Why?
44
45
46 B<A:> Some things to make sure of:
47
48 =over 4
49
50 =item Make sure that you are requesting COMPRESSION_DEFLATED if you are storing strings.
51
52
53
54
55 $member->desiredCompressionMethod( COMPRESSION_DEFLATED );
56
57
58 =item Don't make lots of little files if you can help it.
59
60
61
62 Since zip computes the compression tables for each member, small
63 members without much entropy won't compress well. Instead, if you've
64 got lots of repeated strings in your data, try to combine them into
65 one big member.
66
67
68 =item Make sure that you are requesting COMPRESSION_STORED if you are storing things that are already compressed.
69
70
71
72 If you're storing a .zip, .jpg, .mp3, or other compressed file in a zip,
73 then don't compress them again. They'll get bigger.
74
75 =back
76
77 =head1 Sample code?
78
79
80 B<Q:> Can you send me code to do (whatever)?
81
82
83 B<A:> Have you looked in the C<examples/> directory yet? It contains:
84
85 =over 4
86
87 =item examples/calcSizes.pl -- How to find out how big a Zip file will be before writing it
88
89
90
91 =item examples/copy.pl -- Copies one Zip file to another
92
93
94
95 =item examples/extract.pl -- extract file(s) from a Zip
96
97
98
99 =item examples/mailZip.pl -- make and mail a zip file
100
101
102
103 =item examples/mfh.pl -- demo for use of MockFileHandle
104
105
106
107 =item examples/readScalar.pl -- shows how to use IO::Scalar as the source of a Zip read
108
109
110
111 =item examples/selfex.pl -- a brief example of a self-extracting Zip
112
113
114
115 =item examples/unzipAll.pl -- uses Archive::Zip::Tree to unzip an entire Zip
116
117
118
119 =item examples/updateZip.pl -- shows how to read/modify/write a Zip
120
121
122
123 =item examples/updateTree.pl -- shows how to update a Zip in place
124
125
126
127 =item examples/writeScalar.pl -- shows how to use IO::Scalar as the destination of a Zip write
128
129
130
131 =item examples/writeScalar2.pl -- shows how to use IO::String as the destination of a Zip write
132
133
134
135 =item examples/zip.pl -- Constructs a Zip file
136
137
138
139 =item examples/zipcheck.pl -- One way to check a Zip file for validity
140
141
142
143 =item examples/zipinfo.pl -- Prints out information about a Zip archive file
144
145
146
147 =item examples/zipGrep.pl -- Searches for text in Zip files
148
149
150
151 =item examples/ziptest.pl -- Lists a Zip file and checks member CRCs
152
153
154
155 =item examples/ziprecent.pl -- Puts recent files into a zipfile
156
157
158
159 =item examples/ziptest.pl -- Another way to check a Zip file for validity
160
161
162
163 =back
164
165 =head1 Can't Read/modify/write same Zip file
166
167
168 B<Q:> Why can't I open a Zip file, add a member, and write it back? I get an
169 error message when I try.
170
171
172 B<A:> Because Archive::Zip doesn't (and can't, generally) read file contents into memory,
173 the original Zip file is required to stay around until the writing of the new
174 file is completed.
175
176
177 The best way to do this is to write the Zip to a temporary file and then
178 rename the temporary file to have the old name (possibly after deleting the
179 old one).
180
181
182 Archive::Zip v1.02 added the archive methods C<overwrite()> and
183 C<overwriteAs()> to do this simply and carefully.
184
185
186 See C<examples/updateZip.pl> for an example of this technique.
187
188 =head1 File creation time not set
189
190
191 B<Q:> Upon extracting files, I see that their modification (and access) times are
192 set to the time in the Zip archive. However, their creation time is not set to
193 the same time. Why?
194
195
196 B<A:> Mostly because Perl doesn't give cross-platform access to I<creation time>.
197 Indeed, many systems (like Unix) don't support such a concept.
198 However, if yours does, you can easily set it. Get the modification time from
199 the member using C<lastModTime()>.
200
201 =head1 Can't use Archive::Zip on gzip files
202
203
204 B<Q:> Can I use Archive::Zip to extract Unix gzip files?
205
206
207 B<A:> No.
208
209
210 There is a distinction between Unix gzip files, and Zip archives that
211 also can use the gzip compression.
212
213
214 Depending on the format of the gzip file, you can use L<Compress::Zlib>, or
215 L<Archive::Tar> to decompress it (and de-archive it in the case of Tar files).
216
217
218 You can unzip PKZIP/WinZip/etc/ archives using Archive::Zip (that's what
219 it's for) as long as any compressed members are compressed using
220 Deflate compression.
221
222 =head1 Add a directory/tree to a Zip
223
224
225 B<Q:> How can I add a directory (or tree) full of files to a Zip?
226
227
228 B<A:> You can use the Archive::Zip::addTree*() methods:
229
230 use Archive::Zip;
231 my $zip = Archive::Zip->new();
232 # add all readable files and directories below . as xyz/*
233 $zip->addTree( '.', 'xyz' );
234 # add all readable plain files below /abc as def/*
235 $zip->addTree( '/abc', 'def', sub { -f && -r } );
236 # add all .c files below /tmp as stuff/*
237 $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
238 # add all .o files below /tmp as stuff/* if they aren't writable
239 $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
240 # add all .so files below /tmp that are smaller than 200 bytes as stuff/*
241 $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
242 # and write them into a file
243 $zip->writeToFileNamed('xxx.zip');
244
245 =head1 Extract a directory/tree
246
247
248 B<Q:> How can I extract some (or all) files from a Zip into a different
249 directory?
250
251
252 B<A:> You can use the Archive::Zip::extractTree() method:
253 ??? ||
254
255
256 # now extract the same files into /tmpx
257 $zip->extractTree( 'stuff', '/tmpx' );
258
259 =head1 Update a directory/tree
260
261
262 B<Q:> How can I update a Zip from a directory tree, adding or replacing only
263 the newer files?
264
265
266 B<A:> You can use the Archive::Zip::updateTree() method that was added in version 1.09.
267
268 =head1 Zip times might be off by 1 second
269
270
271 B<Q:> It bothers me greatly that my file times are wrong by one second about half
272 the time. Why don't you do something about it?
273
274
275 B<A:> Get over it. This is a result of the Zip format storing times in DOS
276 format, which has a resolution of only two seconds.
277
278 =head1 Zip times don't include time zone information
279
280
281 B<Q:> My file times don't respect time zones. What gives?
282
283
284 B<A:> If this is important to you, please submit patches to read the various
285 Extra Fields that encode times with time zones. I'm just using the DOS
286 Date/Time, which doesn't have a time zone.
287
288 =head1 How do I make a self-extracting Zip
289
290
291 B<Q:> I want to make a self-extracting Zip file. Can I do this?
292
293
294 B<A:> Yes. You can write a self-extracting archive stub (that is, a version of
295 unzip) to the output filehandle that you pass to writeToFileHandle(). See
296 examples/selfex.pl for how to write a self-extracting archive.
297
298
299 However, you should understand that this will only work on one kind of
300 platform (the one for which the stub was compiled).
301
302 =head1 How can I deal with Zips with prepended garbage (i.e. from Sircam)
303
304
305 B<Q:> How can I tell if a Zip has been damaged by adding garbage to the
306 beginning or inside the file?
307
308
309 B<A:> I added code for this for the Amavis virus scanner. You can query archives
310 for their 'eocdOffset' property, which should be 0:
311
312
313 if ($zip->eocdOffset > 0)
314 { warn($zip->eocdOffset . " bytes of garbage at beginning or within Zip") }
315
316
317 When members are extracted, this offset will be used to adjust the start of
318 the member if necessary.
319
320 =head1 Can't extract Shrunk files
321
322
323 B<Q:> I'm trying to extract a file out of a Zip produced by PKZIP, and keep
324 getting this error message:
325
326
327 error: Unsupported compression combination: read 6, write 0
328
329
330 B<A:> You can't uncompress this archive member. Archive::Zip only supports uncompressed
331 members, and compressed members that are compressed using the compression
332 supported by Compress::Zlib. That means only Deflated and Stored members.
333
334
335 Your file is compressed using the Shrink format, which isn't supported by
336 Compress::Zlib.
337
338
339 You could, perhaps, use a command-line UnZip program (like the Info-Zip
340 one) to extract this.
341
342 =head1 Can't do decryption
343
344
345 B<Q:> How do I decrypt encrypted Zip members?
346
347
348 B<A:> With some other program or library. Archive::Zip doesn't support decryption,
349 and probably never will (unless I<you> write it).
350
351 =head1 How to test file integrity?
352
353
354 B<Q:> How can Archive::Zip can test the validity of a Zip file?
355
356
357 B<A:> If you try to decompress the file, the gzip streams will report errors
358 if you have garbage. Most of the time.
359
360 If you try to open the file and a central directory structure can't be
361 found, an error will be reported.
362
363 When a file is being read, if we can't find a proper PK.. signature in
364 the right places we report a format error.
365
366 If there is added garbage at the beginning of a Zip file (as inserted
367 by some viruses), you can find out about it, but Archive::Zip will ignore it,
368 and you can still use the archive. When it gets written back out the
369 added stuff will be gone.
370
371
372 There are two ready-to-use utilities in the examples directory that can
373 be used to test file integrity, or that you can use as examples
374 for your own code:
375
376 =over 4
377
378 =item examples/zipcheck.pl shows how to use an attempted extraction to test a file.
379
380
381
382 =item examples/ziptest.pl shows how to test CRCs in a file.
383
384
385
386 =back
387
388 =head1 Duplicate files in Zip?
389
390
391 B<Q:> Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this?
392
393
394 B<A:> As far as I can tell, this is not disallowed by the Zip spec. If you
395 think it's a bad idea, check for it yourself:
396
397
398 $zip->addFile($someFile, $someName) unless $zip->memberNamed($someName);
399
400
401 I can even imagine cases where this might be useful (for instance, multiple
402 versions of files).
403
404 =head1 File ownership/permissions/ACLS/etc
405
406
407 B<Q:> Why doesn't Archive::Zip deal with file ownership, ACLs, etc.?
408
409
410 B<A:> There is no standard way to represent these in the Zip file format. If
411 you want to send me code to properly handle the various extra fields that
412 have been used to represent these through the years, I'll look at it.
413
414 =head1 I can't compile but ActiveState only has an old version of Archive::Zip
415
416
417 B<Q:> I've only installed modules using ActiveState's PPM program and
418 repository. But they have a much older version of Archive::Zip than is in CPAN. Will
419 you send me a newer PPM?
420
421
422 B<A:> Probably not, unless I get lots of extra time. But there's no reason you
423 can't install the version from CPAN. Archive::Zip is pure Perl, so all you need is
424 NMAKE, which you can get for free from Microsoft (see the FAQ in the
425 ActiveState documentation for details on how to install CPAN modules).
426
427 =head1 My JPEGs (or MP3's) don't compress when I put them into Zips!
428
429
430 B<Q:> How come my JPEGs and MP3's don't compress much when I put them into Zips?
431
432
433 B<A:> Because they're already compressed.
434
435 =head1 Under Windows, things lock up/get damaged
436
437
438 B<Q:> I'm using Windows. When I try to use Archive::Zip, my machine locks up/makes
439 funny sounds/displays a BSOD/corrupts data. How can I fix this?
440
441
442 B<A:> First, try the newest version of Compress::Zlib. I know of
443 Windows-related problems prior to v1.14 of that library.
444
445
446 If that doesn't get rid of the problem, fix your computer or get rid of
447 Windows.
448
449 =head1 Zip contents in a scalar
450
451
452 B<Q:> I want to read a Zip file from (or write one to) a scalar variable instead
453 of a file. How can I do this?
454
455
456 B<A:> Use C<IO::Scalar> and the C<readFromFileHandle()> and
457 C<writeToFileHandle()> methods.
458 See C<examples/readScalar.pl> and C<examples/writeScalar.pl>.
459
460 =head1 Reading from streams
461
462
463 B<Q:> How do I read from a stream (like for the Info-Zip C<funzip> program)?
464
465
466 B<A:> This isn't currently supported, though writing to a stream is.
+64
-0
lib/Archive/Zip/FileMember.pm less more
0 package Archive::Zip::FileMember;
1
2 use strict;
3 use vars qw( $VERSION @ISA );
4
5 BEGIN {
6 $VERSION = '1.18';
7 @ISA = qw ( Archive::Zip::Member );
8 }
9
10 use Archive::Zip qw(
11 :UTILITY_METHODS
12 );
13
14 sub externalFileName {
15 shift->{'externalFileName'};
16 }
17
18 # Return true if I depend on the named file
19 sub _usesFileNamed {
20 my $self = shift;
21 my $fileName = shift;
22 my $xfn = $self->externalFileName();
23 return undef if ref($xfn);
24 return $xfn eq $fileName;
25 }
26
27 sub fh {
28 my $self = shift;
29 $self->_openFile()
30 if !defined( $self->{'fh'} ) || !$self->{'fh'}->opened();
31 return $self->{'fh'};
32 }
33
34 # opens my file handle from my file name
35 sub _openFile {
36 my $self = shift;
37 my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
38 if ( !$status ) {
39 _ioError( "Can't open", $self->externalFileName() );
40 return undef;
41 }
42 $self->{'fh'} = $fh;
43 _binmode($fh);
44 return $fh;
45 }
46
47 # Make sure I close my file handle
48 sub endRead {
49 my $self = shift;
50 undef $self->{'fh'}; # _closeFile();
51 return $self->SUPER::endRead(@_);
52 }
53
54 sub _become {
55 my $self = shift;
56 my $newClass = shift;
57 return $self if ref($self) eq $newClass;
58 delete( $self->{'externalFileName'} );
59 delete( $self->{'fh'} );
60 return $self->SUPER::_become($newClass);
61 }
62
63 1;
+950
-0
lib/Archive/Zip/Member.pm less more
0 package Archive::Zip::Member;
1
2 # A generic membet of an archive
3
4 use strict;
5 use vars qw( $VERSION @ISA );
6
7 BEGIN {
8 $VERSION = '1.18';
9 @ISA = qw( Archive::Zip );
10 }
11
12 use Archive::Zip qw(
13 :CONSTANTS
14 :MISC_CONSTANTS
15 :ERROR_CODES
16 :PKZIP_CONSTANTS
17 :UTILITY_METHODS
18 );
19
20 use Time::Local ();
21 use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
22 use File::Path;
23 use File::Basename;
24
25 use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
26 use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
27 use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
28 use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
29
30 # Unix perms for default creation of files/dirs.
31 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
32 use constant DEFAULT_FILE_PERMISSIONS => 0100666;
33 use constant DIRECTORY_ATTRIB => 040000;
34 use constant FILE_ATTRIB => 0100000;
35
36 # Returns self if successful, else undef
37 # Assumes that fh is positioned at beginning of central directory file header.
38 # Leaves fh positioned immediately after file header or EOCD signature.
39 sub _newFromZipFile {
40 my $class = shift;
41 my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
42 return $self;
43 }
44
45 sub newFromString {
46 my $class = shift;
47 my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
48 return $self;
49 }
50
51 sub newFromFile {
52 my $class = shift;
53 my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
54 return $self;
55 }
56
57 sub newDirectoryNamed {
58 my $class = shift;
59 my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
60 return $self;
61 }
62
63 sub new {
64 my $class = shift;
65 my $self = {
66 'lastModFileDateTime' => 0,
67 'fileAttributeFormat' => FA_UNIX,
68 'versionMadeBy' => 20,
69 'versionNeededToExtract' => 20,
70 'bitFlag' => 0,
71 'compressionMethod' => COMPRESSION_STORED,
72 'desiredCompressionMethod' => COMPRESSION_STORED,
73 'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
74 'internalFileAttributes' => 0,
75 'externalFileAttributes' => 0, # set later
76 'fileName' => '',
77 'cdExtraField' => '',
78 'localExtraField' => '',
79 'fileComment' => '',
80 'crc32' => 0,
81 'compressedSize' => 0,
82 'uncompressedSize' => 0,
83 @_
84 };
85 bless( $self, $class );
86 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
87 return $self;
88 }
89
90 sub _becomeDirectoryIfNecessary {
91 my $self = shift;
92 $self->_become(DIRECTORYMEMBERCLASS)
93 if $self->isDirectory();
94 return $self;
95 }
96
97 # Morph into given class (do whatever cleanup I need to do)
98 sub _become {
99 return bless( $_[0], $_[1] );
100 }
101
102 sub versionMadeBy {
103 shift->{'versionMadeBy'};
104 }
105
106 sub fileAttributeFormat {
107 ( $#_ > 0 )
108 ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
109 : $_[0]->{'fileAttributeFormat'};
110 }
111
112 sub versionNeededToExtract {
113 shift->{'versionNeededToExtract'};
114 }
115
116 sub bitFlag {
117 shift->{'bitFlag'};
118 }
119
120 sub compressionMethod {
121 shift->{'compressionMethod'};
122 }
123
124 sub desiredCompressionMethod {
125 my $self = shift;
126 my $newDesiredCompressionMethod = shift;
127 my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
128 if ( defined($newDesiredCompressionMethod) ) {
129 $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
130 if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) {
131 $self->{'desiredCompressionLevel'} = 0;
132 }
133 elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
134 $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
135 }
136 }
137 return $oldDesiredCompressionMethod;
138 }
139
140 sub desiredCompressionLevel {
141 my $self = shift;
142 my $newDesiredCompressionLevel = shift;
143 my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
144 if ( defined($newDesiredCompressionLevel) ) {
145 $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
146 $self->{'desiredCompressionMethod'} = (
147 $newDesiredCompressionLevel
148 ? COMPRESSION_DEFLATED
149 : COMPRESSION_STORED
150 );
151 }
152 return $oldDesiredCompressionLevel;
153 }
154
155 sub fileName {
156 my $self = shift;
157 my $newName = shift;
158 if ($newName) {
159 $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
160 $self->{'fileName'} = $newName;
161 }
162 return $self->{'fileName'};
163 }
164
165 sub lastModFileDateTime {
166 my $modTime = shift->{'lastModFileDateTime'};
167 $modTime =~ m/^(\d+)$/; # untaint
168 return $1;
169 }
170
171 sub lastModTime {
172 my $self = shift;
173 return _dosToUnixTime( $self->lastModFileDateTime() );
174 }
175
176 sub setLastModFileDateTimeFromUnix {
177 my $self = shift;
178 my $time_t = shift;
179 $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
180 }
181
182 sub internalFileAttributes {
183 shift->{'internalFileAttributes'};
184 }
185
186 sub externalFileAttributes {
187 shift->{'externalFileAttributes'};
188 }
189
190 # Convert UNIX permissions into proper value for zip file
191 # NOT A METHOD!
192 sub _mapPermissionsFromUnix {
193 my $perms = shift;
194 return $perms << 16;
195
196 # TODO: map MS-DOS perms too (RHSA?)
197 }
198
199 # Convert ZIP permissions into Unix ones
200 #
201 # This was taken from Info-ZIP group's portable UnZip
202 # zipfile-extraction program, version 5.50.
203 # http://www.info-zip.org/pub/infozip/
204 #
205 # See the mapattr() function in unix/unix.c
206 # See the attribute format constants in unzpriv.h
207 #
208 # XXX Note that there's one situation that isn't implemented
209 # yet that depends on the "extra field."
210 sub _mapPermissionsToUnix {
211 my $self = shift;
212
213 my $format = $self->{'fileAttributeFormat'};
214 my $attribs = $self->{'externalFileAttributes'};
215
216 my $mode = 0;
217
218 if ( $format == FA_AMIGA ) {
219 $attribs = $attribs >> 17 & 7; # Amiga RWE bits
220 $mode = $attribs << 6 | $attribs << 3 | $attribs;
221 return $mode;
222 }
223
224 if ( $format == FA_THEOS ) {
225 $attribs &= 0xF1FFFFFF;
226 if ( ( $attribs & 0xF0000000 ) != 0x40000000 ) {
227 $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
228 }
229 else {
230 $attribs &= 0x41FFFFFF; # leave directory bit as set
231 }
232 }
233
234 if ( $format == FA_UNIX
235 || $format == FA_VAX_VMS
236 || $format == FA_ACORN
237 || $format == FA_ATARI_ST
238 || $format == FA_BEOS
239 || $format == FA_QDOS
240 || $format == FA_TANDEM )
241 {
242 $mode = $attribs >> 16;
243 return $mode if $mode != 0 or not $self->localExtraField;
244
245 # warn("local extra field is: ", $self->localExtraField, "\n");
246
247 # XXX This condition is not implemented
248 # I'm just including the comments from the info-zip section for now.
249
250 # Some (non-Info-ZIP) implementations of Zip for Unix and
251 # VMS (and probably others ??) leave 0 in the upper 16-bit
252 # part of the external_file_attributes field. Instead, they
253 # store file permission attributes in some extra field.
254 # As a work-around, we search for the presence of one of
255 # these extra fields and fall back to the MSDOS compatible
256 # part of external_file_attributes if one of the known
257 # e.f. types has been detected.
258 # Later, we might implement extraction of the permission
259 # bits from the VMS extra field. But for now, the work-around
260 # should be sufficient to provide "readable" extracted files.
261 # (For ASI Unix e.f., an experimental remap from the e.f.
262 # mode value IS already provided!)
263 }
264
265 # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
266 # Unix attributes in the upper 16 bits of the external attributes
267 # field, just like Info-ZIP's Zip for Unix. We try to use that
268 # value, after a check for consistency with the MSDOS attribute
269 # bits (see below).
270 if ( $format == FA_MSDOS ) {
271 $mode = $attribs >> 16;
272 }
273
274 # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
275 $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
276
277 # keep previous $mode setting when its "owner"
278 # part appears to be consistent with DOS attribute flags!
279 return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
280 $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
281 return $mode;
282 }
283
284 sub unixFileAttributes {
285 my $self = shift;
286 my $oldPerms = $self->_mapPermissionsToUnix();
287 if (@_) {
288 my $perms = shift;
289 if ( $self->isDirectory() ) {
290 $perms &= ~FILE_ATTRIB;
291 $perms |= DIRECTORY_ATTRIB;
292 }
293 else {
294 $perms &= ~DIRECTORY_ATTRIB;
295 $perms |= FILE_ATTRIB;
296 }
297 $self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
298 }
299 return $oldPerms;
300 }
301
302 sub localExtraField {
303 ( $#_ > 0 )
304 ? ( $_[0]->{'localExtraField'} = $_[1] )
305 : $_[0]->{'localExtraField'};
306 }
307
308 sub cdExtraField {
309 ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
310 }
311
312 sub extraFields {
313 my $self = shift;
314 return $self->localExtraField() . $self->cdExtraField();
315 }
316
317 sub fileComment {
318 ( $#_ > 0 )
319 ? ( $_[0]->{'fileComment'} = pack( 'C0a*', $_[1] ) )
320 : $_[0]->{'fileComment'};
321 }
322
323 sub hasDataDescriptor {
324 my $self = shift;
325 if (@_) {
326 my $shouldHave = shift;
327 if ($shouldHave) {
328 $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK;
329 }
330 else {
331 $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
332 }
333 }
334 return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
335 }
336
337 sub crc32 {
338 shift->{'crc32'};
339 }
340
341 sub crc32String {
342 sprintf( "%08x", shift->{'crc32'} );
343 }
344
345 sub compressedSize {
346 shift->{'compressedSize'};
347 }
348
349 sub uncompressedSize {
350 shift->{'uncompressedSize'};
351 }
352
353 sub isEncrypted {
354 shift->bitFlag() & GPBF_ENCRYPTED_MASK;
355 }
356
357 sub isTextFile {
358 my $self = shift;
359 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
360 if (@_) {
361 my $flag = shift;
362 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
363 $self->{'internalFileAttributes'} |=
364 ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
365 }
366 return $bit == IFA_TEXT_FILE;
367 }
368
369 sub isBinaryFile {
370 my $self = shift;
371 my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
372 if (@_) {
373 my $flag = shift;
374 $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
375 $self->{'internalFileAttributes'} |=
376 ( $flag ? IFA_BINARY_FILE: IFA_TEXT_FILE );
377 }
378 return $bit == IFA_BINARY_FILE;
379 }
380
381 sub extractToFileNamed {
382 my $self = shift;
383 my $name = shift; # local FS name
384 return _error("encryption unsupported") if $self->isEncrypted();
385 mkpath( dirname($name) ); # croaks on error
386 my ( $status, $fh ) = _newFileHandle( $name, 'w' );
387 return _ioError("Can't open file $name for write") unless $status;
388 my $retval = $self->extractToFileHandle($fh);
389 $fh->close();
390 utime( $self->lastModTime(), $self->lastModTime(), $name );
391 return $retval;
392 }
393
394 sub isDirectory {
395 return 0;
396 }
397
398 sub externalFileName {
399 return undef;
400 }
401
402 # The following are used when copying data
403 sub _writeOffset {
404 shift->{'writeOffset'};
405 }
406
407 sub _readOffset {
408 shift->{'readOffset'};
409 }
410
411 sub writeLocalHeaderRelativeOffset {
412 shift->{'writeLocalHeaderRelativeOffset'};
413 }
414
415 sub wasWritten { shift->{'wasWritten'} }
416
417 sub _dataEnded {
418 shift->{'dataEnded'};
419 }
420
421 sub _readDataRemaining {
422 shift->{'readDataRemaining'};
423 }
424
425 sub _inflater {
426 shift->{'inflater'};
427 }
428
429 sub _deflater {
430 shift->{'deflater'};
431 }
432
433 # Return the total size of my local header
434 sub _localHeaderSize {
435 my $self = shift;
436 return SIGNATURE_LENGTH + LOCAL_FILE_HEADER_LENGTH +
437 length( $self->fileName() ) + length( $self->localExtraField() );
438 }
439
440 # Return the total size of my CD header
441 sub _centralDirectoryHeaderSize {
442 my $self = shift;
443 return SIGNATURE_LENGTH + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH +
444 length( $self->fileName() ) + length( $self->cdExtraField() ) +
445 length( $self->fileComment() );
446 }
447
448 # DOS date/time format
449 # 0-4 (5) Second divided by 2
450 # 5-10 (6) Minute (0-59)
451 # 11-15 (5) Hour (0-23 on a 24-hour clock)
452 # 16-20 (5) Day of the month (1-31)
453 # 21-24 (4) Month (1 = January, 2 = February, etc.)
454 # 25-31 (7) Year offset from 1980 (add 1980 to get actual year)
455
456 # Convert DOS date/time format to unix time_t format
457 # NOT AN OBJECT METHOD!
458 sub _dosToUnixTime {
459 my $dt = shift;
460 return time() unless defined($dt);
461
462 my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
463 my $mon = ( ( $dt >> 21 ) & 0x0f ) - 1;
464 my $mday = ( ( $dt >> 16 ) & 0x1f );
465
466 my $hour = ( ( $dt >> 11 ) & 0x1f );
467 my $min = ( ( $dt >> 5 ) & 0x3f );
468 my $sec = ( ( $dt << 1 ) & 0x3e );
469
470 # catch errors
471 my $time_t =
472 eval { Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year ); };
473 return time() if ($@);
474 return $time_t;
475 }
476
477 # Note, this isn't exactly UTC 1980, it's 1980 + 12 hours and 1
478 # minute so that nothing timezoney can muck us up.
479 my $safe_epoch = 315576060;
480
481 # convert a unix time to DOS date/time
482 # NOT AN OBJECT METHOD!
483 sub _unixToDosTime {
484 my $time_t = shift;
485 unless ($time_t) {
486 _error("Tried to add member with zero or undef value for time");
487 $time_t = $safe_epoch;
488 }
489 if ( $time_t < $safe_epoch ) {
490 _ioError("Unsupported date before 1980 encountered, moving to 1980");
491 $time_t = $safe_epoch;
492 }
493 my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
494 my $dt = 0;
495 $dt += ( $sec >> 1 );
496 $dt += ( $min << 5 );
497 $dt += ( $hour << 11 );
498 $dt += ( $mday << 16 );
499 $dt += ( ( $mon + 1 ) << 21 );
500 $dt += ( ( $year - 80 ) << 25 );
501 return $dt;
502 }
503
504 # Write my local header to a file handle.
505 # Stores the offset to the start of the header in my
506 # writeLocalHeaderRelativeOffset member.
507 # Returns AZ_OK on success.
508 sub _writeLocalFileHeader {
509 my $self = shift;
510 my $fh = shift;
511
512 my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
513 $fh->print($signatureData)
514 or return _ioError("writing local header signature");
515
516 my $header = pack(
517 LOCAL_FILE_HEADER_FORMAT,
518 $self->versionNeededToExtract(),
519 $self->bitFlag(),
520 $self->desiredCompressionMethod(),
521 $self->lastModFileDateTime(),
522 $self->crc32(),
523 $self->compressedSize(), # may need to be re-written later
524 $self->uncompressedSize(),
525 length( $self->fileName() ),
526 length( $self->localExtraField() )
527 );
528
529 $fh->print($header) or return _ioError("writing local header");
530 if ( $self->fileName() ) {
531 $fh->print( $self->fileName() )
532 or return _ioError("writing local header filename");
533 }
534 if ( $self->localExtraField() ) {
535 $fh->print( $self->localExtraField() )
536 or return _ioError("writing local extra field");
537 }
538
539 return AZ_OK;
540 }
541
542 sub _writeCentralDirectoryFileHeader {
543 my $self = shift;
544 my $fh = shift;
545
546 my $sigData =
547 pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
548 $fh->print($sigData)
549 or return _ioError("writing central directory header signature");
550
551 my $fileNameLength = length( $self->fileName() );
552 my $extraFieldLength = length( $self->cdExtraField() );
553 my $fileCommentLength = length( $self->fileComment() );
554
555 my $header = pack(
556 CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
557 $self->versionMadeBy(),
558 $self->fileAttributeFormat(),
559 $self->versionNeededToExtract(),
560 $self->bitFlag(),
561 $self->desiredCompressionMethod(),
562 $self->lastModFileDateTime(),
563 $self->crc32(), # these three fields should have been updated
564 $self->_writeOffset(), # by writing the data stream out
565 $self->uncompressedSize(), #
566 $fileNameLength,
567 $extraFieldLength,
568 $fileCommentLength,
569 0, # {'diskNumberStart'},
570 $self->internalFileAttributes(),
571 $self->externalFileAttributes(),
572 $self->writeLocalHeaderRelativeOffset()
573 );
574
575 $fh->print($header)
576 or return _ioError("writing central directory header");
577 if ($fileNameLength) {
578 $fh->print( $self->fileName() )
579 or return _ioError("writing central directory header signature");
580 }
581 if ($extraFieldLength) {
582 $fh->print( $self->cdExtraField() )
583 or return _ioError("writing central directory extra field");
584 }
585 if ($fileCommentLength) {
586 $fh->print( $self->fileComment() )
587 or return _ioError("writing central directory file comment");
588 }
589
590 return AZ_OK;
591 }
592
593 # This writes a data descriptor to the given file handle.
594 # Assumes that crc32, writeOffset, and uncompressedSize are
595 # set correctly (they should be after a write).
596 # Further, the local file header should have the
597 # GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
598 sub _writeDataDescriptor {
599 my $self = shift;
600 my $fh = shift;
601 my $header = pack(
602 SIGNATURE_FORMAT . DATA_DESCRIPTOR_FORMAT,
603 DATA_DESCRIPTOR_SIGNATURE,
604 $self->crc32(),
605 $self->_writeOffset(), # compressed size
606 $self->uncompressedSize()
607 );
608
609 $fh->print($header)
610 or return _ioError("writing data descriptor");
611 return AZ_OK;
612 }
613
614 # Re-writes the local file header with new crc32 and compressedSize fields.
615 # To be called after writing the data stream.
616 # Assumes that filename and extraField sizes didn't change since last written.
617 sub _refreshLocalFileHeader {
618 my $self = shift;
619 my $fh = shift;
620
621 my $here = $fh->tell();
622 $fh->seek( $self->writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
623 IO::Seekable::SEEK_SET )
624 or return _ioError("seeking to rewrite local header");
625
626 my $header = pack(
627 LOCAL_FILE_HEADER_FORMAT,
628 $self->versionNeededToExtract(),
629 $self->bitFlag(),
630 $self->desiredCompressionMethod(),
631 $self->lastModFileDateTime(),
632 $self->crc32(),
633 $self->_writeOffset(), # compressed size
634 $self->uncompressedSize(),
635 length( $self->fileName() ),
636 length( $self->localExtraField() )
637 );
638
639 $fh->print($header)
640 or return _ioError("re-writing local header");
641 $fh->seek( $here, IO::Seekable::SEEK_SET )
642 or return _ioError("seeking after rewrite of local header");
643
644 return AZ_OK;
645 }
646
647 sub readChunk {
648 my ( $self, $chunkSize ) = @_;
649
650 if ( $self->readIsDone() ) {
651 $self->endRead();
652 my $dummy = '';
653 return ( \$dummy, AZ_STREAM_END );
654 }
655
656 $chunkSize = $Archive::Zip::ChunkSize if not defined($chunkSize);
657 $chunkSize = $self->_readDataRemaining()
658 if $chunkSize > $self->_readDataRemaining();
659
660 my $buffer = '';
661 my $outputRef;
662 my ( $bytesRead, $status ) = $self->_readRawChunk( \$buffer, $chunkSize );
663 return ( \$buffer, $status ) unless $status == AZ_OK;
664
665 $self->{'readDataRemaining'} -= $bytesRead;
666 $self->{'readOffset'} += $bytesRead;
667
668 if ( $self->compressionMethod() == COMPRESSION_STORED ) {
669 $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
670 }
671
672 ( $outputRef, $status ) = &{ $self->{'chunkHandler'} }( $self, \$buffer );
673 $self->{'writeOffset'} += length($$outputRef);
674
675 $self->endRead()
676 if $self->readIsDone();
677
678 return ( $outputRef, $status );
679 }
680
681 # Read the next raw chunk of my data. Subclasses MUST implement.
682 # my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
683 sub _readRawChunk {
684 my $self = shift;
685 return $self->_subclassResponsibility();
686 }
687
688 # A place holder to catch rewindData errors if someone ignores
689 # the error code.
690 sub _noChunk {
691 my $self = shift;
692 return ( \undef, _error("trying to copy chunk when init failed") );
693 }
694
695 # Basically a no-op so that I can have a consistent interface.
696 # ( $outputRef, $status) = $self->_copyChunk( \$buffer );
697 sub _copyChunk {
698 my ( $self, $dataRef ) = @_;
699 return ( $dataRef, AZ_OK );
700 }
701
702 # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
703 sub _deflateChunk {
704 my ( $self, $buffer ) = @_;
705 my ( $out, $status ) = $self->_deflater()->deflate($buffer);
706
707 if ( $self->_readDataRemaining() == 0 ) {
708 my $extraOutput;
709 ( $extraOutput, $status ) = $self->_deflater()->flush();
710 $out .= $extraOutput;
711 $self->endRead();
712 return ( \$out, AZ_STREAM_END );
713 }
714 elsif ( $status == Z_OK ) {
715 return ( \$out, AZ_OK );
716 }
717 else {
718 $self->endRead();
719 my $retval = _error( 'deflate error', $status );
720 my $dummy = '';
721 return ( \$dummy, $retval );
722 }
723 }
724
725 # ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
726 sub _inflateChunk {
727 my ( $self, $buffer ) = @_;
728 my ( $out, $status ) = $self->_inflater()->inflate($buffer);
729 my $retval;
730 $self->endRead() unless $status == Z_OK;
731 if ( $status == Z_OK || $status == Z_STREAM_END ) {
732 $retval = ( $status == Z_STREAM_END ) ? AZ_STREAM_END: AZ_OK;
733 return ( \$out, $retval );
734 }
735 else {
736 $retval = _error( 'inflate error', $status );
737 my $dummy = '';
738 return ( \$dummy, $retval );
739 }
740 }
741
742 sub rewindData {
743 my $self = shift;
744 my $status;
745
746 # set to trap init errors
747 $self->{'chunkHandler'} = $self->can('_noChunk');
748
749 # Work around WinZip bug with 0-length DEFLATED files
750 $self->desiredCompressionMethod(COMPRESSION_STORED)
751 if $self->uncompressedSize() == 0;
752
753 # assume that we're going to read the whole file, and compute the CRC anew.
754 $self->{'crc32'} = 0
755 if ( $self->compressionMethod() == COMPRESSION_STORED );
756
757 # These are the only combinations of methods we deal with right now.
758 if ( $self->compressionMethod() == COMPRESSION_STORED
759 and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
760 {
761 ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
762 '-Level' => $self->desiredCompressionLevel(),
763 '-WindowBits' => -MAX_WBITS(), # necessary magic
764 '-Bufsize' => $Archive::Zip::ChunkSize,
765 @_
766 ); # pass additional options
767 return _error( 'deflateInit error:', $status )
768 unless $status == Z_OK;
769 $self->{'chunkHandler'} = $self->can('_deflateChunk');
770 }
771 elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
772 and $self->desiredCompressionMethod() == COMPRESSION_STORED )
773 {
774 ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
775 '-WindowBits' => -MAX_WBITS(), # necessary magic
776 '-Bufsize' => $Archive::Zip::ChunkSize,
777 @_
778 ); # pass additional options
779 return _error( 'inflateInit error:', $status )
780 unless $status == Z_OK;
781 $self->{'chunkHandler'} = $self->can('_inflateChunk');
782 }
783 elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() ) {
784 $self->{'chunkHandler'} = $self->can('_copyChunk');
785 }
786 else {
787 return _error(
788 sprintf(
789 "Unsupported compression combination: read %d, write %d",
790 $self->compressionMethod(),
791 $self->desiredCompressionMethod()
792 )
793 );
794 }
795
796 $self->{'readDataRemaining'} =
797 ( $self->compressionMethod() == COMPRESSION_STORED )
798 ? $self->uncompressedSize()
799 : $self->compressedSize();
800 $self->{'dataEnded'} = 0;
801 $self->{'readOffset'} = 0;
802
803 return AZ_OK;
804 }
805
806 sub endRead {
807 my $self = shift;
808 delete $self->{'inflater'};
809 delete $self->{'deflater'};
810 $self->{'dataEnded'} = 1;
811 $self->{'readDataRemaining'} = 0;
812 return AZ_OK;
813 }
814
815 sub readIsDone {
816 my $self = shift;
817 return ( $self->_dataEnded() or !$self->_readDataRemaining() );
818 }
819
820 sub contents {
821 my $self = shift;
822 my $newContents = shift;
823
824 if ( defined($newContents) ) {
825
826 # change our type and call the subclass contents method.
827 $self->_become(STRINGMEMBERCLASS);
828 return $self->contents( pack( 'C0a*', $newContents ) )
829 ; # in case of Unicode
830 }
831 else {
832 my $oldCompression =
833 $self->desiredCompressionMethod(COMPRESSION_STORED);
834 my $status = $self->rewindData(@_);
835 if ( $status != AZ_OK ) {
836 $self->endRead();
837 return $status;
838 }
839 my $retval = '';
840 while ( $status == AZ_OK ) {
841 my $ref;
842 ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
843
844 # did we get it in one chunk?
845 if ( length($$ref) == $self->uncompressedSize() ) {
846 $retval = $$ref;
847 }
848 else { $retval .= $$ref }
849 }
850 $self->desiredCompressionMethod($oldCompression);
851 $self->endRead();
852 $status = AZ_OK if $status == AZ_STREAM_END;
853 $retval = undef unless $status == AZ_OK;
854 return wantarray ? ( $retval, $status ) : $retval;
855 }
856 }
857
858 sub extractToFileHandle {
859 my $self = shift;
860 return _error("encryption unsupported") if $self->isEncrypted();
861 my $fh = shift;
862 _binmode($fh);
863 my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
864 my $status = $self->rewindData(@_);
865 $status = $self->_writeData($fh) if $status == AZ_OK;
866 $self->desiredCompressionMethod($oldCompression);
867 $self->endRead();
868 return $status;
869 }
870
871 # write local header and data stream to file handle
872 sub _writeToFileHandle {
873 my $self = shift;
874 my $fh = shift;
875 my $fhIsSeekable = shift;
876 my $offset = shift;
877
878 return _error("no member name given for $self")
879 unless $self->fileName();
880
881 $self->{'writeLocalHeaderRelativeOffset'} = $offset;
882 $self->{'wasWritten'} = 0;
883
884 # Determine if I need to write a data descriptor
885 # I need to do this if I can't refresh the header
886 # and I don't know compressed size or crc32 fields.
887 my $headerFieldsUnknown = (
888 ( $self->uncompressedSize() > 0 )
889 and ($self->compressionMethod() == COMPRESSION_STORED
890 or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
891 );
892
893 my $shouldWriteDataDescriptor =
894 ( $headerFieldsUnknown and not $fhIsSeekable );
895
896 $self->hasDataDescriptor(1)
897 if ($shouldWriteDataDescriptor);
898
899 $self->{'writeOffset'} = 0;
900
901 my $status = $self->rewindData();
902 ( $status = $self->_writeLocalFileHeader($fh) )
903 if $status == AZ_OK;
904 ( $status = $self->_writeData($fh) )
905 if $status == AZ_OK;
906 if ( $status == AZ_OK ) {
907 $self->{'wasWritten'} = 1;
908 if ( $self->hasDataDescriptor() ) {
909 $status = $self->_writeDataDescriptor($fh);
910 }
911 elsif ($headerFieldsUnknown) {
912 $status = $self->_refreshLocalFileHeader($fh);
913 }
914 }
915
916 return $status;
917 }
918
919 # Copy my (possibly compressed) data to given file handle.
920 # Returns C<AZ_OK> on success
921 sub _writeData {
922 my $self = shift;
923 my $writeFh = shift;
924
925 return AZ_OK if ( $self->uncompressedSize() == 0 );
926 my $status;
927 my $chunkSize = $Archive::Zip::ChunkSize;
928 while ( $self->_readDataRemaining() > 0 ) {
929 my $outRef;
930 ( $outRef, $status ) = $self->readChunk($chunkSize);
931 return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
932
933 if ( length($$outRef) > 0 ) {
934 $writeFh->print($$outRef)
935 or return _ioError("write error during copy");
936 }
937
938 last if $status == AZ_STREAM_END;
939 }
940 $self->{'compressedSize'} = $self->_writeOffset();
941 return AZ_OK;
942 }
943
944 # Return true if I depend on the named file
945 sub _usesFileNamed {
946 return 0;
947 }
948
949 1;
+280
-0
lib/Archive/Zip/MemberRead.pm less more
0 package Archive::Zip::MemberRead;
1
2 # Copyright (c) 2002 Sreeji K. Das. All rights reserved. This program is free
3 # software; you can redistribute it and/or modify it under the same terms
4 # as Perl itself.
5
6 =head1 NAME
7
8 Archive::Zip::MemberRead - A wrapper that lets you read Zip archive members as if they were files.
9
10 =cut
11
12 =head1 SYNOPSIS
13
14 use Archive::Zip;
15 use Archive::Zip::MemberRead;
16 $zip = new Archive::Zip("file.zip");
17 $fh = new Archive::Zip::MemberRead($zip, "subdir/abc.txt");
18 while (defined($line = $fh->getline()))
19 {
20 print $fh->input_line_number . "#: $line\n";
21 }
22
23 $read = $fh->read($buffer, 32*1024);
24 print "Read $read bytes as :$buffer:\n";
25
26 =head1 DESCRIPTION
27
28 The Archive::Zip::MemberRead module lets you read Zip archive member data
29 just like you read data from files.
30
31 =head1 METHODS
32
33 =over 4
34
35 =cut
36
37 use strict;
38 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
39
40 use vars qw{$VERSION};
41
42 BEGIN {
43 $VERSION = '1.18';
44 $VERSION = eval $VERSION;
45 }
46
47 =item Archive::Zip::Member::readFileHandle()
48
49 You can get a C<Archive::Zip::MemberRead> from an archive member by
50 calling C<readFileHandle()>:
51
52 my $member = $zip->memberNamed('abc/def.c');
53 my $fh = $member->readFileHandle();
54 while (defined($line = $fh->getline()))
55 {
56 # ...
57 }
58 $fh->close();
59
60 =cut
61
62 sub Archive::Zip::Member::readFileHandle {
63 return Archive::Zip::MemberRead->new( shift() );
64 }
65
66 =item Archive::Zip::MemberRead->new($zip, $fileName)
67
68 =item Archive::Zip::MemberRead->new($zip, $member)
69
70 =item Archive::Zip::MemberRead->new($member)
71
72 Construct a new Archive::Zip::MemberRead on the specified member.
73
74 my $fh = Archive::Zip::MemberRead->new($zip, 'fred.c')
75
76 =cut
77
78 sub new {
79 my ( $class, $zip, $file ) = @_;
80 my ( $self, $member );
81
82 if ( $zip && $file ) # zip and filename, or zip and member
83 {
84 $member = ref($file) ? $file : $zip->memberNamed($file);
85 }
86 elsif ( $zip && !$file && ref($zip) ) # just member
87 {
88 $member = $zip;
89 }
90 else {
91 die(
92 'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member'
93 );
94 }
95
96 $self = {};
97 bless( $self, $class );
98 $self->set_member($member);
99 return $self;
100 }
101
102 sub set_member {
103 my ( $self, $member ) = @_;
104
105 $self->{member} = $member;
106 $self->set_compression(COMPRESSION_STORED);
107 $self->rewind();
108 }
109
110 sub set_compression {
111 my ( $self, $compression ) = @_;
112 $self->{member}->desiredCompressionMethod($compression) if $self->{member};
113 }
114
115 =item rewind()
116
117 Rewinds an C<Archive::Zip::MemberRead> so that you can read from it again
118 starting at the beginning.
119
120 =cut
121
122 sub rewind {
123 my $self = shift;
124
125 $self->_reset_vars();
126 $self->{member}->rewindData() if $self->{member};
127 }
128
129 sub _reset_vars {
130 my $self = shift;
131 $self->{lines} = [];
132 $self->{partial} = 0;
133 $self->{line_no} = 0;
134 }
135
136 =item input_line_number()
137
138 Returns the current line number, but only if you're using C<getline()>.
139 Using C<read()> will not update the line number.
140
141 =cut
142
143 sub input_line_number {
144 my $self = shift;
145 return $self->{line_no};
146 }
147
148 =item close()
149
150 Closes the given file handle.
151
152 =cut
153
154 sub close {
155 my $self = shift;
156
157 $self->_reset_vars();
158 $self->{member}->endRead();
159 }
160
161 =item buffer_size([ $size ])
162
163 Gets or sets the buffer size used for reads.
164 Default is the chunk size used by Archive::Zip.
165
166 =cut
167
168 sub buffer_size {
169 my ( $self, $size ) = @_;
170
171 if ( !$size ) {
172 return $self->{chunkSize} || Archive::Zip::chunkSize();
173 }
174 else {
175 $self->{chunkSize} = $size;
176 }
177 }
178
179 =item getline()
180
181 Returns the next line from the currently open member.
182 Makes sense only for text files.
183 A read error is considered fatal enough to die.
184 Returns undef on eof. All subsequent calls would return undef,
185 unless a rewind() is called.
186 Note: The line returned has the newline removed.
187
188 =cut
189
190 # $self->{partial} flags whether the last line in the buffer is partial or not.
191 # A line is treated as partial if it does not ends with \n
192 sub getline {
193 my $self = shift;
194 my ( $temp, $status, $size, $buffer, @lines );
195
196 $status = AZ_OK;
197 $size = $self->buffer_size();
198 $temp = \$status;
199 while ( $$temp !~ /\n/ && $status != AZ_STREAM_END ) {
200 ( $temp, $status ) = $self->{member}->readChunk($size);
201 if ( $status != AZ_OK && $status != AZ_STREAM_END ) {
202 die "ERROR: Error reading chunk from archive - $status\n";
203 }
204
205 $buffer .= $$temp;
206 }
207
208 @lines = split( /\n/, $buffer );
209 $self->{line_no}++;
210 if ( $#lines == -1 ) {
211 return ( $#{ $self->{lines} } == -1 )
212 ? undef
213 : shift( @{ $self->{lines} } );
214 }
215
216 $self->{lines}->[ $#{ $self->{lines} } ] .= shift(@lines)
217 if $self->{partial};
218
219 splice( @{ $self->{lines} }, @{ $self->{lines} }, 0, @lines );
220 $self->{partial} = !( $buffer =~ /\n$/ );
221 return shift( @{ $self->{lines} } );
222 }
223
224 =item read($buffer, $num_bytes_to_read)
225
226 Simulates a normal C<read()> system call.
227 Returns the no. of bytes read. C<undef> on error, 0 on eof, I<e.g.>:
228
229 $fh = new Archive::Zip::MemberRead($zip, "sreeji/secrets.bin");
230 while (1)
231 {
232 $read = $fh->read($buffer, 1024);
233 die "FATAL ERROR reading my secrets !\n" if (!defined($read));
234 last if (!$read);
235 # Do processing.
236 ....
237 }
238
239 =cut
240
241 #
242 # All these $_ are required to emulate read().
243 #
244 sub read {
245 my $self = $_[0];
246 my $size = $_[2];
247 my ( $temp, $status, $ret );
248
249 ( $temp, $status ) = $self->{member}->readChunk($size);
250 if ( $status != AZ_OK && $status != AZ_STREAM_END ) {
251 $_[1] = undef;
252 $ret = undef;
253 }
254 else {
255 $_[1] = $$temp;
256 $ret = length($$temp);
257 }
258 return $ret;
259 }
260
261 1;
262
263 =back
264
265 =head1 AUTHOR
266
267 Sreeji K. Das, <sreeji_k@yahoo.com>
268 See L<Archive::Zip> by Ned Konz without which this module does not make
269 any sense!
270
271 Minor mods by Ned Konz.
272
273 =head1 COPYRIGHT
274
275 Copyright (c) 2002 Sreeji K. Das. All rights reserved. This program is free
276 software; you can redistribute it and/or modify it under the same terms
277 as Perl itself.
278
279 =cut
+69
-0
lib/Archive/Zip/MockFileHandle.pm less more
0 package Archive::Zip::MockFileHandle;
1
2 # Output file handle that calls a custom write routine
3 # Ned Konz, March 2000
4 # This is provided to help with writing zip files
5 # when you have to process them a chunk at a time.
6
7 use strict;
8
9 use vars qw{$VERSION};
10
11 BEGIN {
12 $VERSION = '1.18';
13 $VERSION = eval $VERSION;
14 }
15
16 sub new {
17 my $class = shift || __PACKAGE__;
18 $class = ref($class) || $class;
19 my $self = bless(
20 {
21 'position' => 0,
22 'size' => 0
23 },
24 $class
25 );
26 return $self;
27 }
28
29 sub eof {
30 my $self = shift;
31 return $self->{'position'} >= $self->{'size'};
32 }
33
34 # Copy given buffer to me
35 sub print {
36 my $self = shift;
37 my $bytes = join( '', @_ );
38 my $bytesWritten = $self->writeHook($bytes);
39 if ( $self->{'position'} + $bytesWritten > $self->{'size'} ) {
40 $self->{'size'} = $self->{'position'} + $bytesWritten;
41 }
42 $self->{'position'} += $bytesWritten;
43 return $bytesWritten;
44 }
45
46 # Called on each write.
47 # Override in subclasses.
48 # Return number of bytes written (0 on error).
49 sub writeHook {
50 my $self = shift;
51 my $bytes = shift;
52 return length($bytes);
53 }
54
55 sub binmode { 1 }
56
57 sub close { 1 }
58
59 sub clearerr { 1 }
60
61 # I'm write-only!
62 sub read { 0 }
63
64 sub tell { return shift->{'position'} }
65
66 sub opened { 1 }
67
68 1;
+79
-0
lib/Archive/Zip/NewFileMember.pm less more
0 package Archive::Zip::NewFileMember;
1
2 use strict;
3 use vars qw( $VERSION @ISA );
4
5 BEGIN {
6 $VERSION = '1.18';
7 @ISA = qw ( Archive::Zip::FileMember );
8 }
9
10 use Archive::Zip qw(
11 :CONSTANTS
12 :ERROR_CODES
13 :UTILITY_METHODS
14 );
15
16 # Given a file name, set up for eventual writing.
17 sub _newFromFileNamed {
18 my $class = shift;
19 my $fileName = shift; # local FS format
20 my $newName = shift;
21 $newName = _asZipDirName($fileName) unless defined($newName);
22 return undef unless ( stat($fileName) && -r _ && !-d _ );
23 my $self = $class->new(@_);
24 $self->fileName($newName);
25 $self->{'externalFileName'} = $fileName;
26 $self->{'compressionMethod'} = COMPRESSION_STORED;
27 my @stat = stat(_);
28 $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
29 $self->desiredCompressionMethod(
30 ( $self->compressedSize() > 0 )
31 ? COMPRESSION_DEFLATED
32 : COMPRESSION_STORED
33 );
34 $self->unixFileAttributes( $stat[2] );
35 $self->setLastModFileDateTimeFromUnix( $stat[9] );
36 $self->isTextFile( -T _ );
37 return $self;
38 }
39
40 sub rewindData {
41 my $self = shift;
42
43 my $status = $self->SUPER::rewindData(@_);
44 return $status unless $status == AZ_OK;
45
46 return AZ_IO_ERROR unless $self->fh();
47 $self->fh()->clearerr();
48 $self->fh()->seek( 0, IO::Seekable::SEEK_SET )
49 or return _ioError( "rewinding", $self->externalFileName() );
50 return AZ_OK;
51 }
52
53 # Return bytes read. Note that first parameter is a ref to a buffer.
54 # my $data;
55 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
56 sub _readRawChunk {
57 my ( $self, $dataRef, $chunkSize ) = @_;
58 return ( 0, AZ_OK ) unless $chunkSize;
59 my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
60 or return ( 0, _ioError("reading data") );
61 return ( $bytesRead, AZ_OK );
62 }
63
64 # If I already exist, extraction is a no-op.
65 sub extractToFileNamed {
66 my $self = shift;
67 my $name = shift; # local FS name
68 if ( File::Spec->rel2abs($name) eq
69 File::Spec->rel2abs( $self->externalFileName() ) and -r $name )
70 {
71 return AZ_OK;
72 }
73 else {
74 return $self->SUPER::extractToFileNamed( $name, @_ );
75 }
76 }
77
78 1;
+64
-0
lib/Archive/Zip/StringMember.pm less more
0 package Archive::Zip::StringMember;
1
2 use strict;
3 use vars qw( $VERSION @ISA );
4
5 BEGIN {
6 $VERSION = '1.18';
7 @ISA = qw( Archive::Zip::Member );
8 }
9
10 use Archive::Zip qw(
11 :CONSTANTS
12 :ERROR_CODES
13 );
14
15 # Create a new string member. Default is COMPRESSION_STORED.
16 # Can take a ref to a string as well.
17 sub _newFromString {
18 my $class = shift;
19 my $string = shift;
20 my $name = shift;
21 my $self = $class->new(@_);
22 $self->contents($string);
23 $self->fileName($name) if defined($name);
24
25 # Set the file date to now
26 $self->setLastModFileDateTimeFromUnix( time() );
27 $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
28 return $self;
29 }
30
31 sub _become {
32 my $self = shift;
33 my $newClass = shift;
34 return $self if ref($self) eq $newClass;
35 delete( $self->{'contents'} );
36 return $self->SUPER::_become($newClass);
37 }
38
39 # Get or set my contents. Note that we do not call the superclass
40 # version of this, because it calls us.
41 sub contents {
42 my $self = shift;
43 my $string = shift;
44 if ( defined($string) ) {
45 $self->{'contents'} =
46 pack( 'C0a*', ( ref($string) eq 'SCALAR' ) ? $$string : $string );
47 $self->{'uncompressedSize'} = $self->{'compressedSize'} =
48 length( $self->{'contents'} );
49 $self->{'compressionMethod'} = COMPRESSION_STORED;
50 }
51 return $self->{'contents'};
52 }
53
54 # Return bytes read. Note that first parameter is a ref to a buffer.
55 # my $data;
56 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
57 sub _readRawChunk {
58 my ( $self, $dataRef, $chunkSize ) = @_;
59 $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
60 return ( length($$dataRef), AZ_OK );
61 }
62
63 1;
+40
-0
lib/Archive/Zip/Tree.pm less more
0 use Archive::Zip;
1
2 warn(
3 "Archive::Zip::Tree is deprecated; its methods have been moved into Archive::Zip."
4 ) if $^W;
5
6 1;
7
8 __END__
9
10 =head1 NAME
11
12 Archive::Zip::Tree - (DEPRECATED) methods for adding/extracting trees using Archive::Zip
13
14 =head1 SYNOPSIS
15
16 =head1 DESCRIPTION
17
18 This module is deprecated, because all its methods were moved into the main
19 Archive::Zip module.
20
21 It is included in the distribution merely to avoid breaking old code.
22
23 See L<Archive::Zip>.
24
25 =head1 AUTHOR
26
27 Ned Konz, perl@bike-nomad.com
28
29 =head1 COPYRIGHT
30
31 Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free
32 software; you can redistribute it and/or modify it under the same terms
33 as Perl itself.
34
35 =head1 SEE ALSO
36
37 L<Archive::Zip>
38
39 =cut
+413
-0
lib/Archive/Zip/ZipFileMember.pm less more
0 package Archive::Zip::ZipFileMember;
1
2 use strict;
3 use vars qw( $VERSION @ISA );
4
5 BEGIN {
6 $VERSION = '1.18';
7 @ISA = qw ( Archive::Zip::FileMember );
8 }
9
10 use Archive::Zip qw(
11 :CONSTANTS
12 :ERROR_CODES
13 :PKZIP_CONSTANTS
14 :UTILITY_METHODS
15 );
16
17 # Create a new Archive::Zip::ZipFileMember
18 # given a filename and optional open file handle
19 #
20 sub _newFromZipFile {
21 my $class = shift;
22 my $fh = shift;
23 my $externalFileName = shift;
24 my $possibleEocdOffset = shift; # normally 0
25
26 my $self = $class->new(
27 'crc32' => 0,
28 'diskNumberStart' => 0,
29 'localHeaderRelativeOffset' => 0,
30 'dataOffset' => 0, # localHeaderRelativeOffset + header length
31 @_
32 );
33 $self->{'externalFileName'} = $externalFileName;
34 $self->{'fh'} = $fh;
35 $self->{'possibleEocdOffset'} = $possibleEocdOffset;
36 return $self;
37 }
38
39 sub isDirectory {
40 my $self = shift;
41 return ( substr( $self->fileName(), -1, 1 ) eq '/'
42 and $self->uncompressedSize() == 0 );
43 }
44
45 # Seek to the beginning of the local header, just past the signature.
46 # Verify that the local header signature is in fact correct.
47 # Update the localHeaderRelativeOffset if necessary by adding the possibleEocdOffset.
48 # Returns status.
49
50 sub _seekToLocalHeader {
51 my $self = shift;
52 my $where = shift; # optional
53 my $previousWhere = shift; # optional
54
55 $where = $self->localHeaderRelativeOffset() unless defined($where);
56
57 # avoid loop on certain corrupt files (from Julian Field)
58 return _formatError("corrupt zip file")
59 if defined($previousWhere) && $where == $previousWhere;
60
61 my $status;
62 my $signature;
63
64 $status = $self->fh()->seek( $where, IO::Seekable::SEEK_SET );
65 return _ioError("seeking to local header") unless $status;
66
67 ( $status, $signature ) =
68 _readSignature( $self->fh(), $self->externalFileName(),
69 LOCAL_FILE_HEADER_SIGNATURE );
70 return $status if $status == AZ_IO_ERROR;
71
72 # retry with EOCD offset if any was given.
73 if ( $status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'} ) {
74 $status = $self->_seekToLocalHeader(
75 $self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'},
76 $where
77 );
78 if ( $status == AZ_OK ) {
79 $self->{'localHeaderRelativeOffset'} +=
80 $self->{'possibleEocdOffset'};
81 $self->{'possibleEocdOffset'} = 0;
82 }
83 }
84
85 return $status;
86 }
87
88 # Because I'm going to delete the file handle, read the local file
89 # header if the file handle is seekable. If it isn't, I assume that
90 # I've already read the local header.
91 # Return ( $status, $self )
92
93 sub _become {
94 my $self = shift;
95 my $newClass = shift;
96 return $self if ref($self) eq $newClass;
97
98 my $status = AZ_OK;
99
100 if ( _isSeekable( $self->fh() ) ) {
101 my $here = $self->fh()->tell();
102 $status = $self->_seekToLocalHeader();
103 $status = $self->_readLocalFileHeader() if $status == AZ_OK;
104 $self->fh()->seek( $here, IO::Seekable::SEEK_SET );
105 return $status unless $status == AZ_OK;
106 }
107
108 delete( $self->{'eocdCrc32'} );
109 delete( $self->{'diskNumberStart'} );
110 delete( $self->{'localHeaderRelativeOffset'} );
111 delete( $self->{'dataOffset'} );
112
113 return $self->SUPER::_become($newClass);
114 }
115
116 sub diskNumberStart {
117 shift->{'diskNumberStart'};
118 }
119
120 sub localHeaderRelativeOffset {
121 shift->{'localHeaderRelativeOffset'};
122 }
123
124 sub dataOffset {
125 shift->{'dataOffset'};
126 }
127
128 # Skip local file header, updating only extra field stuff.
129 # Assumes that fh is positioned before signature.
130 sub _skipLocalFileHeader {
131 my $self = shift;
132 my $header;
133 my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
134 if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH ) {
135 return _ioError("reading local file header");
136 }
137 my $fileNameLength;
138 my $extraFieldLength;
139 my $bitFlag;
140 (
141 undef, # $self->{'versionNeededToExtract'},
142 $bitFlag,
143 undef, # $self->{'compressionMethod'},
144 undef, # $self->{'lastModFileDateTime'},
145 undef, # $crc32,
146 undef, # $compressedSize,
147 undef, # $uncompressedSize,
148 $fileNameLength,
149 $extraFieldLength
150 ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
151
152 if ($fileNameLength) {
153 $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
154 or return _ioError("skipping local file name");
155 }
156
157 if ($extraFieldLength) {
158 $bytesRead =
159 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
160 if ( $bytesRead != $extraFieldLength ) {
161 return _ioError("reading local extra field");
162 }
163 }
164
165 $self->{'dataOffset'} = $self->fh()->tell();
166
167 if ( $bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK ) {
168
169 # Read the crc32, compressedSize, and uncompressedSize from the
170 # extended data descriptor, which directly follows the compressed data.
171 #
172 # Skip over the compressed file data (assumes that EOCD compressedSize
173 # was correct)
174 $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
175 or return _ioError("seeking to extended local header");
176
177 # these values should be set correctly from before.
178 my $oldCrc32 = $self->{'eocdCrc32'};
179 my $oldCompressedSize = $self->{'compressedSize'};
180 my $oldUncompressedSize = $self->{'uncompressedSize'};
181
182 my $status = $self->_readDataDescriptor();
183 return $status unless $status == AZ_OK;
184
185 return _formatError(
186 "CRC or size mismatch while skipping data descriptor")
187 if ( $oldCrc32 != $self->{'crc32'}
188 || $oldUncompressedSize != $self->{'uncompressedSize'} );
189 }
190
191 return AZ_OK;
192 }
193
194 # Read from a local file header into myself. Returns AZ_OK if successful.
195 # Assumes that fh is positioned after signature.
196 # Note that crc32, compressedSize, and uncompressedSize will be 0 if
197 # GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag.
198
199 sub _readLocalFileHeader {
200 my $self = shift;
201 my $header;
202 my $bytesRead = $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH );
203 if ( $bytesRead != LOCAL_FILE_HEADER_LENGTH ) {
204 return _ioError("reading local file header");
205 }
206 my $fileNameLength;
207 my $crc32;
208 my $compressedSize;
209 my $uncompressedSize;
210 my $extraFieldLength;
211 (
212 $self->{'versionNeededToExtract'}, $self->{'bitFlag'},
213 $self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
214 $crc32, $compressedSize,
215 $uncompressedSize, $fileNameLength,
216 $extraFieldLength
217 ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
218
219 if ($fileNameLength) {
220 my $fileName;
221 $bytesRead = $self->fh()->read( $fileName, $fileNameLength );
222 if ( $bytesRead != $fileNameLength ) {
223 return _ioError("reading local file name");
224 }
225 $self->fileName($fileName);
226 }
227
228 if ($extraFieldLength) {
229 $bytesRead =
230 $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength );
231 if ( $bytesRead != $extraFieldLength ) {
232 return _ioError("reading local extra field");
233 }
234 }
235
236 $self->{'dataOffset'} = $self->fh()->tell();
237
238 if ( $self->hasDataDescriptor() ) {
239
240 # Read the crc32, compressedSize, and uncompressedSize from the
241 # extended data descriptor.
242 # Skip over the compressed file data (assumes that EOCD compressedSize
243 # was correct)
244 $self->fh()->seek( $self->{'compressedSize'}, IO::Seekable::SEEK_CUR )
245 or return _ioError("seeking to extended local header");
246
247 my $status = $self->_readDataDescriptor();
248 return $status unless $status == AZ_OK;
249 }
250 else {
251 return _formatError(
252 "CRC or size mismatch after reading data descriptor")
253 if ( $self->{'crc32'} != $crc32
254 || $self->{'uncompressedSize'} != $uncompressedSize );
255 }
256
257 return AZ_OK;
258 }
259
260 # This will read the data descriptor, which is after the end of compressed file
261 # data in members that that have GPBF_HAS_DATA_DESCRIPTOR_MASK set in their
262 # bitFlag.
263 # The only reliable way to find these is to rely on the EOCD compressedSize.
264 # Assumes that file is positioned immediately after the compressed data.
265 # Returns status; sets crc32, compressedSize, and uncompressedSize.
266 sub _readDataDescriptor {
267 my $self = shift;
268 my $signatureData;
269 my $header;
270 my $crc32;
271 my $compressedSize;
272 my $uncompressedSize;
273
274 my $bytesRead = $self->fh()->read( $signatureData, SIGNATURE_LENGTH );
275 return _ioError("reading header signature")
276 if $bytesRead != SIGNATURE_LENGTH;
277 my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
278
279 # unfortunately, the signature appears to be optional.
280 if ( $signature == DATA_DESCRIPTOR_SIGNATURE
281 && ( $signature != $self->{'crc32'} ) )
282 {
283 $bytesRead = $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH );
284 return _ioError("reading data descriptor")
285 if $bytesRead != DATA_DESCRIPTOR_LENGTH;
286
287 ( $crc32, $compressedSize, $uncompressedSize ) =
288 unpack( DATA_DESCRIPTOR_FORMAT, $header );
289 }
290 else {
291 $bytesRead =
292 $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH_NO_SIG );
293 return _ioError("reading data descriptor")
294 if $bytesRead != DATA_DESCRIPTOR_LENGTH_NO_SIG;
295
296 $crc32 = $signature;
297 ( $compressedSize, $uncompressedSize ) =
298 unpack( DATA_DESCRIPTOR_FORMAT_NO_SIG, $header );
299 }
300
301 $self->{'eocdCrc32'} = $self->{'crc32'}
302 unless defined( $self->{'eocdCrc32'} );
303 $self->{'crc32'} = $crc32;
304 $self->{'compressedSize'} = $compressedSize;
305 $self->{'uncompressedSize'} = $uncompressedSize;
306
307 return AZ_OK;
308 }
309
310 # Read a Central Directory header. Return AZ_OK on success.
311 # Assumes that fh is positioned right after the signature.
312
313 sub _readCentralDirectoryFileHeader {
314 my $self = shift;
315 my $fh = $self->fh();
316 my $header = '';
317 my $bytesRead = $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH );
318 if ( $bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH ) {
319 return _ioError("reading central dir header");
320 }
321 my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
322 (
323 $self->{'versionMadeBy'},
324 $self->{'fileAttributeFormat'},
325 $self->{'versionNeededToExtract'},
326 $self->{'bitFlag'},
327 $self->{'compressionMethod'},
328 $self->{'lastModFileDateTime'},
329 $self->{'crc32'},
330 $self->{'compressedSize'},
331 $self->{'uncompressedSize'},
332 $fileNameLength,
333 $extraFieldLength,
334 $fileCommentLength,
335 $self->{'diskNumberStart'},
336 $self->{'internalFileAttributes'},
337 $self->{'externalFileAttributes'},
338 $self->{'localHeaderRelativeOffset'}
339 ) = unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
340
341 $self->{'eocdCrc32'} = $self->{'crc32'};
342
343 if ($fileNameLength) {
344 $bytesRead = $fh->read( $self->{'fileName'}, $fileNameLength );
345 if ( $bytesRead != $fileNameLength ) {
346 _ioError("reading central dir filename");
347 }
348 }
349 if ($extraFieldLength) {
350 $bytesRead = $fh->read( $self->{'cdExtraField'}, $extraFieldLength );
351 if ( $bytesRead != $extraFieldLength ) {
352 return _ioError("reading central dir extra field");
353 }
354 }
355 if ($fileCommentLength) {
356 $bytesRead = $fh->read( $self->{'fileComment'}, $fileCommentLength );
357 if ( $bytesRead != $fileCommentLength ) {
358 return _ioError("reading central dir file comment");
359 }
360 }
361
362 # NK 10/21/04: added to avoid problems with manipulated headers
363 if ( $self->{'uncompressedSize'} != $self->{'compressedSize'}
364 and $self->{'compressionMethod'} == COMPRESSION_STORED )
365 {
366 $self->{'uncompressedSize'} = $self->{'compressedSize'};
367 }
368
369 $self->desiredCompressionMethod( $self->compressionMethod() );
370
371 return AZ_OK;
372 }
373
374 sub rewindData {
375 my $self = shift;
376
377 my $status = $self->SUPER::rewindData(@_);
378 return $status unless $status == AZ_OK;
379
380 return AZ_IO_ERROR unless $self->fh();
381
382 $self->fh()->clearerr();
383
384 # Seek to local file header.
385 # The only reason that I'm doing this this way is that the extraField
386 # length seems to be different between the CD header and the LF header.
387 $status = $self->_seekToLocalHeader();
388 return $status unless $status == AZ_OK;
389
390 # skip local file header
391 $status = $self->_skipLocalFileHeader();
392 return $status unless $status == AZ_OK;
393
394 # Seek to beginning of file data
395 $self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET )
396 or return _ioError("seeking to beginning of file data");
397
398 return AZ_OK;
399 }
400
401 # Return bytes read. Note that first parameter is a ref to a buffer.
402 # my $data;
403 # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
404 sub _readRawChunk {
405 my ( $self, $dataRef, $chunkSize ) = @_;
406 return ( 0, AZ_OK ) unless $chunkSize;
407 my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
408 or return ( 0, _ioError("reading data") );
409 return ( $bytesRead, AZ_OK );
410 }
411
412 1;
+2042
-0
lib/Archive/Zip.pm less more
0 package Archive::Zip;
1
2 # Copyright 2000 - 2002 Ned Konz. All rights reserved. This program is free
3 # software; you can redistribute it and/or modify it under the same terms as
4 # Perl itself.
5
6 # ----------------------------------------------------------------------
7 # class Archive::Zip
8 # Note that the package Archive::Zip exists only for exporting and
9 # sharing constants. Everything else is in another package
10 # in this file.
11 # Creation of a new Archive::Zip object actually creates a new object
12 # of class Archive::Zip::Archive.
13 # ----------------------------------------------------------------------
14
15 BEGIN {
16 require 5.003_96;
17 }
18 use strict;
19 use UNIVERSAL ();
20 use Carp ();
21 use IO::File ();
22 use IO::Seekable ();
23 use Compress::Zlib ();
24 use File::Spec ();
25 use File::Temp ();
26
27 use vars qw( $VERSION @ISA );
28 BEGIN {
29 $VERSION = '1.18';
30 $VERSION = eval $VERSION;
31
32 require Exporter;
33 @ISA = qw( Exporter );
34 }
35
36 use vars qw( $ChunkSize $ErrorHandler );
37
38 # This is the size we'll try to read, write, and (de)compress.
39 # You could set it to something different if you had lots of memory
40 # and needed more speed.
41 $ChunkSize = 32768;
42
43 $ErrorHandler = \&Carp::carp;
44
45 # BEGIN block is necessary here so that other modules can use the constants.
46 use vars qw( @EXPORT_OK %EXPORT_TAGS );
47 BEGIN {
48 @EXPORT_OK = ('computeCRC32');
49 %EXPORT_TAGS = (
50 CONSTANTS => [ qw(
51 FA_MSDOS
52 FA_UNIX
53 GPBF_ENCRYPTED_MASK
54 GPBF_DEFLATING_COMPRESSION_MASK
55 GPBF_HAS_DATA_DESCRIPTOR_MASK
56 COMPRESSION_STORED
57 COMPRESSION_DEFLATED
58 COMPRESSION_LEVEL_NONE
59 COMPRESSION_LEVEL_DEFAULT
60 COMPRESSION_LEVEL_FASTEST
61 COMPRESSION_LEVEL_BEST_COMPRESSION
62 IFA_TEXT_FILE_MASK
63 IFA_TEXT_FILE
64 IFA_BINARY_FILE
65 ) ],
66
67 MISC_CONSTANTS => [ qw(
68 FA_AMIGA
69 FA_VAX_VMS
70 FA_VM_CMS
71 FA_ATARI_ST
72 FA_OS2_HPFS
73 FA_MACINTOSH
74 FA_Z_SYSTEM
75 FA_CPM
76 FA_TOPS20
77 FA_WINDOWS_NTFS
78 FA_QDOS
79 FA_ACORN
80 FA_VFAT
81 FA_MVS
82 FA_BEOS
83 FA_TANDEM
84 FA_THEOS
85 GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
86 GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
87 GPBF_IS_COMPRESSED_PATCHED_DATA_MASK
88 COMPRESSION_SHRUNK
89 DEFLATING_COMPRESSION_NORMAL
90 DEFLATING_COMPRESSION_MAXIMUM
91 DEFLATING_COMPRESSION_FAST
92 DEFLATING_COMPRESSION_SUPER_FAST
93 COMPRESSION_REDUCED_1
94 COMPRESSION_REDUCED_2
95 COMPRESSION_REDUCED_3
96 COMPRESSION_REDUCED_4
97 COMPRESSION_IMPLODED
98 COMPRESSION_TOKENIZED
99 COMPRESSION_DEFLATED_ENHANCED
100 COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED
101 ) ],
102
103 ERROR_CODES => [ qw(
104 AZ_OK
105 AZ_STREAM_END
106 AZ_ERROR
107 AZ_FORMAT_ERROR
108 AZ_IO_ERROR
109 ) ],
110
111 # For Internal Use Only
112 PKZIP_CONSTANTS => [ qw(
113 SIGNATURE_FORMAT
114 SIGNATURE_LENGTH
115 LOCAL_FILE_HEADER_SIGNATURE
116 LOCAL_FILE_HEADER_FORMAT
117 LOCAL_FILE_HEADER_LENGTH
118 CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
119 DATA_DESCRIPTOR_FORMAT
120 DATA_DESCRIPTOR_LENGTH
121 DATA_DESCRIPTOR_SIGNATURE
122 DATA_DESCRIPTOR_FORMAT_NO_SIG
123 DATA_DESCRIPTOR_LENGTH_NO_SIG
124 CENTRAL_DIRECTORY_FILE_HEADER_FORMAT
125 CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
126 END_OF_CENTRAL_DIRECTORY_SIGNATURE
127 END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING
128 END_OF_CENTRAL_DIRECTORY_FORMAT
129 END_OF_CENTRAL_DIRECTORY_LENGTH
130 ) ],
131
132 # For Internal Use Only
133 UTILITY_METHODS => [ qw(
134 _error
135 _printError
136 _ioError
137 _formatError
138 _subclassResponsibility
139 _binmode
140 _isSeekable
141 _newFileHandle
142 _readSignature
143 _asZipDirName
144 ) ],
145 );
146
147 # Add all the constant names and error code names to @EXPORT_OK
148 Exporter::export_ok_tags( qw(
149 CONSTANTS
150 ERROR_CODES
151 PKZIP_CONSTANTS
152 UTILITY_METHODS
153 MISC_CONSTANTS
154 ) );
155
156 }
157
158 # Error codes
159 use constant AZ_OK => 0;
160 use constant AZ_STREAM_END => 1;
161 use constant AZ_ERROR => 2;
162 use constant AZ_FORMAT_ERROR => 3;
163 use constant AZ_IO_ERROR => 4;
164
165 # File types
166 # Values of Archive::Zip::Member->fileAttributeFormat()
167
168 use constant FA_MSDOS => 0;
169 use constant FA_AMIGA => 1;
170 use constant FA_VAX_VMS => 2;
171 use constant FA_UNIX => 3;
172 use constant FA_VM_CMS => 4;
173 use constant FA_ATARI_ST => 5;
174 use constant FA_OS2_HPFS => 6;
175 use constant FA_MACINTOSH => 7;
176 use constant FA_Z_SYSTEM => 8;
177 use constant FA_CPM => 9;
178 use constant FA_TOPS20 => 10;
179 use constant FA_WINDOWS_NTFS => 11;
180 use constant FA_QDOS => 12;
181 use constant FA_ACORN => 13;
182 use constant FA_VFAT => 14;
183 use constant FA_MVS => 15;
184 use constant FA_BEOS => 16;
185 use constant FA_TANDEM => 17;
186 use constant FA_THEOS => 18;
187
188 # general-purpose bit flag masks
189 # Found in Archive::Zip::Member->bitFlag()
190
191 use constant GPBF_ENCRYPTED_MASK => 1 << 0;
192 use constant GPBF_DEFLATING_COMPRESSION_MASK => 3 << 1;
193 use constant GPBF_HAS_DATA_DESCRIPTOR_MASK => 1 << 3;
194
195 # deflating compression types, if compressionMethod == COMPRESSION_DEFLATED
196 # ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK )
197
198 use constant DEFLATING_COMPRESSION_NORMAL => 0 << 1;
199 use constant DEFLATING_COMPRESSION_MAXIMUM => 1 << 1;
200 use constant DEFLATING_COMPRESSION_FAST => 2 << 1;
201 use constant DEFLATING_COMPRESSION_SUPER_FAST => 3 << 1;
202
203 # compression method
204
205 # these two are the only ones supported in this module
206 use constant COMPRESSION_STORED => 0; # file is stored (no compression)
207 use constant COMPRESSION_DEFLATED => 8; # file is Deflated
208 use constant COMPRESSION_LEVEL_NONE => 0;
209 use constant COMPRESSION_LEVEL_DEFAULT => -1;
210 use constant COMPRESSION_LEVEL_FASTEST => 1;
211 use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9;
212
213 # internal file attribute bits
214 # Found in Archive::Zip::Member::internalFileAttributes()
215
216 use constant IFA_TEXT_FILE_MASK => 1;
217 use constant IFA_TEXT_FILE => 1;
218 use constant IFA_BINARY_FILE => 0;
219
220 # PKZIP file format miscellaneous constants (for internal use only)
221 use constant SIGNATURE_FORMAT => "V";
222 use constant SIGNATURE_LENGTH => 4;
223
224 # these lengths are without the signature.
225 use constant LOCAL_FILE_HEADER_SIGNATURE => 0x04034b50;
226 use constant LOCAL_FILE_HEADER_FORMAT => "v3 V4 v2";
227 use constant LOCAL_FILE_HEADER_LENGTH => 26;
228
229 # PKZIP docs don't mention the signature, but Info-Zip writes it.
230 use constant DATA_DESCRIPTOR_SIGNATURE => 0x08074b50;
231 use constant DATA_DESCRIPTOR_FORMAT => "V3";
232 use constant DATA_DESCRIPTOR_LENGTH => 12;
233
234 # but the signature is apparently optional.
235 use constant DATA_DESCRIPTOR_FORMAT_NO_SIG => "V2";
236 use constant DATA_DESCRIPTOR_LENGTH_NO_SIG => 8;
237
238 use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50;
239 use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2";
240 use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42;
241
242 use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50;
243 use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING =>
244 pack( "V", END_OF_CENTRAL_DIRECTORY_SIGNATURE );
245 use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v";
246 use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18;
247
248 use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK => 1 << 1;
249 use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK => 1 << 2;
250 use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK => 1 << 5;
251
252 # the rest of these are not supported in this module
253 use constant COMPRESSION_SHRUNK => 1; # file is Shrunk
254 use constant COMPRESSION_REDUCED_1 => 2; # file is Reduced CF=1
255 use constant COMPRESSION_REDUCED_2 => 3; # file is Reduced CF=2
256 use constant COMPRESSION_REDUCED_3 => 4; # file is Reduced CF=3
257 use constant COMPRESSION_REDUCED_4 => 5; # file is Reduced CF=4
258 use constant COMPRESSION_IMPLODED => 6; # file is Imploded
259 use constant COMPRESSION_TOKENIZED => 7; # reserved for Tokenizing compr.
260 use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating
261 use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10;
262
263 # Load the various required classes
264 require Archive::Zip::Archive;
265 require Archive::Zip::Member;
266 require Archive::Zip::FileMember;
267 require Archive::Zip::DirectoryMember;
268 require Archive::Zip::ZipFileMember;
269 require Archive::Zip::NewFileMember;
270 require Archive::Zip::StringMember;
271
272 use constant ZIPARCHIVECLASS => 'Archive::Zip::Archive';
273 use constant ZIPMEMBERCLASS => 'Archive::Zip::Member';
274
275 sub new
276 {
277 my $class = shift;
278 return $class->ZIPARCHIVECLASS->new(@_);
279 }
280
281 sub computeCRC32
282 {
283 my $data = shift;
284 $data = shift if ref($data); # allow calling as an obj method
285 my $crc = shift;
286 return Compress::Zlib::crc32( $data, $crc );
287 }
288
289 # Report or change chunk size used for reading and writing.
290 # Also sets Zlib's default buffer size (eventually).
291 sub setChunkSize
292 {
293 my $chunkSize = shift;
294 $chunkSize = shift if ref($chunkSize); # object method on zip?
295 my $oldChunkSize = $Archive::Zip::ChunkSize;
296 $Archive::Zip::ChunkSize = $chunkSize if ($chunkSize);
297 return $oldChunkSize;
298 }
299
300 sub chunkSize
301 {
302 return $Archive::Zip::ChunkSize;
303 }
304
305 sub setErrorHandler (&)
306 {
307 my $errorHandler = shift;
308 $errorHandler = \&Carp::carp unless defined($errorHandler);
309 my $oldErrorHandler = $Archive::Zip::ErrorHandler;
310 $Archive::Zip::ErrorHandler = $errorHandler;
311 return $oldErrorHandler;
312 }
313
314 # ----------------------------------------------------------------------
315 # Private utility functions (not methods).
316 # ----------------------------------------------------------------------
317
318 sub _printError
319 {
320 my $string = join ( ' ', @_, "\n" );
321 my $oldCarpLevel = $Carp::CarpLevel;
322 $Carp::CarpLevel += 2;
323 &{$ErrorHandler} ($string);
324 $Carp::CarpLevel = $oldCarpLevel;
325 }
326
327 # This is called on format errors.
328 sub _formatError
329 {
330 shift if ref( $_[0] );
331 _printError( 'format error:', @_ );
332 return AZ_FORMAT_ERROR;
333 }
334
335 # This is called on IO errors.
336 sub _ioError
337 {
338 shift if ref( $_[0] );
339 _printError( 'IO error:', @_, ':', $! );
340 return AZ_IO_ERROR;
341 }
342
343 # This is called on generic errors.
344 sub _error
345 {
346 shift if ref( $_[0] );
347 _printError( 'error:', @_ );
348 return AZ_ERROR;
349 }
350
351 # Called when a subclass should have implemented
352 # something but didn't
353 sub _subclassResponsibility
354 {
355 Carp::croak("subclass Responsibility\n");
356 }
357
358 # Try to set the given file handle or object into binary mode.
359 sub _binmode
360 {
361 my $fh = shift;
362 return UNIVERSAL::can( $fh, 'binmode' ) ? $fh->binmode() : binmode($fh);
363 }
364
365 # Attempt to guess whether file handle is seekable.
366 # Because of problems with Windoze, this only returns true when
367 # the file handle is a real file.
368 sub _isSeekable
369 {
370 my $fh = shift;
371 if ( UNIVERSAL::isa($fh, 'IO::Scalar') ) {
372 return 0;
373 }
374 if ( UNIVERSAL::isa($fh, 'IO::String') ) {
375 return 1;
376 }
377 if ( UNIVERSAL::isa($fh, 'IO::Seekable') ) {
378 # Unfortunately, some things like FileHandle objects
379 # return true for Seekable, but AREN'T!!!!!
380 if ( UNIVERSAL::isa($fh, 'FileHandle') ) {
381 return 0;
382 }
383 return 1;
384 }
385 if ( UNIVERSAL::can($fh, 'stat') ) {
386 return -f $fh;
387 }
388 return (
389 UNIVERSAL::can($fh, 'seek') and UNIVERSAL::can($fh, 'tell')
390 ) ? 1 : 0;
391 }
392
393 # Return an opened IO::Handle
394 # my ( $status, fh ) = _newFileHandle( 'fileName', 'w' );
395 # Can take a filename, file handle, or ref to GLOB
396 # Or, if given something that is a ref but not an IO::Handle,
397 # passes back the same thing.
398 sub _newFileHandle
399 {
400 my $fd = shift;
401 my $status = 1;
402 my $handle;
403
404 if ( ref($fd) )
405 {
406 if ( UNIVERSAL::isa( $fd, 'IO::Scalar' )
407 or UNIVERSAL::isa( $fd, 'IO::String' ) )
408 {
409 $handle = $fd;
410 }
411 elsif ( UNIVERSAL::isa( $fd, 'IO::Handle' )
412 or UNIVERSAL::isa( $fd, 'GLOB' ) )
413 {
414 $handle = IO::File->new();
415 $status = $handle->fdopen( $fd, @_ );
416 }
417 else
418 {
419 $handle = $fd;
420 }
421 }
422 else
423 {
424 $handle = IO::File->new();
425 $status = $handle->open( $fd, @_ );
426 }
427
428 return ( $status, $handle );
429 }
430
431 # Returns next signature from given file handle, leaves
432 # file handle positioned afterwards.
433 # In list context, returns ($status, $signature)
434 # ( $status, $signature) = _readSignature( $fh, $fileName );
435
436 sub _readSignature
437 {
438 my $fh = shift;
439 my $fileName = shift;
440 my $expectedSignature = shift; # optional
441
442 my $signatureData;
443 my $bytesRead = $fh->read( $signatureData, SIGNATURE_LENGTH );
444 return _ioError("reading header signature")
445 if $bytesRead != SIGNATURE_LENGTH;
446 my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
447 my $status = AZ_OK;
448
449 # compare with expected signature, if any, or any known signature.
450 if ( ( defined($expectedSignature) && $signature != $expectedSignature )
451 || ( !defined($expectedSignature)
452 && $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
453 && $signature != LOCAL_FILE_HEADER_SIGNATURE
454 && $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE
455 && $signature != DATA_DESCRIPTOR_SIGNATURE ) )
456 {
457 my $errmsg = sprintf( "bad signature: 0x%08x", $signature );
458 if ( _isSeekable($fh) )
459 {
460 $errmsg .=
461 sprintf( " at offset %d", $fh->tell() - SIGNATURE_LENGTH );
462 }
463
464 $status = _formatError("$errmsg in file $fileName");
465 }
466
467 return ( $status, $signature );
468 }
469
470 # Utility method to make and open a temp file.
471 # Will create $temp_dir if it doesn't exist.
472 # Returns file handle and name:
473 #
474 # my ($fh, $name) = Archive::Zip::tempFile();
475 # my ($fh, $name) = Archive::Zip::tempFile('mytempdir');
476 #
477
478 sub tempFile
479 {
480 my $dir = shift;
481 my ( $fh, $filename ) = File::Temp::tempfile(
482 SUFFIX => '.zip',
483 UNLINK => 0, # we will delete it!
484 $dir ? ( DIR => $dir ) : ()
485 );
486 return ( undef, undef ) unless $fh;
487 my ( $status, $newfh ) = _newFileHandle( $fh, 'w+' );
488 return ( $newfh, $filename );
489 }
490
491 # Return the normalized directory name as used in a zip file (path
492 # separators become slashes, etc.).
493 # Will translate internal slashes in path components (i.e. on Macs) to
494 # underscores. Discards volume names.
495 # When $forceDir is set, returns paths with trailing slashes (or arrays
496 # with trailing blank members).
497 #
498 # If third argument is a reference, returns volume information there.
499 #
500 # input output
501 # . ('.') '.'
502 # ./a ('a') a
503 # ./a/b ('a','b') a/b
504 # ./a/b/ ('a','b') a/b
505 # a/b/ ('a','b') a/b
506 # /a/b/ ('','a','b') /a/b
507 # c:\a\b\c.doc ('','a','b','c.doc') /a/b/c.doc # on Windoze
508 # "i/o maps:whatever" ('i_o maps', 'whatever') "i_o maps/whatever" # on Macs
509 sub _asZipDirName
510 {
511 my $name = shift;
512 my $forceDir = shift;
513 my $volReturn = shift;
514 my ( $volume, $directories, $file ) =
515 File::Spec->splitpath( File::Spec->canonpath($name), $forceDir );
516 $$volReturn = $volume if ( ref($volReturn) );
517 my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories);
518 if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component
519 push ( @dirs, $file || '' );
520 #return wantarray ? @dirs : join ( '/', @dirs );
521 return join ( '/', @dirs );
522 }
523
524 # Return an absolute local name for a zip name.
525 # Assume a directory if zip name has trailing slash.
526 # Takes an optional volume name in FS format (like 'a:').
527 #
528 sub _asLocalName
529 {
530 my $name = shift; # zip format
531 my $volume = shift;
532 $volume = '' unless defined($volume); # local FS format
533
534 my @paths = split ( /\//, $name );
535 my $filename = pop (@paths);
536 $filename = '' unless defined($filename);
537 my $localDirs = @paths?File::Spec->catdir(@paths):'';
538 my $localName = File::Spec->catpath( $volume, $localDirs, $filename );
539 $localName = File::Spec->rel2abs($localName) unless $volume;
540 return $localName;
541 }
542
543 1;
544
545 __END__
546
547 =pod
548
549 =head1 NAME
550
551 Archive::Zip - Provide an interface to ZIP archive files.
552
553 =head1 SYNOPSIS
554
555 # Create a Zip file
556 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
557 my $zip = Archive::Zip->new();
558
559 # Add a directory
560 my $dir_member = $zip->addDirectory( 'dirname/' );
561
562 # Add a file from a string with compression
563 my $string_member = $zip->addString( 'This is a test', 'stringMember.txt' );
564 $string_member->desiredCompressionMethod( COMPRESSION_DEFLATED );
565
566 # Add a file from disk
567 my $file_member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' );
568
569 # Save the Zip file
570 unless ( $zip->writeToFileNamed('someZip.zip') == AZ_OK ) {
571 die 'write error';
572 }
573
574 # Read a Zip file
575 my $somezip = Archive::Zip->new();
576 unless ( $somezip->read( 'someZip.zip' ) == AZ_OK ) {
577 die 'read error';
578 }
579
580 # Change the compression type for a file in the Zip
581 my $member = $somezip->memberNamed( 'stringMember.txt' );
582 $member->desiredCompressionMethod( COMPRESSION_STORED );
583 unless ( $zip->writeToFileNamed( 'someOtherZip.zip' ) == AZ_OK ) {
584 die 'write error';
585 }
586
587 =head1 DESCRIPTION
588
589 The Archive::Zip module allows a Perl program to create, manipulate, read,
590 and write Zip archive files.
591
592 Zip archives can be created, or you can read from existing zip files.
593
594 Once created, they can be written to files, streams, or strings. Members
595 can be added, removed, extracted, replaced, rearranged, and enumerated.
596 They can also be renamed or have their dates, comments, or other attributes
597 queried or modified. Their data can be compressed or uncompressed as needed.
598
599 Members can be created from members in existing Zip files, or from existing
600 directories, files, or strings.
601
602 This module uses the L<Compress::Zlib> library to read and write the
603 compressed streams inside the files.
604
605 =head2 File Naming
606
607 Regardless of what your local file system uses for file naming, names in a
608 Zip file are in Unix format (I<forward> slashes (/) separating directory
609 names, etc.).
610
611 C<Archive::Zip> tries to be consistent with file naming conventions, and will
612 translate back and forth between native and Zip file names.
613
614 However, it can't guess which format names are in. So two rules control what
615 kind of file name you must pass various routines:
616
617 =over 4
618
619 =item Names of files are in local format.
620
621 C<File::Spec> and C<File::Basename> are used for various file
622 operations. When you're referring to a file on your system, use its
623 file naming conventions.
624
625 =item Names of archive members are in Unix format.
626
627 This applies to every method that refers to an archive member, or
628 provides a name for new archive members. The C<extract()> methods
629 that can take one or two names will convert from local to zip names
630 if you call them with a single name.
631
632 =back
633
634 =head2 Archive::Zip Object Model
635
636 =head2 Overview
637
638 Archive::Zip::Archive objects are what you ordinarily deal with.
639 These maintain the structure of a zip file, without necessarily
640 holding data. When a zip is read from a disk file, the (possibly
641 compressed) data still lives in the file, not in memory. Archive
642 members hold information about the individual members, but not
643 (usually) the actual member data. When the zip is written to a
644 (different) file, the member data is compressed or copied as needed.
645 It is possible to make archive members whose data is held in a string
646 in memory, but this is not done when a zip file is read. Directory
647 members don't have any data.
648
649 =head2 Inheritance
650
651 Exporter
652 Archive::Zip Common base class, has defs.
653 Archive::Zip::Archive A Zip archive.
654 Archive::Zip::Member Abstract superclass for all members.
655 Archive::Zip::StringMember Member made from a string
656 Archive::Zip::FileMember Member made from an external file
657 Archive::Zip::ZipFileMember Member that lives in a zip file
658 Archive::Zip::NewFileMember Member whose data is in a file
659 Archive::Zip::DirectoryMember Member that is a directory
660
661 =head1 EXPORTS
662
663 =over 4
664
665 =item :CONSTANTS
666
667 Exports the following constants:
668
669 FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
670 GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
671 COMPRESSION_STORED COMPRESSION_DEFLATED IFA_TEXT_FILE_MASK
672 IFA_TEXT_FILE IFA_BINARY_FILE COMPRESSION_LEVEL_NONE
673 COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST
674 COMPRESSION_LEVEL_BEST_COMPRESSION
675
676 =item :MISC_CONSTANTS
677
678 Exports the following constants (only necessary for extending the
679 module):
680
681 FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST FA_OS2_HPFS
682 FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS
683 GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
684 GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
685 GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
686 DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
687 DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
688 COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
689 COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
690 COMPRESSION_DEFLATED_ENHANCED
691 COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED
692
693 =item :ERROR_CODES
694
695 Explained below. Returned from most methods.
696
697 AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR
698
699 =back
700
701 =head1 ERROR CODES
702
703 Many of the methods in Archive::Zip return error codes. These are implemented
704 as inline subroutines, using the C<use constant> pragma. They can be imported
705 into your namespace using the C<:ERROR_CODES> tag:
706
707 use Archive::Zip qw( :ERROR_CODES );
708
709 ...
710
711 unless ( $zip->read( 'myfile.zip' ) == AZ_OK ) {
712 die "whoops!";
713 }
714
715 =over 4
716
717 =item AZ_OK (0)
718
719 Everything is fine.
720
721 =item AZ_STREAM_END (1)
722
723 The read stream (or central directory) ended normally.
724
725 =item AZ_ERROR (2)
726
727 There was some generic kind of error.
728
729 =item AZ_FORMAT_ERROR (3)
730
731 There is a format error in a ZIP file being read.
732
733 =item AZ_IO_ERROR (4)
734
735 There was an IO error.
736
737 =back
738
739 =head2 Compression
740
741 Archive::Zip allows each member of a ZIP file to be compressed (using the
742 Deflate algorithm) or uncompressed.
743
744 Other compression algorithms that some versions of ZIP have been able to
745 produce are not supported. Each member has two compression methods: the
746 one it's stored as (this is always COMPRESSION_STORED for string and external
747 file members), and the one you desire for the member in the zip file.
748
749 These can be different, of course, so you can make a zip member that is not
750 compressed out of one that is, and vice versa.
751
752 You can inquire about the current compression and set the desired
753 compression method:
754
755 my $member = $zip->memberNamed( 'xyz.txt' );
756 $member->compressionMethod(); # return current compression
757
758 # set to read uncompressed
759 $member->desiredCompressionMethod( COMPRESSION_STORED );
760
761 # set to read compressed
762 $member->desiredCompressionMethod( COMPRESSION_DEFLATED );
763
764 There are two different compression methods:
765
766 =over 4
767
768 =item COMPRESSION_STORED
769
770 File is stored (no compression)
771
772 =item COMPRESSION_DEFLATED
773
774 File is Deflated
775
776 =back
777
778 =head2 Compression Levels
779
780 If a member's desiredCompressionMethod is COMPRESSION_DEFLATED, you
781 can choose different compression levels. This choice may affect the
782 speed of compression and decompression, as well as the size of the
783 compressed member data.
784
785 $member->desiredCompressionLevel( 9 );
786
787 The levels given can be:
788
789 =over 4
790
791 =item 0 or COMPRESSION_LEVEL_NONE
792
793 This is the same as saying
794
795 $member->desiredCompressionMethod( COMPRESSION_STORED );
796
797 =item 1 .. 9
798
799 1 gives the best speed and worst compression, and 9 gives the
800 best compression and worst speed.
801
802 =item COMPRESSION_LEVEL_FASTEST
803
804 This is a synonym for level 1.
805
806 =item COMPRESSION_LEVEL_BEST_COMPRESSION
807
808 This is a synonym for level 9.
809
810 =item COMPRESSION_LEVEL_DEFAULT
811
812 This gives a good compromise between speed and compression,
813 and is currently equivalent to 6 (this is in the zlib code).
814 This is the level that will be used if not specified.
815
816 =back
817
818 =head1 Archive::Zip Methods
819
820 The Archive::Zip class (and its invisible subclass Archive::Zip::Archive)
821 implement generic zip file functionality. Creating a new Archive::Zip object
822 actually makes an Archive::Zip::Archive object, but you don't have to worry
823 about this unless you're subclassing.
824
825 =head2 Constructor
826
827 =over 4
828
829 =item new( [$fileName] )
830
831 Make a new, empty zip archive.
832
833 my $zip = Archive::Zip->new();
834
835 If an additional argument is passed, new() will call read()
836 to read the contents of an archive:
837
838 my $zip = Archive::Zip->new( 'xyz.zip' );
839
840 If a filename argument is passed and the read fails for any
841 reason, new will return undef. For this reason, it may be
842 better to call read separately.
843
844 =back
845
846 =head2 Zip Archive Utility Methods
847
848 These Archive::Zip methods may be called as functions or as object
849 methods. Do not call them as class methods:
850
851 $zip = Archive::Zip->new();
852 $crc = Archive::Zip::computeCRC32( 'ghijkl' ); # OK
853 $crc = $zip->computeCRC32( 'ghijkl' ); # also OK
854 $crc = Archive::Zip->computeCRC32( 'ghijkl' ); # NOT OK
855
856 =over 4
857
858 =item Archive::Zip::computeCRC32( $string [, $crc] )
859
860 This is a utility function that uses the Compress::Zlib CRC
861 routine to compute a CRC-32. You can get the CRC of a string:
862
863 $crc = Archive::Zip::computeCRC32( $string );
864
865 Or you can compute the running CRC:
866
867 $crc = 0;
868 $crc = Archive::Zip::computeCRC32( 'abcdef', $crc );
869 $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc );
870
871 =item Archive::Zip::setChunkSize( $number )
872
873 Report or change chunk size used for reading and writing.
874 This can make big differences in dealing with large files.
875 Currently, this defaults to 32K. This also changes the chunk
876 size used for Compress::Zlib. You must call setChunkSize()
877 before reading or writing. This is not exportable, so you
878 must call it like:
879
880 Archive::Zip::setChunkSize( 4096 );
881
882 or as a method on a zip (though this is a global setting).
883 Returns old chunk size.
884
885 =item Archive::Zip::chunkSize()
886
887 Returns the current chunk size:
888
889 my $chunkSize = Archive::Zip::chunkSize();
890
891 =item Archive::Zip::setErrorHandler( \&subroutine )
892
893 Change the subroutine called with error strings. This
894 defaults to \&Carp::carp, but you may want to change it to
895 get the error strings. This is not exportable, so you must
896 call it like:
897
898 Archive::Zip::setErrorHandler( \&myErrorHandler );
899
900 If myErrorHandler is undef, resets handler to default.
901 Returns old error handler. Note that if you call Carp::carp
902 or a similar routine or if you're chaining to the default
903 error handler from your error handler, you may want to
904 increment the number of caller levels that are skipped (do
905 not just set it to a number):
906
907 $Carp::CarpLevel++;
908
909 =item Archive::Zip::tempFile( [$tmpdir] )
910
911 Create a uniquely named temp file. It will be returned open
912 for read/write. If C<$tmpdir> is given, it is used as the
913 name of a directory to create the file in. If not given,
914 creates the file using C<File::Spec::tmpdir()>. Generally, you can
915 override this choice using the
916
917 $ENV{TMPDIR}
918
919 environment variable. But see the L<File::Spec|File::Spec>
920 documentation for your system. Note that on many systems, if you're
921 running in taint mode, then you must make sure that C<$ENV{TMPDIR}> is
922 untainted for it to be used.
923 Will I<NOT> create C<$tmpdir> if it doesn't exist (this is a change
924 from prior versions!). Returns file handle and name:
925
926 my ($fh, $name) = Archive::Zip::tempFile();
927 my ($fh, $name) = Archive::Zip::tempFile('myTempDir');
928 my $fh = Archive::Zip::tempFile(); # if you don't need the name
929
930 =back
931
932 =head2 Zip Archive Accessors
933
934 =over 4
935
936 =item members()
937
938 Return a copy of the members array
939
940 my @members = $zip->members();
941
942 =item numberOfMembers()
943
944 Return the number of members I have
945
946 =item memberNames()
947
948 Return a list of the (internal) file names of the zip members
949
950 =item memberNamed( $string )
951
952 Return ref to member whose filename equals given filename or
953 undef. C<$string> must be in Zip (Unix) filename format.
954
955 =item membersMatching( $regex )
956
957 Return array of members whose filenames match given regular
958 expression in list context. Returns number of matching
959 members in scalar context.
960
961 my @textFileMembers = $zip->membersMatching( '.*\.txt' );
962 # or
963 my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' );
964
965 =item diskNumber()
966
967 Return the disk that I start on. Not used for writing zips,
968 but might be interesting if you read a zip in. This should be
969 0, as Archive::Zip does not handle multi-volume archives.
970
971 =item diskNumberWithStartOfCentralDirectory()
972
973 Return the disk number that holds the beginning of the
974 central directory. Not used for writing zips, but might be
975 interesting if you read a zip in. This should be 0, as
976 Archive::Zip does not handle multi-volume archives.
977
978 =item numberOfCentralDirectoriesOnThisDisk()
979
980 Return the number of CD structures in the zipfile last read in.
981 Not used for writing zips, but might be interesting if you read a zip
982 in.
983
984 =item numberOfCentralDirectories()
985
986 Return the number of CD structures in the zipfile last read in.
987 Not used for writing zips, but might be interesting if you read a zip
988 in.
989
990 =item centralDirectorySize()
991
992 Returns central directory size, as read from an external zip
993 file. Not used for writing zips, but might be interesting if
994 you read a zip in.
995
996 =item centralDirectoryOffsetWRTStartingDiskNumber()
997
998 Returns the offset into the zip file where the CD begins. Not
999 used for writing zips, but might be interesting if you read a
1000 zip in.
1001
1002 =item zipfileComment( [$string] )
1003
1004 Get or set the zipfile comment. Returns the old comment.
1005
1006 print $zip->zipfileComment();
1007 $zip->zipfileComment( 'New Comment' );
1008
1009 =item eocdOffset()
1010
1011 Returns the (unexpected) number of bytes between where the
1012 EOCD was found and where it expected to be. This is normally
1013 0, but would be positive if something (a virus, perhaps) had
1014 added bytes somewhere before the EOCD. Not used for writing
1015 zips, but might be interesting if you read a zip in. Here is
1016 an example of how you can diagnose this:
1017
1018 my $zip = Archive::Zip->new('somefile.zip');
1019 if ($zip->eocdOffset())
1020 {
1021 warn "A virus has added ", $zip->eocdOffset, " bytes of garbage\n";
1022 }
1023
1024 The C<eocdOffset()> is used to adjust the starting position of member
1025 headers, if necessary.
1026
1027 =item fileName()
1028
1029 Returns the name of the file last read from. If nothing has
1030 been read yet, returns an empty string; if read from a file
1031 handle, returns the handle in string form.
1032
1033 =back
1034
1035 =head2 Zip Archive Member Operations
1036
1037 Various operations on a zip file modify members. When a member is
1038 passed as an argument, you can either use a reference to the member
1039 itself, or the name of a member. Of course, using the name requires
1040 that names be unique within a zip (this is not enforced).
1041
1042 =over 4
1043
1044 =item removeMember( $memberOrName )
1045
1046 Remove and return the given member, or match its name and
1047 remove it. Returns undef if member or name doesn't exist in this
1048 Zip. No-op if member does not belong to this zip.
1049
1050 =item replaceMember( $memberOrName, $newMember )
1051
1052 Remove and return the given member, or match its name and
1053 remove it. Replace with new member. Returns undef if member or
1054 name doesn't exist in this Zip, or if C<$newMember> is undefined.
1055
1056 It is an (undiagnosed) error to provide a C<$newMember> that is a
1057 member of the zip being modified.
1058
1059 my $member1 = $zip->removeMember( 'xyz' );
1060 my $member2 = $zip->replaceMember( 'abc', $member1 );
1061 # now, $member2 (named 'abc') is not in $zip,
1062 # and $member1 (named 'xyz') is, having taken $member2's place.
1063
1064 =item extractMember( $memberOrName [, $extractedName ] )
1065
1066 Extract the given member, or match its name and extract it.
1067 Returns undef if member doesn't exist in this Zip. If
1068 optional second arg is given, use it as the name of the
1069 extracted member. Otherwise, the internal filename of the
1070 member is used as the name of the extracted file or
1071 directory.
1072 If you pass C<$extractedName>, it should be in the local file
1073 system's format.
1074 All necessary directories will be created. Returns C<AZ_OK>
1075 on success.
1076
1077 =item extractMemberWithoutPaths( $memberOrName [, $extractedName ] )
1078
1079 Extract the given member, or match its name and extract it.
1080 Does not use path information (extracts into the current
1081 directory). Returns undef if member doesn't exist in this
1082 Zip.
1083 If optional second arg is given, use it as the name of the
1084 extracted member (its paths will be deleted too). Otherwise,
1085 the internal filename of the member (minus paths) is used as
1086 the name of the extracted file or directory. Returns C<AZ_OK>
1087 on success.
1088
1089 =item addMember( $member )
1090
1091 Append a member (possibly from another zip file) to the zip
1092 file. Returns the new member. Generally, you will use
1093 addFile(), addDirectory(), addFileOrDirectory(), addString(),
1094 or read() to add members.
1095
1096 # Move member named 'abc' to end of zip:
1097 my $member = $zip->removeMember( 'abc' );
1098 $zip->addMember( $member );
1099
1100 =item updateMember( $memberOrName, $fileName )
1101
1102 Update a single member from the file or directory named C<$fileName>.
1103 Returns the (possibly added or updated) member, if any; C<undef> on
1104 errors.
1105 The comparison is based on C<lastModTime()> and (in the case of a
1106 non-directory) the size of the file.
1107
1108 =item addFile( $fileName [, $newName ] )
1109
1110 Append a member whose data comes from an external file,
1111 returning the member or undef. The member will have its file
1112 name set to the name of the external file, and its
1113 desiredCompressionMethod set to COMPRESSION_DEFLATED. The
1114 file attributes and last modification time will be set from
1115 the file.
1116 If the name given does not represent a readable plain file or
1117 symbolic link, undef will be returned. C<$fileName> must be
1118 in the format required for the local file system.
1119 The optional C<$newName> argument sets the internal file name
1120 to something different than the given $fileName. C<$newName>,
1121 if given, must be in Zip name format (i.e. Unix).
1122 The text mode bit will be set if the contents appears to be
1123 text (as returned by the C<-T> perl operator).
1124
1125
1126 I<NOTE> that you shouldn't (generally) use absolute path names
1127 in zip member names, as this will cause problems with some zip
1128 tools as well as introduce a security hole and make the zip
1129 harder to use.
1130
1131 =item addDirectory( $directoryName [, $fileName ] )
1132
1133
1134
1135 Append a member created from the given directory name. The
1136 directory name does not have to name an existing directory.
1137 If the named directory exists, the file modification time and
1138 permissions are set from the existing directory, otherwise
1139 they are set to now and permissive default permissions.
1140 C<$directoryName> must be in local file system format.
1141 The optional second argument sets the name of the archive
1142 member (which defaults to C<$directoryName>). If given, it
1143 must be in Zip (Unix) format.
1144 Returns the new member.
1145
1146 =item addFileOrDirectory( $name [, $newName ] )
1147
1148
1149
1150 Append a member from the file or directory named $name. If
1151 $newName is given, use it for the name of the new member.
1152 Will add or remove trailing slashes from $newName as needed.
1153 C<$name> must be in local file system format.
1154 The optional second argument sets the name of the archive
1155 member (which defaults to C<$name>). If given, it must be in
1156 Zip (Unix) format.
1157
1158 =item addString( $stringOrStringRef, $name )
1159
1160
1161
1162 Append a member created from the given string or string
1163 reference. The name is given by the second argument.
1164 Returns the new member. The last modification time will be
1165 set to now, and the file attributes will be set to permissive
1166 defaults.
1167
1168 my $member = $zip->addString( 'This is a test', 'test.txt' );
1169
1170 =item contents( $memberOrMemberName [, $newContents ] )
1171
1172
1173
1174 Returns the uncompressed data for a particular member, or
1175 undef.
1176
1177 print "xyz.txt contains " . $zip->contents( 'xyz.txt' );
1178
1179 Also can change the contents of a member:
1180
1181 $zip->contents( 'xyz.txt', 'This is the new contents' );
1182
1183 If called expecting an array as the return value, it will include
1184 the status as the second value in the array.
1185
1186 ($content, $status) = $zip->contents( 'xyz.txt');
1187
1188 =back
1189
1190 =head2 Zip Archive I/O operations
1191
1192
1193 A Zip archive can be written to a file or file handle, or read from
1194 one.
1195
1196 =over 4
1197
1198 =item writeToFileNamed( $fileName )
1199
1200
1201
1202 Write a zip archive to named file. Returns C<AZ_OK> on
1203 success.
1204
1205 my $status = $zip->writeToFileNamed( 'xx.zip' );
1206 die "error somewhere" if $status != AZ_OK;
1207
1208 Note that if you use the same name as an existing zip file
1209 that you read in, you will clobber ZipFileMembers. So
1210 instead, write to a different file name, then delete the
1211 original.
1212 If you use the C<overwrite()> or C<overwriteAs()> methods, you can
1213 re-write the original zip in this way.
1214 C<$fileName> should be a valid file name on your system.
1215
1216 =item writeToFileHandle( $fileHandle [, $seekable] )
1217
1218 Write a zip archive to a file handle. Return AZ_OK on
1219 success. The optional second arg tells whether or not to try
1220 to seek backwards to re-write headers. If not provided, it is
1221 set if the Perl C<-f> test returns true. This could fail on
1222 some operating systems, though.
1223
1224 my $fh = IO::File->new( 'someFile.zip', 'w' );
1225 unless ( $zip->writeToFileHandle( $fh ) != AZ_OK ) {
1226 # error handling
1227 }
1228
1229 If you pass a file handle that is not seekable (like if
1230 you're writing to a pipe or a socket), pass a false second
1231 argument:
1232
1233 my $fh = IO::File->new( '| cat > somefile.zip', 'w' );
1234 $zip->writeToFileHandle( $fh, 0 ); # fh is not seekable
1235
1236 If this method fails during the write of a member, that
1237 member and all following it will return false from
1238 C<wasWritten()>. See writeCentralDirectory() for a way to
1239 deal with this.
1240 If you want, you can write data to the file handle before
1241 passing it to writeToFileHandle(); this could be used (for
1242 instance) for making self-extracting archives. However, this
1243 only works reliably when writing to a real file (as opposed
1244 to STDOUT or some other possible non-file).
1245
1246 See examples/selfex.pl for how to write a self-extracting
1247 archive.
1248
1249 =item writeCentralDirectory( $fileHandle [, $offset ] )
1250
1251 Writes the central directory structure to the given file
1252 handle.
1253
1254 Returns AZ_OK on success. If given an $offset, will
1255 seek to that point before writing. This can be used for
1256 recovery in cases where writeToFileHandle or writeToFileNamed
1257 returns an IO error because of running out of space on the
1258 destination file.
1259
1260 You can truncate the zip by seeking backwards and then writing the
1261 directory:
1262
1263 my $fh = IO::File->new( 'someFile.zip', 'w' );
1264 my $retval = $zip->writeToFileHandle( $fh );
1265 if ( $retval == AZ_IO_ERROR ) {
1266 my @unwritten = grep { not $_->wasWritten() } $zip->members();
1267 if (@unwritten) {
1268 $zip->removeMember( $member ) foreach my $member ( @unwritten );
1269 $zip->writeCentralDirectory( $fh,
1270 $unwritten[0]->writeLocalHeaderRelativeOffset());
1271 }
1272 }
1273
1274 =item overwriteAs( $newName )
1275
1276 Write the zip to the specified file, as safely as possible.
1277 This is done by first writing to a temp file, then renaming
1278 the original if it exists, then renaming the temp file, then
1279 deleting the renamed original if it exists. Returns AZ_OK if
1280 successful.
1281
1282 =item overwrite()
1283
1284 Write back to the original zip file. See overwriteAs() above.
1285 If the zip was not ever read from a file, this generates an
1286 error.
1287
1288 =item read( $fileName )
1289
1290 Read zipfile headers from a zip file, appending new members.
1291 Returns C<AZ_OK> or error code.
1292
1293 my $zipFile = Archive::Zip->new();
1294 my $status = $zipFile->read( '/some/FileName.zip' );
1295
1296 =item readFromFileHandle( $fileHandle, $filename )
1297
1298 Read zipfile headers from an already-opened file handle,
1299 appending new members. Does not close the file handle.
1300 Returns C<AZ_OK> or error code. Note that this requires a
1301 seekable file handle; reading from a stream is not yet
1302 supported.
1303
1304 my $fh = IO::File->new( '/some/FileName.zip', 'r' );
1305 my $zip1 = Archive::Zip->new();
1306 my $status = $zip1->readFromFileHandle( $fh );
1307 my $zip2 = Archive::Zip->new();
1308 $status = $zip2->readFromFileHandle( $fh );
1309
1310 =back
1311
1312 =head2 Zip Archive Tree operations
1313
1314 These used to be in Archive::Zip::Tree but got moved into
1315 Archive::Zip. They enable operation on an entire tree of members or
1316 files.
1317 A usage example:
1318
1319 use Archive::Zip;
1320 my $zip = Archive::Zip->new();
1321
1322 # add all readable files and directories below . as xyz/*
1323 $zip->addTree( '.', 'xyz' );
1324
1325 # add all readable plain files below /abc as def/*
1326 $zip->addTree( '/abc', 'def', sub { -f && -r } );
1327
1328 # add all .c files below /tmp as stuff/*
1329 $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
1330
1331 # add all .o files below /tmp as stuff/* if they aren't writable
1332 $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
1333
1334 # add all .so files below /tmp that are smaller than 200 bytes as stuff/*
1335 $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
1336
1337 # and write them into a file
1338 $zip->writeToFileNamed('xxx.zip');
1339
1340 # now extract the same files into /tmpx
1341 $zip->extractTree( 'stuff', '/tmpx' );
1342
1343 =over 4
1344
1345 =item $zip->addTree( $root, $dest [,$pred] ) -- Add tree of files to a zip
1346
1347 C<$root> is the root of the tree of files and directories to be
1348 added. It is a valid directory name on your system. C<$dest> is
1349 the name for the root in the zip file (undef or blank means
1350 to use relative pathnames). It is a valid ZIP directory name
1351 (that is, it uses forward slashes (/) for separating
1352 directory components). C<$pred> is an optional subroutine
1353 reference to select files: it is passed the name of the
1354 prospective file or directory using C<$_>, and if it returns
1355 true, the file or directory will be included. The default is
1356 to add all readable files and directories. For instance,
1357 using
1358
1359 my $pred = sub { /\.txt/ };
1360 $zip->addTree( '.', '', $pred );
1361
1362 will add all the .txt files in and below the current
1363 directory, using relative names, and making the names
1364 identical in the zipfile:
1365
1366 original name zip member name
1367 ./xyz xyz
1368 ./a/ a/
1369 ./a/b a/b
1370
1371 To translate absolute to relative pathnames, just pass them
1372 in: $zip->addTree( '/c/d', 'a' );
1373
1374 original name zip member name
1375 /c/d/xyz a/xyz
1376 /c/d/a/ a/a/
1377 /c/d/a/b a/a/b
1378
1379 Returns AZ_OK on success. Note that this will not follow
1380 symbolic links to directories. Note also that this does not
1381 check for the validity of filenames.
1382
1383 Note that you generally I<don't> want to make zip archive member names
1384 absolute.
1385
1386 =item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] )
1387
1388 $root is the root of the tree of files and directories to be
1389 added $dest is the name for the root in the zip file (undef
1390 means to use relative pathnames) $pattern is a (non-anchored)
1391 regular expression for filenames to match $pred is an
1392 optional subroutine reference to select files: it is passed
1393 the name of the prospective file or directory in C<$_>, and
1394 if it returns true, the file or directory will be included.
1395 The default is to add all readable files and directories. To
1396 add all files in and below the current dirctory whose names
1397 end in C<.pl>, and make them extract into a subdirectory
1398 named C<xyz>, do this:
1399
1400 $zip->addTreeMatching( '.', 'xyz', '\.pl$' )
1401
1402 To add all I<writable> files in and below the dirctory named
1403 C</abc> whose names end in C<.pl>, and make them extract into
1404 a subdirectory named C<xyz>, do this:
1405
1406 $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } )
1407
1408 Returns AZ_OK on success. Note that this will not follow
1409 symbolic links to directories.
1410
1411 =item $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
1412
1413
1414
1415 Update a zip file from a directory tree.
1416
1417 C<updateTree()> takes the same arguments as C<addTree()>, but first
1418 checks to see whether the file or directory already exists in the zip
1419 file, and whether it has been changed.
1420
1421 If the fourth argument C<$mirror> is true, then delete all my members
1422 if corresponding files weren't found.
1423
1424
1425 Returns an error code or AZ_OK if all is well.
1426
1427 =item $zip->extractTree()
1428
1429
1430
1431 =item $zip->extractTree( $root )
1432
1433
1434
1435 =item $zip->extractTree( $root, $dest )
1436
1437
1438
1439 =item $zip->extractTree( $root, $dest, $volume )
1440
1441
1442
1443 If you don't give any arguments at all, will extract all the
1444 files in the zip with their original names.
1445
1446
1447 If you supply one argument for C<$root>, C<extractTree> will extract
1448 all the members whose names start with C<$root> into the current
1449 directory, stripping off C<$root> first.
1450 C<$root> is in Zip (Unix) format.
1451 For instance,
1452
1453 $zip->extractTree( 'a' );
1454
1455 when applied to a zip containing the files:
1456 a/x a/b/c ax/d/e d/e will extract:
1457
1458
1459 a/x as ./x
1460
1461
1462 a/b/c as ./b/c
1463
1464
1465 If you give two arguments, C<extractTree> extracts all the members
1466 whose names start with C<$root>. It will translate C<$root> into
1467 C<$dest> to construct the destination file name.
1468 C<$root> and C<$dest> are in Zip (Unix) format.
1469 For instance,
1470
1471 $zip->extractTree( 'a', 'd/e' );
1472
1473 when applied to a zip containing the files:
1474 a/x a/b/c ax/d/e d/e will extract:
1475
1476
1477 a/x to d/e/x
1478
1479
1480 a/b/c to d/e/b/c and ignore ax/d/e and d/e
1481
1482
1483 If you give three arguments, C<extractTree> extracts all the members
1484 whose names start with C<$root>. It will translate C<$root> into
1485 C<$dest> to construct the destination file name, and then it will
1486 convert to local file system format, using C<$volume> as the name of
1487 the destination volume.
1488
1489
1490 C<$root> and C<$dest> are in Zip (Unix) format.
1491
1492
1493 C<$volume> is in local file system format.
1494
1495
1496 For instance, under Windows,
1497
1498 $zip->extractTree( 'a', 'd/e', 'f:' );
1499
1500 when applied to a zip containing the files:
1501 a/x a/b/c ax/d/e d/e will extract:
1502
1503
1504 a/x to f:d/e/x
1505
1506
1507 a/b/c to f:d/e/b/c and ignore ax/d/e and d/e
1508
1509
1510 If you want absolute paths (the prior example used paths relative to
1511 the current directory on the destination volume, you can specify these
1512 in C<$dest>:
1513
1514 $zip->extractTree( 'a', '/d/e', 'f:' );
1515
1516 when applied to a zip containing the files:
1517 a/x a/b/c ax/d/e d/e will extract:
1518
1519
1520 a/x to f:\d\e\x
1521
1522
1523 a/b/c to f:\d\e\b\c and ignore ax/d/e and d/e
1524
1525 Returns an error code or AZ_OK if everything worked OK.
1526
1527 =back
1528
1529 =head1 MEMBER OPERATIONS
1530
1531
1532 =head2 Member Class Methods
1533
1534
1535 Several constructors allow you to construct members without adding
1536 them to a zip archive. These work the same as the addFile(),
1537 addDirectory(), and addString() zip instance methods described above,
1538 but they don't add the new members to a zip.
1539
1540 =over 4
1541
1542 =item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName] )
1543
1544
1545
1546 Construct a new member from the given string. Returns undef
1547 on error.
1548
1549 my $member = Archive::Zip::Member->newFromString( 'This is a test',
1550 'xyz.txt' );
1551
1552 =item newFromFile( $fileName )
1553
1554
1555
1556 Construct a new member from the given file. Returns undef on
1557 error.
1558
1559 my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' );
1560
1561 =item newDirectoryNamed( $directoryName [, $zipname ] )
1562
1563
1564
1565 Construct a new member from the given directory.
1566 C<$directoryName> must be a valid name on your file system; it doesn't
1567 have to exist.
1568
1569
1570 If given, C<$zipname> will be the name of the zip member; it must be a
1571 valid Zip (Unix) name. If not given, it will be converted from
1572 C<$directoryName>.
1573
1574
1575 Returns undef on error.
1576
1577 my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' );
1578
1579 =back
1580
1581 =head2 Member Simple accessors
1582
1583
1584 These methods get (and/or set) member attribute values.
1585
1586 =over 4
1587
1588 =item versionMadeBy()
1589
1590
1591
1592 Gets the field from the member header.
1593
1594 =item fileAttributeFormat( [$format] )
1595
1596
1597
1598 Gets or sets the field from the member header. These are
1599 C<FA_*> values.
1600
1601 =item versionNeededToExtract()
1602
1603
1604
1605 Gets the field from the member header.
1606
1607 =item bitFlag()
1608
1609
1610
1611 Gets the general purpose bit field from the member header.
1612 This is where the C<GPBF_*> bits live.
1613
1614 =item compressionMethod()
1615
1616
1617
1618 Returns the member compression method. This is the method
1619 that is currently being used to compress the member data.
1620 This will be COMPRESSION_STORED for added string or file
1621 members, or any of the C<COMPRESSION_*> values for members
1622 from a zip file. However, this module can only handle members
1623 whose data is in COMPRESSION_STORED or COMPRESSION_DEFLATED
1624 format.
1625
1626 =item desiredCompressionMethod( [$method] )
1627
1628
1629
1630 Get or set the member's C<desiredCompressionMethod>. This is
1631 the compression method that will be used when the member is
1632 written. Returns prior desiredCompressionMethod. Only
1633 COMPRESSION_DEFLATED or COMPRESSION_STORED are valid
1634 arguments. Changing to COMPRESSION_STORED will change the
1635 member desiredCompressionLevel to 0; changing to
1636 COMPRESSION_DEFLATED will change the member
1637 desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT.
1638
1639 =item desiredCompressionLevel( [$method] )
1640
1641
1642
1643 Get or set the member's desiredCompressionLevel This is the
1644 method that will be used to write. Returns prior
1645 desiredCompressionLevel. Valid arguments are 0 through 9,
1646 COMPRESSION_LEVEL_NONE, COMPRESSION_LEVEL_DEFAULT,
1647 COMPRESSION_LEVEL_BEST_COMPRESSION, and
1648 COMPRESSION_LEVEL_FASTEST. 0 or COMPRESSION_LEVEL_NONE will
1649 change the desiredCompressionMethod to COMPRESSION_STORED.
1650 All other arguments will change the desiredCompressionMethod
1651 to COMPRESSION_DEFLATED.
1652
1653 =item externalFileName()
1654
1655
1656
1657 Return the member's external file name, if any, or undef.
1658
1659 =item fileName()
1660
1661
1662
1663 Get or set the member's internal filename. Returns the
1664 (possibly new) filename. Names will have backslashes
1665 converted to forward slashes, and will have multiple
1666 consecutive slashes converted to single ones.
1667
1668 =item lastModFileDateTime()
1669
1670
1671
1672 Return the member's last modification date/time stamp in
1673 MS-DOS format.
1674
1675 =item lastModTime()
1676
1677
1678
1679 Return the member's last modification date/time stamp,
1680 converted to unix localtime format.
1681
1682 print "Mod Time: " . scalar( localtime( $member->lastModTime() ) );
1683
1684 =item setLastModFileDateTimeFromUnix()
1685
1686 Set the member's lastModFileDateTime from the given unix
1687 time.
1688
1689 $member->setLastModFileDateTimeFromUnix( time() );
1690
1691 =item internalFileAttributes()
1692
1693 Return the internal file attributes field from the zip
1694 header. This is only set for members read from a zip file.
1695
1696 =item externalFileAttributes()
1697
1698 Return member attributes as read from the ZIP file. Note that
1699 these are NOT UNIX!
1700
1701 =item unixFileAttributes( [$newAttributes] )
1702
1703 Get or set the member's file attributes using UNIX file
1704 attributes. Returns old attributes.
1705
1706 my $oldAttribs = $member->unixFileAttributes( 0666 );
1707
1708 Note that the return value has more than just the file
1709 permissions, so you will have to mask off the lowest bits for
1710 comparisions.
1711
1712 =item localExtraField( [$newField] )
1713
1714 Gets or sets the extra field that was read from the local
1715 header. This is not set for a member from a zip file until
1716 after the member has been written out. The extra field must
1717 be in the proper format.
1718
1719 =item cdExtraField( [$newField] )
1720
1721 Gets or sets the extra field that was read from the central
1722 directory header. The extra field must be in the proper
1723 format.
1724
1725 =item extraFields()
1726
1727 Return both local and CD extra fields, concatenated.
1728
1729 =item fileComment( [$newComment] )
1730
1731 Get or set the member's file comment.
1732
1733 =item hasDataDescriptor()
1734
1735 Get or set the data descriptor flag. If this is set, the
1736 local header will not necessarily have the correct data
1737 sizes. Instead, a small structure will be stored at the end
1738 of the member data with these values. This should be
1739 transparent in normal operation.
1740
1741 =item crc32()
1742
1743 Return the CRC-32 value for this member. This will not be set
1744 for members that were constructed from strings or external
1745 files until after the member has been written.
1746
1747 =item crc32String()
1748
1749 Return the CRC-32 value for this member as an 8 character
1750 printable hex string. This will not be set for members that
1751 were constructed from strings or external files until after
1752 the member has been written.
1753
1754 =item compressedSize()
1755
1756 Return the compressed size for this member. This will not be
1757 set for members that were constructed from strings or
1758 external files until after the member has been written.
1759
1760 =item uncompressedSize()
1761
1762 Return the uncompressed size for this member.
1763
1764 =item isEncrypted()
1765
1766 Return true if this member is encrypted. The Archive::Zip
1767 module does not currently create or extract encrypted
1768 members.
1769
1770 =item isTextFile( [$flag] )
1771
1772 Returns true if I am a text file. Also can set the status if
1773 given an argument (then returns old state). Note that this
1774 module does not currently do anything with this flag upon
1775 extraction or storage. That is, bytes are stored in native
1776 format whether or not they came from a text file.
1777
1778 =item isBinaryFile()
1779
1780 Returns true if I am a binary file. Also can set the status
1781 if given an argument (then returns old state). Note that this
1782 module does not currently do anything with this flag upon
1783 extraction or storage. That is, bytes are stored in native
1784 format whether or not they came from a text file.
1785
1786 =item extractToFileNamed( $fileName )
1787
1788 Extract me to a file with the given name. The file will be
1789 created with default modes. Directories will be created as
1790 needed.
1791 The C<$fileName> argument should be a valid file name on your
1792 file system.
1793 Returns AZ_OK on success.
1794
1795 =item isDirectory()
1796
1797 Returns true if I am a directory.
1798
1799 =item writeLocalHeaderRelativeOffset()
1800
1801 Returns the file offset in bytes the last time I was written.
1802
1803 =item wasWritten()
1804
1805 Returns true if I was successfully written. Reset at the
1806 beginning of a write attempt.
1807
1808 =back
1809
1810 =head2 Low-level member data reading
1811
1812 It is possible to use lower-level routines to access member data
1813 streams, rather than the extract* methods and contents(). For
1814 instance, here is how to print the uncompressed contents of a member
1815 in chunks using these methods:
1816
1817 my ( $member, $status, $bufferRef );
1818 $member = $zip->memberNamed( 'xyz.txt' );
1819 $member->desiredCompressionMethod( COMPRESSION_STORED );
1820 $status = $member->rewindData();
1821 die "error $status" unless $status == AZ_OK;
1822 while ( ! $member->readIsDone() )
1823 {
1824 ( $bufferRef, $status ) = $member->readChunk();
1825 die "error $status"
1826 if $status != AZ_OK && $status != AZ_STREAM_END;
1827 # do something with $bufferRef:
1828 print $$bufferRef;
1829 }
1830 $member->endRead();
1831
1832 =over 4
1833
1834 =item readChunk( [$chunkSize] )
1835
1836 This reads the next chunk of given size from the member's
1837 data stream and compresses or uncompresses it as necessary,
1838 returning a reference to the bytes read and a status. If size
1839 argument is not given, defaults to global set by
1840 Archive::Zip::setChunkSize. Status is AZ_OK on success until
1841 the last chunk, where it returns AZ_STREAM_END. Returns C<(
1842 \$bytes, $status)>.
1843
1844 my ( $outRef, $status ) = $self->readChunk();
1845 print $$outRef if $status != AZ_OK && $status != AZ_STREAM_END;
1846
1847 =item rewindData()
1848
1849 Rewind data and set up for reading data streams or writing
1850 zip files. Can take options for C<inflateInit()> or
1851 C<deflateInit()>, but this isn't likely to be necessary.
1852 Subclass overrides should call this method. Returns C<AZ_OK>
1853 on success.
1854
1855 =item endRead()
1856
1857 Reset the read variables and free the inflater or deflater.
1858 Must be called to close files, etc. Returns AZ_OK on success.
1859
1860 =item readIsDone()
1861
1862 Return true if the read has run out of data or errored out.
1863
1864 =item contents()
1865
1866 Return the entire uncompressed member data or undef in scalar
1867 context. When called in array context, returns C<( $string,
1868 $status )>; status will be AZ_OK on success:
1869
1870 my $string = $member->contents();
1871 # or
1872 my ( $string, $status ) = $member->contents();
1873 die "error $status" unless $status == AZ_OK;
1874
1875 Can also be used to set the contents of a member (this may
1876 change the class of the member):
1877
1878 $member->contents( "this is my new contents" );
1879
1880 =item extractToFileHandle( $fh )
1881
1882 Extract (and uncompress, if necessary) the member's contents
1883 to the given file handle. Return AZ_OK on success.
1884
1885 =back
1886
1887 =head1 Archive::Zip::FileMember methods
1888
1889 The Archive::Zip::FileMember class extends Archive::Zip::Member. It is the
1890 base class for both ZipFileMember and NewFileMember classes. This class adds
1891 an C<externalFileName> and an C<fh> member to keep track of the external
1892 file.
1893
1894 =over 4
1895
1896 =item externalFileName()
1897
1898 Return the member's external filename.
1899
1900 =item fh()
1901
1902 Return the member's read file handle. Automatically opens file if
1903 necessary.
1904
1905 =back
1906
1907 =head1 Archive::Zip::ZipFileMember methods
1908
1909 The Archive::Zip::ZipFileMember class represents members that have been read
1910 from external zip files.
1911
1912 =over 4
1913
1914 =item diskNumberStart()
1915
1916 Returns the disk number that the member's local header resides in.
1917 Should be 0.
1918
1919 =item localHeaderRelativeOffset()
1920
1921 Returns the offset into the zip file where the member's local header
1922 is.
1923
1924 =item dataOffset()
1925
1926 Returns the offset from the beginning of the zip file to the member's
1927 data.
1928
1929 =back
1930
1931 =head1 REQUIRED MODULES
1932
1933 L<Archive::Zip> requires several other modules:
1934
1935 L<Carp>
1936
1937 L<Compress::Zlib>
1938
1939 L<Cwd>
1940
1941 L<File::Basename>
1942
1943 L<File::Copy>
1944
1945 L<File::Find>
1946
1947 L<File::Path>
1948
1949 L<File::Spec>
1950
1951 L<File::Spec>
1952
1953 L<IO::File>
1954
1955 L<IO::Seekable>
1956
1957 L<Time::Local>
1958
1959 =head1 BUGS AND CAVEATS
1960
1961 =head2 When not to use Archive::Zip
1962
1963 If you are just going to be extracting zips (and/or other archives) you
1964 are recommended to look at using L<Archive::Extract> instead, as it is much
1965 easier to use and factors out archive-specific functionality.
1966
1967 =head2 Try to avoid IO::Scalar
1968
1969 One of the most common ways to use Archive::Zip is to generate Zip files
1970 in-memory. Most people have use L<IO::Scalar> for this purpose.
1971
1972 Unfortunately, as of 1.11 this module no longer works with L<IO::Scalar>
1973 as it incorrectly implements seeking.
1974
1975 Anybody using L<IO::Scalar> should consider porting to L<IO::String>,
1976 which is smaller, lighter, and is implemented to be perfectly compatible
1977 with regular seekable filehandles.
1978
1979 Support for L<IO::Scalar> most likely will B<not> be restored in the
1980 future, as L<IO::Scalar> itself cannot change the way it is implemented
1981 due to back-compatibility issues.
1982
1983 =head1 TO DO
1984
1985 * auto-choosing storing vs compression
1986
1987 * extra field hooks (see notes.txt)
1988
1989 * check for dups on addition/renaming?
1990
1991 * Text file extraction (line end translation)
1992
1993 * Reading zip files from non-seekable inputs
1994 (Perhaps by proxying through IO::String?)
1995
1996 * separate unused constants into separate module
1997
1998 * cookbook style docs
1999
2000 * Handle tainted paths correctly
2001
2002 * Work on better compatability with other IO:: modules
2003
2004 =head1 SUPPORT
2005
2006 Bugs should be reported via the CPAN bug tracker
2007
2008 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Archive-Zip>
2009
2010 For other issues contact the maintainer
2011
2012 =head1 AUTHOR
2013
2014 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
2015
2016 Previously maintained by Steve Peters E<lt>steve@fisharerojo.orgE<gt>.
2017
2018 File attributes code by Maurice Aubrey E<lt>maurice@lovelyfilth.comE<gt>.
2019
2020 Originally by Ned Konz E<lt>nedkonz@cpan.orgE<gt>.
2021
2022 =head1 COPYRIGHT
2023
2024 Copyright (c) 2000-2004 Ned Konz. All rights reserved.
2025
2026 Some parts copyright (c) 2005 Steve Peters. All rights reserved.
2027
2028 Some parts copyright (c) 2006 Adam Kennedy. All rights reserved.
2029
2030 This program is free software; you can redistribute it and/or modify it
2031 under the same terms as Perl itself.
2032
2033 =head1 SEE ALSO
2034
2035 L<Compress::Zlib>, L<Archive::Tar>, L<Archive::Extract>
2036
2037 There is a Japanese translation of this
2038 document at L<http://www.memb.jp/~deq/perl/doc-ja/Archive-Zip.html> that
2039 was done by DEQ E<lt>deq@oct.zaq.ne.jpE<gt> . Thanks!
2040
2041 =cut
+6
-0
t/01_compile.t less more
0 #!/usr/bin/perl -w
1
2 use Test::More tests => 2;
3
4 use_ok( 'Archive::Zip' );
5 use_ok( 'Archive::Zip::MemberRead' );
+581
-0
t/02_main.t less more
0 #!/usr/bin/perl -w
1
2 # Main testing for Archive::Zip
3
4 use strict;
5 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
6 use FileHandle;
7 use File::Path;
8 use File::Spec;
9
10 use Test::More tests => 141;
11
12 BEGIN {
13 unshift @INC, "t/";
14 require( File::Spec->catfile('t', 'common.pl') )
15 or die "Can't load t/common.pl";
16 }
17
18
19
20
21
22 #####################################################################
23 # Testing Utility Functions
24
25 #--------- check CRC
26 is(TESTSTRINGCRC, 0xac373f32, 'Testing CRC matches expected');
27
28 # Bad times die
29 SCOPE: {
30 my @errors = ();
31 local $Archive::Zip::ErrorHandler = sub { push @errors, @_ };
32 eval { Archive::Zip::Member::_unixToDosTime( 0 ) };
33 ok( $errors[0] =~ /Tried to add member with zero or undef/,
34 'Got expected _unixToDosTime error' );
35 }
36
37 #--------- check time conversion
38
39 foreach my $unix_time (
40 315576062, 315576064, 315580000, 315600000,
41 316000000, 320000000, 400000000, 500000000,
42 600000000, 700000000, 800000000, 900000000,
43 1000000000, 1100000000, 1200000000,
44 int(time()/2)*2,
45 ) {
46 my $dos_time = Archive::Zip::Member::_unixToDosTime( $unix_time );
47 my $round_trip = Archive::Zip::Member::_dosToUnixTime( $dos_time );
48 is( $unix_time, $round_trip, 'Got expected DOS DateTime value' );
49 }
50
51
52
53
54
55 #####################################################################
56 # Testing Archives
57
58 #--------- empty file
59 # new # Archive::Zip
60 # new # Archive::Zip::Archive
61 my $zip = Archive::Zip->new();
62 isa_ok( $zip, 'Archive::Zip' );
63
64 # members # Archive::Zip::Archive
65 my @members = $zip->members;
66 is(scalar(@members), 0, '->members is 0' );
67
68 # numberOfMembers # Archive::Zip::Archive
69 my $numberOfMembers = $zip->numberOfMembers();
70 is($numberOfMembers, 0, '->numberofMembers is 0' );
71
72 # writeToFileNamed # Archive::Zip::Archive
73 my $status = $zip->writeToFileNamed( OUTPUTZIP );
74 is($status, AZ_OK, '->writeToFileNames ok' );
75
76 my $zipout;
77 SKIP: {
78 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
79 if ( $^O eq 'MSWin32' ) {
80 print STDERR "\n# You might see an expected 'zipfile is empty' warning now.\n";
81 }
82 ($status, $zipout) = testZip();
83 # STDERR->print("status= $status, out=$zipout\n");
84
85 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
86 ok( $status != 0 );
87 }
88 # unzip -t returns error code=1 for warning on empty
89
90 #--------- add a directory
91 my $memberName = TESTDIR . '/';
92 my $dirName = TESTDIR;
93
94 # addDirectory # Archive::Zip::Archive
95 # new # Archive::Zip::Member
96 my $member = $zip->addDirectory($memberName);
97 ok(defined($member));
98 is($member->fileName(), $memberName);
99
100 # On some (Windows systems) the modification time is
101 # corrupted. Save this to check late.
102 my $dir_time = $member->lastModFileDateTime();
103
104 # members # Archive::Zip::Archive
105 @members = $zip->members();
106 is(scalar(@members), 1);
107 is($members[0], $member);
108
109 # numberOfMembers # Archive::Zip::Archive
110 $numberOfMembers = $zip->numberOfMembers();
111 is($numberOfMembers, 1);
112
113 # writeToFileNamed # Archive::Zip::Archive
114 $status = $zip->writeToFileNamed( OUTPUTZIP );
115 is($status, AZ_OK);
116
117 # Does the modification time get corrupted?
118 is( ($zip->members)[0]->lastModFileDateTime(), $dir_time );
119
120 SKIP: {
121 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
122 ($status, $zipout) = testZip();
123 # STDERR->print("status= $status, out=$zipout\n");
124 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
125 is( $status, 0 );
126 }
127
128 #--------- extract the directory by name
129 rmtree([ TESTDIR ], 0, 0);
130 $status = $zip->extractMember($memberName);
131 is($status, AZ_OK);
132 ok(-d $dirName);
133
134 #--------- extract the directory by identity
135 ok(rmdir($dirName)); # it's still empty
136 $status = $zip->extractMember($member);
137 is($status, AZ_OK);
138 ok(-d $dirName);
139
140 #--------- add a string member, uncompressed
141 $memberName = TESTDIR . '/string.txt';
142 # addString # Archive::Zip::Archive
143 # newFromString # Archive::Zip::Member
144 $member = $zip->addString(TESTSTRING, $memberName);
145 ok(defined($member));
146
147 is($member->fileName(), $memberName);
148
149 # members # Archive::Zip::Archive
150 @members = $zip->members();
151 is(scalar(@members), 2);
152 is($members[1], $member);
153
154 # numberOfMembers # Archive::Zip::Archive
155 $numberOfMembers = $zip->numberOfMembers();
156 is($numberOfMembers, 2);
157
158 # writeToFileNamed # Archive::Zip::Archive
159 $status = $zip->writeToFileNamed( OUTPUTZIP );
160 is($status, AZ_OK);
161
162 SKIP: {
163 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
164 ($status, $zipout) = testZip();
165 # STDERR->print("status= $status, out=$zipout\n");
166 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
167 is( $status, 0 );
168 }
169
170 is($member->crc32(), TESTSTRINGCRC);
171
172 is($member->crc32String(), sprintf("%08x", TESTSTRINGCRC));
173
174 #--------- extract it by name
175 $status = $zip->extractMember($memberName);
176 is($status, AZ_OK);
177 ok(-f $memberName);
178 is(fileCRC($memberName), TESTSTRINGCRC);
179
180 #--------- now compress it and re-test
181 my $oldCompressionMethod =
182 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
183 is($oldCompressionMethod, COMPRESSION_STORED, 'old compression method OK');
184
185 # writeToFileNamed # Archive::Zip::Archive
186 $status = $zip->writeToFileNamed( OUTPUTZIP );
187 is($status, AZ_OK, 'writeToFileNamed returns AZ_OK');
188 is($member->crc32(), TESTSTRINGCRC);
189 is($member->uncompressedSize(), TESTSTRINGLENGTH);
190
191 SKIP: {
192 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
193 ($status, $zipout) = testZip();
194 # STDERR->print("status= $status, out=$zipout\n");
195 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
196 is( $status, 0 );
197 }
198
199 #--------- extract it by name
200 $status = $zip->extractMember($memberName);
201 is($status, AZ_OK);
202 ok(-f $memberName);
203 is(fileCRC($memberName), TESTSTRINGCRC);
204
205 #--------- add a file member, compressed
206 ok(rename($memberName, TESTDIR . '/file.txt'));
207 $memberName = TESTDIR . '/file.txt';
208
209 # addFile # Archive::Zip::Archive
210 # newFromFile # Archive::Zip::Member
211 $member = $zip->addFile($memberName);
212 ok(defined($member));
213
214 is($member->desiredCompressionMethod(), COMPRESSION_DEFLATED);
215
216 # writeToFileNamed # Archive::Zip::Archive
217 $status = $zip->writeToFileNamed( OUTPUTZIP );
218 is($status, AZ_OK);
219 is($member->crc32(), TESTSTRINGCRC);
220 is($member->uncompressedSize(), TESTSTRINGLENGTH);
221
222 SKIP: {
223 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
224 ($status, $zipout) = testZip();
225 # STDERR->print("status= $status, out=$zipout\n");
226 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
227 is( $status, 0 );
228 }
229
230 #--------- extract it by name (note we have to rename it first
231 #--------- or we will clobber the original file
232 my $newName = $memberName;
233 $newName =~ s/\.txt/2.txt/;
234 $status = $zip->extractMember($memberName, $newName);
235 is($status, AZ_OK);
236 ok(-f $newName);
237 is(fileCRC($newName), TESTSTRINGCRC);
238
239 #--------- now make it uncompressed and re-test
240 $oldCompressionMethod =
241 $member->desiredCompressionMethod(COMPRESSION_STORED);
242
243 is($oldCompressionMethod, COMPRESSION_DEFLATED);
244
245 # writeToFileNamed # Archive::Zip::Archive
246 $status = $zip->writeToFileNamed( OUTPUTZIP );
247 is($status, AZ_OK);
248 is($member->crc32(), TESTSTRINGCRC);
249 is($member->uncompressedSize(), TESTSTRINGLENGTH);
250
251 SKIP: {
252 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
253 ($status, $zipout) = testZip();
254 # STDERR->print("status= $status, out=$zipout\n");
255 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
256 is( $status, 0 );
257 }
258
259 #--------- extract it by name
260 $status = $zip->extractMember($memberName, $newName);
261 is($status, AZ_OK);
262 ok(-f $newName);
263 is(fileCRC($newName), TESTSTRINGCRC);
264
265 # Now, the contents of OUTPUTZIP are:
266 # Length Method Size Ratio Date Time CRC-32 Name
267 #-------- ------ ------- ----- ---- ---- ------ ----
268 # 0 Stored 0 0% 03-17-00 11:16 00000000 testDir/
269 # 300 Defl:N 146 51% 03-17-00 11:16 ac373f32 testDir/string.txt
270 # 300 Stored 300 0% 03-17-00 11:16 ac373f32 testDir/file.txt
271 #-------- ------- --- -------
272 # 600 446 26% 3 files
273
274 # members # Archive::Zip::Archive
275 @members = $zip->members();
276 is(scalar(@members), 3);
277 is($members[2], $member);
278
279 # memberNames # Archive::Zip::Archive
280 my @memberNames = $zip->memberNames();
281 is(scalar(@memberNames), 3);
282 is($memberNames[2], $memberName);
283
284 # memberNamed # Archive::Zip::Archive
285 is($zip->memberNamed($memberName), $member);
286
287 # membersMatching # Archive::Zip::Archive
288 @members = $zip->membersMatching('file');
289 is(scalar(@members), 1);
290 is($members[0], $member);
291
292 @members = $zip->membersMatching('.txt$');
293 is(scalar(@members), 2);
294 is($members[1], $member);
295
296 #--------- remove the string member and test the file
297 # removeMember # Archive::Zip::Archive
298 $member = $zip->removeMember($members[0]);
299 is($member, $members[0]);
300
301 $status = $zip->writeToFileNamed( OUTPUTZIP );
302 is($status, AZ_OK);
303
304 SKIP: {
305 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
306 ($status, $zipout) = testZip();
307 # STDERR->print("status= $status, out=$zipout\n");
308 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
309 is( $status, 0 );
310 }
311
312 #--------- add the string member at the end and test the file
313 # addMember # Archive::Zip::Archive
314 $zip->addMember($member);
315 @members = $zip->members();
316
317 is(scalar(@members), 3);
318 is($members[2], $member);
319
320 # memberNames # Archive::Zip::Archive
321 @memberNames = $zip->memberNames();
322 is(scalar(@memberNames), 3);
323 is($memberNames[1], $memberName);
324
325 $status = $zip->writeToFileNamed( OUTPUTZIP );
326 is($status, AZ_OK);
327
328 SKIP: {
329 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
330 ($status, $zipout) = testZip();
331 # STDERR->print("status= $status, out=$zipout\n");
332 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
333 is( $status, 0 );
334 }
335
336 #--------- remove the file member
337 $member = $zip->removeMember($members[1]);
338 is($member, $members[1]);
339 is($zip->numberOfMembers(), 2);
340
341 #--------- replace the string member with the file member
342 # replaceMember # Archive::Zip::Archive
343 $member = $zip->replaceMember($members[2], $member);
344 is($member, $members[2]);
345 is($zip->numberOfMembers(), 2);
346
347 #--------- re-add the string member
348 $zip->addMember($member);
349 is($zip->numberOfMembers(), 3);
350
351 @members = $zip->members();
352 $status = $zip->writeToFileNamed( OUTPUTZIP );
353 is($status, AZ_OK);
354
355 SKIP: {
356 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
357 ($status, $zipout) = testZip();
358 # STDERR->print("status= $status, out=$zipout\n");
359 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
360 is( $status, 0 );
361 }
362
363 #--------- add compressed file
364 $member = $zip->addFile(File::Spec->catfile(TESTDIR, 'file.txt'));
365 ok(defined($member));
366 $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
367 $member->fileName(TESTDIR . '/fileC.txt');
368
369 #--------- add uncompressed string
370 $member = $zip->addString(TESTSTRING, TESTDIR . '/stringU.txt');
371 ok(defined($member));
372 $member->desiredCompressionMethod(COMPRESSION_STORED);
373
374 # Now, the file looks like this:
375 # Length Method Size Ratio Date Time CRC-32 Name
376 #-------- ------ ------- ----- ---- ---- ------ ----
377 # 0 Stored 0 0% 03-17-00 12:30 00000000 testDir/
378 # 300 Stored 300 0% 03-17-00 12:30 ac373f32 testDir/file.txt
379 # 300 Defl:N 146 51% 03-17-00 12:30 ac373f32 testDir/string.txt
380 # 300 Stored 300 0% 03-17-00 12:30 ac373f32 testDir/stringU.txt
381 # 300 Defl:N 146 51% 03-17-00 12:30 ac373f32 testDir/fileC.txt
382 #-------- ------- --- -------
383 # 1200 892 26% 5 files
384
385 @members = $zip->members();
386 $numberOfMembers = $zip->numberOfMembers();
387 is($numberOfMembers, 5);
388
389 #--------- make sure the contents of the stored file member are OK.
390 # contents # Archive::Zip::Archive
391 is($zip->contents($members[1]), TESTSTRING);
392
393 # contents # Archive::Zip::Member
394 is($members[1]->contents(), TESTSTRING);
395
396 #--------- make sure the contents of the compressed string member are OK.
397 is($members[2]->contents(), TESTSTRING);
398
399 #--------- make sure the contents of the stored string member are OK.
400 is($members[3]->contents(), TESTSTRING);
401
402 #--------- make sure the contents of the compressed file member are OK.
403 is($members[4]->contents(), TESTSTRING);
404
405 #--------- write to INPUTZIP
406 $status = $zip->writeToFileNamed( INPUTZIP );
407 is($status, AZ_OK);
408
409 SKIP: {
410 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
411 ($status, $zipout) = testZip(INPUTZIP);
412 # STDERR->print("status= $status, out=$zipout\n");
413 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
414 is( $status, 0 );
415 }
416
417 #--------- read from INPUTZIP (appending its entries)
418 # read # Archive::Zip::Archive
419 $status = $zip->read(INPUTZIP);
420 is($status, AZ_OK);
421 is($zip->numberOfMembers(), 10);
422
423 #--------- clean up duplicate names
424 @members = $zip->members();
425 $member = $zip->removeMember($members[5]);
426 is($member->fileName(), TESTDIR . '/');
427
428 SCOPE: {
429 for my $i (6..9)
430 {
431 $memberName = $members[$i]->fileName();
432 $memberName =~ s/\.txt/2.txt/;
433 $members[$i]->fileName($memberName);
434 }
435 }
436 is(scalar($zip->membersMatching('2.txt')), 4);
437
438 #--------- write zip out and test it.
439 $status = $zip->writeToFileNamed( OUTPUTZIP );
440 is($status, AZ_OK);
441
442 SKIP: {
443 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
444 ($status, $zipout) = testZip();
445 # STDERR->print("status= $status, out=$zipout\n");
446 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
447 is( $status, 0 );
448 }
449
450 #--------- Make sure that we haven't renamed files (this happened!)
451 is(scalar($zip->membersMatching('2\.txt$')), 4);
452
453 #--------- Now try extracting everyone
454 @members = $zip->members();
455 is($zip->extractMember($members[0]), AZ_OK); #DM
456 is($zip->extractMember($members[1]), AZ_OK); #NFM
457 is($zip->extractMember($members[2]), AZ_OK);
458 is($zip->extractMember($members[3]), AZ_OK); #NFM
459 is($zip->extractMember($members[4]), AZ_OK);
460 is($zip->extractMember($members[5]), AZ_OK);
461 is($zip->extractMember($members[6]), AZ_OK);
462 is($zip->extractMember($members[7]), AZ_OK);
463 is($zip->extractMember($members[8]), AZ_OK);
464
465 #--------- count dirs
466 {
467 my @dirs = grep { $_->isDirectory() } @members;
468 is(scalar(@dirs), 1);
469 is($dirs[0], $members[0]);
470 }
471
472 #--------- count binary and text files
473 {
474 my @binaryFiles = grep { $_->isBinaryFile() } @members;
475 my @textFiles = grep { $_->isTextFile() } @members;
476 is(scalar(@binaryFiles), 5);
477 is(scalar(@textFiles), 4);
478 }
479
480 #--------- Try writing zip file to file handle
481 {
482 my $fh;
483 if ($catWorks)
484 {
485 unlink( OUTPUTZIP );
486 $fh = FileHandle->new( CATPIPE . OUTPUTZIP );
487 binmode($fh);
488 }
489 SKIP: {
490 skip('cat does not work on this platform', 1) unless $catWorks;
491 ok( $fh );
492 }
493 # $status = $zip->writeToFileHandle($fh, 0) if ($catWorks);
494 $status = $zip->writeToFileHandle($fh) if ($catWorks);
495 SKIP: {
496 skip('cat does not work on this platform', 1) unless $catWorks;
497 is( $status, AZ_OK );
498 }
499 $fh->close() if ($catWorks);
500 SKIP: {
501 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
502 ($status, $zipout) = testZip();
503 is($status, 0);
504 }
505 }
506
507 #--------- Change the contents of a string member
508 is(ref($members[2]), 'Archive::Zip::StringMember');
509 $members[2]->contents( "This is my new contents\n" );
510
511 #--------- write zip out and test it.
512 $status = $zip->writeToFileNamed( OUTPUTZIP );
513 is($status, AZ_OK);
514
515 SKIP: {
516 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
517 ($status, $zipout) = testZip();
518 # STDERR->print("status= $status, out=$zipout\n");
519 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
520 is( $status, 0 );
521 }
522
523 #--------- Change the contents of a file member
524 is(ref($members[1]), 'Archive::Zip::NewFileMember');
525 $members[1]->contents( "This is my new contents\n" );
526
527 #--------- write zip out and test it.
528 $status = $zip->writeToFileNamed( OUTPUTZIP );
529 is($status, AZ_OK);
530
531 SKIP: {
532 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
533 ($status, $zipout) = testZip();
534 # STDERR->print("status= $status, out=$zipout\n");
535 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
536 is( $status, 0 );
537 }
538
539 #--------- Change the contents of a zip member
540
541 is(ref($members[7]), 'Archive::Zip::ZipFileMember');
542 $members[7]->contents( "This is my new contents\n" );
543
544 #--------- write zip out and test it.
545 $status = $zip->writeToFileNamed( OUTPUTZIP );
546 is($status, AZ_OK);
547
548 SKIP: {
549 skip( "No 'unzip' program to test against", 1 ) unless HAVEUNZIP;
550 ($status, $zipout) = testZip();
551 # STDERR->print("status= $status, out=$zipout\n");
552 skip( "test zip doesn't work", 1 ) if $testZipDoesntWork;
553 is( $status, 0 );
554 }
555
556
557 #--------- now clean up
558 # END { system("rm -rf " . TESTDIR . " " . OUTPUTZIP . " " . INPUTZIP) }
559
560 #--------------------- STILL UNTESTED IN THIS SCRIPT ---------------------
561
562 # sub setChunkSize # Archive::Zip
563 # sub _formatError # Archive::Zip
564 # sub _error # Archive::Zip
565 # sub _subclassResponsibility # Archive::Zip
566 # sub diskNumber # Archive::Zip::Archive
567 # sub diskNumberWithStartOfCentralDirectory # Archive::Zip::Archive
568 # sub numberOfCentralDirectoriesOnThisDisk # Archive::Zip::Archive
569 # sub numberOfCentralDirectories # Archive::Zip::Archive
570 # sub centralDirectoryOffsetWRTStartingDiskNumber # Archive::Zip::Archive
571 # sub extraField # Archive::Zip::Member
572 # sub isEncrypted # Archive::Zip::Member
573 # sub isTextFile # Archive::Zip::Member
574 # sub isBinaryFile # Archive::Zip::Member
575 # sub isDirectory # Archive::Zip::Member
576 # sub lastModTime # Archive::Zip::Member
577 # sub _writeDataDescriptor # Archive::Zip::Member
578 # sub isDirectory # Archive::Zip::DirectoryMember
579 # sub _becomeDirectory # Archive::Zip::DirectoryMember
580 # sub diskNumberStart # Archive::Zip::ZipFileMember
+83
-0
t/03_ex.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
4 use File::Spec;
5 use IO::File;
6
7 use Test::More tests => 17;
8 BEGIN {
9 unshift @INC, "t/";
10 require( File::Spec->catfile('t', 'common.pl') )
11 or die "Can't load t/common.pl";
12 }
13
14 sub runPerlCommand
15 {
16 my $libs = join ( ' -I', @INC );
17 my $cmd = "\"$^X\" \"-I$libs\" -w \"". join('" "', @_). '"';
18 my $output = `$cmd`;
19 return wantarray ? ( $?, $output ) : $?;
20 }
21
22 use constant FILENAME => File::Spec->catpath( '', TESTDIR, 'testing.txt' );
23 use constant ZFILENAME => TESTDIR . "/testing.txt"; # name in zip
24
25 my $zip = Archive::Zip->new();
26 isa_ok( $zip, 'Archive::Zip' );
27 $zip->addString( TESTSTRING, FILENAME );
28 $zip->writeToFileNamed(INPUTZIP);
29
30 my ( $status, $output );
31 my $fh = IO::File->new( "test.log", "w" );
32 isa_ok( $fh, 'IO::File' );
33
34 is( runPerlCommand( 'examples/copy.pl', INPUTZIP, OUTPUTZIP ), 0 );
35
36 is( runPerlCommand( 'examples/extract.pl', OUTPUTZIP, ZFILENAME ), 0 );
37
38 is( runPerlCommand( 'examples/mfh.pl', INPUTZIP ), 0 );
39
40 is( runPerlCommand( 'examples/zip.pl', OUTPUTZIP, INPUTZIP, FILENAME ), 0 );
41
42 ( $status, $output ) = runPerlCommand( 'examples/zipinfo.pl', INPUTZIP );
43 is( $status, 0 );
44 $fh->print("zipinfo output:\n");
45 $fh->print($output);
46
47 ( $status, $output ) = runPerlCommand( 'examples/ziptest.pl', INPUTZIP );
48 is( $status, 0 );
49 $fh->print("ziptest output:\n");
50 $fh->print($output);
51
52 ( $status, $output ) = runPerlCommand( 'examples/zipGrep.pl', '100', INPUTZIP );
53 is( $status, 0 );
54 is( $output, ZFILENAME . ":100\n" );
55
56 # calcSizes.pl
57 # creates test.zip, may be sensitive to /dev/null
58
59 # removed because requires IO::Scalar
60 # ok( runPerlCommand('examples/readScalar.pl'), 0 );
61
62 unlink(OUTPUTZIP);
63 is( runPerlCommand( 'examples/selfex.pl', OUTPUTZIP, FILENAME ), 0 );
64 unlink(FILENAME);
65 is( runPerlCommand(OUTPUTZIP), 0 );
66 my $fn =
67 File::Spec->catpath( '', File::Spec->catdir( 'extracted', TESTDIR ),
68 'testing.txt' );
69 is( -f $fn, 1, "$fn exists" );
70
71 # unzipAll.pl
72 # updateZip.pl
73 # writeScalar.pl
74 # zipcheck.pl
75 # ziprecent.pl
76
77 unlink(OUTPUTZIP);
78 is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl create" );
79 is( -f OUTPUTZIP, 1, "zip created" );
80 is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl update" );
81 is( -f OUTPUTZIP, 1, "zip updated" );
82 unlink(OUTPUTZIP);
+51
-0
t/04_readmember.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
4 use Archive::Zip::MemberRead;
5
6 use Test::More tests => 8;
7 BEGIN {
8 unshift @INC, "t/";
9 require( File::Spec->catfile('t', 'common.pl') )
10 or die "Can't load t/common.pl";
11 }
12
13 use constant FILENAME => File::Spec->catfile(TESTDIR, 'member_read.zip');
14
15 my ($zip, $member, $fh, @data);
16 $zip = new Archive::Zip;
17 isa_ok( $zip, 'Archive::Zip' );
18 @data = ( 'Line 1', 'Line 2', '', 'Line 3', 'Line 4' );
19
20 $zip->addString(join("\n", @data), 'string.txt');
21 $zip->writeToFileNamed(FILENAME);
22
23 $member = $zip->memberNamed('string.txt');
24 $fh = $member->readFileHandle();
25 ok( $fh );
26
27 my ($line, $not_ok, $ret, $buffer);
28 while (defined($line = $fh->getline()))
29 {
30 $not_ok = 1 if ($line ne $data[$fh->input_line_number()-1]);
31 }
32 ok( !$not_ok );
33
34 $fh->rewind();
35 $ret = $fh->read($buffer, length($data[0]));
36 ok( $ret == length($data[0]) );
37 ok( $buffer eq $data[0] );
38 $fh->close();
39
40 #
41 # Different usages
42 #
43 $fh = new Archive::Zip::MemberRead($zip, 'string.txt');
44 ok($fh);
45
46 $fh = new Archive::Zip::MemberRead($zip, $zip->memberNamed('string.txt'));
47 ok($fh);
48
49 $fh = new Archive::Zip::MemberRead($zip->memberNamed('string.txt'));
50 ok($fh);
+41
-0
t/05_tree.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
4 use FileHandle;
5 use File::Spec;
6
7 use Test::More tests =>6;
8 BEGIN {
9 unshift @INC, "t/";
10 require( File::Spec->catfile('t', 'common.pl') )
11 or die "Can't load t/common.pl";
12 }
13
14 use constant FILENAME => File::Spec->catfile(TESTDIR, 'testing.txt');
15
16 my $zip;
17 my @memberNames;
18
19 sub makeZip
20 {
21 my ($src, $dest, $pred) = @_;
22 $zip = Archive::Zip->new();
23 $zip->addTree($src, $dest, $pred);
24 @memberNames = $zip->memberNames();
25 }
26
27 sub makeZipAndLookFor
28 {
29 my ($src, $dest, $pred, $lookFor) = @_;
30 makeZip($src, $dest, $pred);
31 ok( @memberNames );
32 ok( (grep { $_ eq $lookFor } @memberNames) == 1 )
33 or print STDERR "Can't find $lookFor in (" . join(",", @memberNames) . ")\n";
34 }
35
36 my ($testFileVolume, $testFileDirs, $testFileName) = File::Spec->splitpath($0);
37
38 makeZipAndLookFor('.', '', sub { print "file $_\n"; -f && /\.t$/ }, 't/02_main.t' );
39 makeZipAndLookFor('.', 'e/', sub { -f && /\.t$/ }, 'e/t/02_main.t');
40 makeZipAndLookFor('./t', '', sub { -f && /\.t$/ }, '02_main.t' );
+60
-0
t/06_update.t less more
0 #!/usr/bin/perl -w
1
2 # Test Archive::Zip updating
3
4 use strict;
5 use File::Spec ();
6 use IO::File ();
7 use File::Find ();
8 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
9
10 use Test::More tests => 12;
11 BEGIN {
12 unshift @INC, "t/";
13 require( File::Spec->catfile('t', 'common.pl') )
14 or die "Can't load t/common.pl";
15 }
16
17 my ($testFileVolume, $testFileDirs, $testFileName) = File::Spec->splitpath($0);
18
19 my $zip = Archive::Zip->new();
20 my $testDir = File::Spec->catpath( $testFileVolume, $testFileDirs, '' );
21
22 my $numberOfMembers = 0;
23 my @memberNames;
24 sub countMembers { unless ($_ eq '.')
25 { push(@memberNames, $_); $numberOfMembers++; } };
26 File::Find::find( \&countMembers, $testDir );
27 is( $numberOfMembers > 1, 1, 'not enough members to test');
28
29 # an initial updateTree() should act like an addTree()
30 is( $zip->updateTree( $testDir ), AZ_OK, 'initial updateTree failed' );
31 is( scalar($zip->members()), $numberOfMembers, 'wrong number of members after create' );
32
33 my $firstFile = $memberNames[0];
34 my $firstMember = ($zip->members())[0];
35
36 is( $firstFile, $firstMember->fileName(), 'member name wrong');
37
38 # add a file to the directory
39 $testFileName = File::Spec->catpath( $testFileVolume, $testFileDirs, 'xxxxxx' );
40 my $fh = IO::File->new( $testFileName, 'w');
41 $fh->print('xxxx');
42 undef($fh);
43 is( -f $testFileName, 1, "creating $testFileName failed");
44
45 # Then update it. It should be added.
46 is( $zip->updateTree( $testDir ), AZ_OK, 'updateTree failed' );
47 is( scalar($zip->members()), $numberOfMembers + 1, 'wrong number of members after update' );
48
49 # Delete the file.
50 unlink($testFileName);
51 is( -f $testFileName, undef, "deleting $testFileName failed");
52
53 # updating without the mirror option should keep the members
54 is( $zip->updateTree( $testDir ), AZ_OK, 'updateTree failed' );
55 is( scalar($zip->members()), $numberOfMembers + 1, 'wrong number of members after update' );
56
57 # now try again with the mirror option; should delete the last file.
58 is( $zip->updateTree( $testDir, undef, undef, 1 ), AZ_OK, 'updateTree failed' );
59 is( scalar($zip->members()), $numberOfMembers, 'wrong number of members after mirror' );
+61
-0
t/99_author.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 BEGIN {
4 $| = 1;
5 $^W = 1;
6 }
7 use Test::More;
8
9 # Skip if doing a regular install
10 unless ( $ENV{AUTOMATED_TESTING} ) {
11 plan( skip_all => "Author tests not required for installation" );
12 }
13
14 # Can we run the POD tests?
15 eval "use Test::Pod 1.00";
16 if ( $@ ) {
17 plan( skip_all => "Test::Pod 1.00 required for testing POD" );
18 }
19
20
21
22
23
24 #####################################################################
25 # WARNING: INSANE BLACK MAGIC
26 #####################################################################
27
28 # Hack Pod::Simple::BlackBox to ignore the Test::Inline
29 # "Extended Begin" syntax.
30 # For example, "=begin has more than one word errors"
31 my $begin = \&Pod::Simple::BlackBox::_ponder_begin;
32 sub mybegin {
33 my $para = $_[1];
34 my $content = join ' ', splice @$para, 2;
35 $content =~ s/^\s+//s;
36 $content =~ s/\s+$//s;
37 my @words = split /\s+/, $content;
38 if ( $words[0] =~ /^test(?:ing)?\z/s ) {
39 foreach ( 2 .. $#$para ) {
40 $para->[$_] = '';
41 }
42 $para->[2] = $words[0];
43 }
44
45 # Continue as normal
46 push @$para, @words;
47 return &$begin(@_);
48 }
49
50 SCOPE: {
51 local $^W = 0;
52 *Pod::Simple::BlackBox::_ponder_begin = \&mybegin;
53 }
54
55 #####################################################################
56 # END BLACK MAGIC
57 #####################################################################
58
59 # Test POD
60 all_pod_files_ok();
t/badjpeg/expected.jpg less more
Binary diff not shown
t/badjpeg/source.zip less more
Binary diff not shown
+107
-0
t/common.pl less more
0 # Shared defs for test programs
1
2 # Paths. Must make case-insensitive.
3 use constant TESTDIR => 'testdir';
4 use constant INPUTZIP => 'testin.zip';
5 use constant OUTPUTZIP => 'testout.zip';
6
7 # Do we have the 'zip' and 'unzip' programs?
8 use File::Which ();
9 use constant HAVEZIP => !! File::Which::which('zip');
10 use constant HAVEUNZIP => !! File::Which::which('unzip');
11
12 use constant ZIP => 'zip ';
13 use constant ZIPTEST => 'unzip -t ';
14
15 # 300-character test string
16 use constant TESTSTRING => join ( "\n", 1 .. 102 ) . "\n";
17 use constant TESTSTRINGLENGTH => length(TESTSTRING);
18
19 # CRC-32 should be ac373f32
20 use constant TESTSTRINGCRC => Archive::Zip::computeCRC32(TESTSTRING);
21
22 # This is so that it will work on other systems.
23 use constant CAT => $^X . ' -pe "BEGIN{binmode(STDIN);binmode(STDOUT)}"';
24 use constant CATPIPE => '| ' . CAT . ' >';
25
26 use vars qw($zipWorks $testZipDoesntWork $catWorks);
27 local ( $zipWorks, $testZipDoesntWork, $catWorks );
28
29 # Run ZIPTEST to test a zip file.
30 sub testZip {
31 my $zipName = shift || OUTPUTZIP;
32 if ( $testZipDoesntWork ) {
33 return wantarray ? ( 0, '' ) : 0;
34 }
35 my $cmd = ZIPTEST . $zipName . ( $^O eq 'MSWin32' ? '' : ' 2>&1' );
36 my $zipout = `$cmd`;
37 return wantarray ? ( $?, $zipout ) : $?;
38 }
39
40 # Return the crc-32 of the given file (0 if empty or error)
41 sub fileCRC {
42 my $fileName = shift;
43 local $/ = undef;
44 my $fh = IO::File->new( $fileName, "r" );
45 binmode($fh);
46 return 0 if not defined($fh);
47 my $contents = <$fh>;
48 return Archive::Zip::computeCRC32($contents);
49 }
50
51 #--------- check to see if cat works
52
53 sub testCat {
54 my $fh = IO::File->new( CATPIPE . OUTPUTZIP );
55 binmode($fh);
56 my $testString = pack( 'C256', 0 .. 255 );
57 my $testCrc = Archive::Zip::computeCRC32($testString);
58 $fh->write( $testString, length($testString) ) or return 0;
59 $fh->close();
60 ( -f OUTPUTZIP ) or return 0;
61 my @stat = stat(OUTPUTZIP);
62 $stat[7] == length($testString) or return 0;
63 fileCRC(OUTPUTZIP) == $testCrc or return 0;
64 unlink(OUTPUTZIP);
65 return 1;
66 }
67
68 BEGIN {
69 $catWorks = testCat();
70 unless ( $catWorks ) {
71 warn( 'warning: ', CAT, " doesn't seem to work, may skip some tests" );
72 }
73 }
74
75 #--------- check to see if zip works (and make INPUTZIP)
76
77 BEGIN {
78 unlink(INPUTZIP);
79
80 # Do we have zip installed?
81 if ( HAVEZIP ) {
82 my $cmd = ZIP . INPUTZIP . ' *' . ( $^O eq 'MSWin32' ? '' : ' 2>&1' );
83 $zipout = `$cmd`;
84 $zipWorks = not $?;
85 unless ( $zipWorks ) {
86 warn( 'warning: ', ZIP, " doesn't seem to work, may skip some tests" );
87 }
88 }
89 }
90
91 #--------- check to see if unzip -t works
92
93 BEGIN {
94 $testZipDoesntWork = 0;
95 if ( HAVEUNZIP ) {
96 my ( $status, $zipout ) = testZip(INPUTZIP);
97 $testZipDoesntWork = $status;
98
99 # Again, on Win32 no big surprise if this doesn't work
100 if ( $testZipDoesntWork ) {
101 warn( 'warning: ', ZIPTEST, " doesn't seem to work, may skip some tests" );
102 }
103 }
104 }
105
106 1;