← Index
NYTProf Performance Profile   « line view »
For t/bug-md-11.t
  Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/Archive/Zip/Archive.pm
StatementsExecuted 374 statements in 4.26ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.68ms2.75msArchive::Zip::Archive::::BEGIN@7Archive::Zip::Archive::BEGIN@7
1111.50ms6.08msArchive::Zip::Archive::::BEGIN@12Archive::Zip::Archive::BEGIN@12
1111.11ms1.40msArchive::Zip::Archive::::BEGIN@9Archive::Zip::Archive::BEGIN@9
711203µs303µsArchive::Zip::Archive::::membersMatchingArchive::Zip::Archive::membersMatching
111115µs797µsArchive::Zip::Archive::::readFromFileHandleArchive::Zip::Archive::readFromFileHandle
11125µs49µsArchive::Zip::Archive::::_readEndOfCentralDirectoryArchive::Zip::Archive::_readEndOfCentralDirectory
11117µs25µsArchive::Zip::Archive::::memberNamedArchive::Zip::Archive::memberNamed
11116µs31µsArchive::Zip::Archive::::_findEndOfCentralDirectoryArchive::Zip::Archive::_findEndOfCentralDirectory
11112µs12µsArchive::Zip::Archive::::newArchive::Zip::Archive::new
11111µs12µsArchive::Zip::Archive::::BEGIN@5Archive::Zip::Archive::BEGIN@5
11110µs851µsArchive::Zip::Archive::::readArchive::Zip::Archive::read
8219µs9µsArchive::Zip::Archive::::membersArchive::Zip::Archive::members
1117µs7µsArchive::Zip::Archive::::BEGIN@16Archive::Zip::Archive::BEGIN@16
1116µs28µsArchive::Zip::Archive::::BEGIN@10Archive::Zip::Archive::BEGIN@10
1115µs21µsArchive::Zip::Archive::::BEGIN@14Archive::Zip::Archive::BEGIN@14
1114µs249µsArchive::Zip::Archive::::BEGIN@21Archive::Zip::Archive::BEGIN@21
11114µs4µsArchive::Zip::Archive::::eocdOffsetArchive::Zip::Archive::eocdOffset
1114µs21µsArchive::Zip::Archive::::BEGIN@11Archive::Zip::Archive::BEGIN@11
1114µs22µsArchive::Zip::Archive::::BEGIN@6Archive::Zip::Archive::BEGIN@6
1112µs2µsArchive::Zip::Archive::::BEGIN@8Archive::Zip::Archive::BEGIN@8
1112µs2µsArchive::Zip::Archive::::zip64Archive::Zip::Archive::zip64
2211µs1µsArchive::Zip::Archive::::centralDirectorySizeArchive::Zip::Archive::centralDirectorySize
1111µs1µsArchive::Zip::Archive::::centralDirectoryOffsetWRTStartingDiskNumberArchive::Zip::Archive::centralDirectoryOffsetWRTStartingDiskNumber
0000s0sArchive::Zip::Archive::::__ANON__[:1087]Archive::Zip::Archive::__ANON__[:1087]
0000s0sArchive::Zip::Archive::::__ANON__[:1109]Archive::Zip::Archive::__ANON__[:1109]
0000s0sArchive::Zip::Archive::::__ANON__[:1166]Archive::Zip::Archive::__ANON__[:1166]
0000s0sArchive::Zip::Archive::::__ANON__[:1334]Archive::Zip::Archive::__ANON__[:1334]
0000s0sArchive::Zip::Archive::::__ANON__[:1355]Archive::Zip::Archive::__ANON__[:1355]
0000s0sArchive::Zip::Archive::::_extractionNameIsSafeArchive::Zip::Archive::_extractionNameIsSafe
0000s0sArchive::Zip::Archive::::_untaintDirArchive::Zip::Archive::_untaintDir
0000s0sArchive::Zip::Archive::::_writeCentralDirectoryOffsetArchive::Zip::Archive::_writeCentralDirectoryOffset
0000s0sArchive::Zip::Archive::::_writeEOCDOffsetArchive::Zip::Archive::_writeEOCDOffset
0000s0sArchive::Zip::Archive::::_writeEndOfCentralDirectoryArchive::Zip::Archive::_writeEndOfCentralDirectory
0000s0sArchive::Zip::Archive::::addDirectoryArchive::Zip::Archive::addDirectory
0000s0sArchive::Zip::Archive::::addFileArchive::Zip::Archive::addFile
0000s0sArchive::Zip::Archive::::addFileOrDirectoryArchive::Zip::Archive::addFileOrDirectory
0000s0sArchive::Zip::Archive::::addMemberArchive::Zip::Archive::addMember
0000s0sArchive::Zip::Archive::::addStringArchive::Zip::Archive::addString
0000s0sArchive::Zip::Archive::::addTreeArchive::Zip::Archive::addTree
0000s0sArchive::Zip::Archive::::addTreeMatchingArchive::Zip::Archive::addTreeMatching
0000s0sArchive::Zip::Archive::::contentsArchive::Zip::Archive::contents
0000s0sArchive::Zip::Archive::::desiredZip64ModeArchive::Zip::Archive::desiredZip64Mode
0000s0sArchive::Zip::Archive::::diskNumberArchive::Zip::Archive::diskNumber
0000s0sArchive::Zip::Archive::::diskNumberWithStartOfCentralDirectoryArchive::Zip::Archive::diskNumberWithStartOfCentralDirectory
0000s0sArchive::Zip::Archive::::extractMemberArchive::Zip::Archive::extractMember
0000s0sArchive::Zip::Archive::::extractMemberWithoutPathsArchive::Zip::Archive::extractMemberWithoutPaths
0000s0sArchive::Zip::Archive::::extractTreeArchive::Zip::Archive::extractTree
0000s0sArchive::Zip::Archive::::fileNameArchive::Zip::Archive::fileName
0000s0sArchive::Zip::Archive::::memberNamesArchive::Zip::Archive::memberNames
0000s0sArchive::Zip::Archive::::numberOfCentralDirectoriesArchive::Zip::Archive::numberOfCentralDirectories
0000s0sArchive::Zip::Archive::::numberOfCentralDirectoriesOnThisDiskArchive::Zip::Archive::numberOfCentralDirectoriesOnThisDisk
0000s0sArchive::Zip::Archive::::numberOfMembersArchive::Zip::Archive::numberOfMembers
0000s0sArchive::Zip::Archive::::overwriteArchive::Zip::Archive::overwrite
0000s0sArchive::Zip::Archive::::overwriteAsArchive::Zip::Archive::overwriteAs
0000s0sArchive::Zip::Archive::::removeMemberArchive::Zip::Archive::removeMember
0000s0sArchive::Zip::Archive::::replaceMemberArchive::Zip::Archive::replaceMember
0000s0sArchive::Zip::Archive::::storeSymbolicLinkArchive::Zip::Archive::storeSymbolicLink
0000s0sArchive::Zip::Archive::::updateMemberArchive::Zip::Archive::updateMember
0000s0sArchive::Zip::Archive::::updateTreeArchive::Zip::Archive::updateTree
0000s0sArchive::Zip::Archive::::versionMadeByArchive::Zip::Archive::versionMadeBy
0000s0sArchive::Zip::Archive::::versionNeededToExtractArchive::Zip::Archive::versionNeededToExtract
0000s0sArchive::Zip::Archive::::writeCentralDirectoryArchive::Zip::Archive::writeCentralDirectory
0000s0sArchive::Zip::Archive::::writeToFileHandleArchive::Zip::Archive::writeToFileHandle
0000s0sArchive::Zip::Archive::::writeToFileNamedArchive::Zip::Archive::writeToFileNamed
0000s0sArchive::Zip::Archive::::zipfileCommentArchive::Zip::Archive::zipfileComment
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Archive::Zip::Archive;
2
3# Represents a generic ZIP archive
4
5220µs214µs
# spent 12µs (11+2) within Archive::Zip::Archive::BEGIN@5 which was called: # once (11µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 5
use strict;
# spent 12µs making 1 call to Archive::Zip::Archive::BEGIN@5 # spent 2µs making 1 call to strict::import
6214µs240µs
# spent 22µs (4+18) within Archive::Zip::Archive::BEGIN@6 which was called: # once (4µs+18µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 6
use File::Path;
# spent 22µs making 1 call to Archive::Zip::Archive::BEGIN@6 # spent 18µs making 1 call to Exporter::import
7294µs12.75ms
# spent 2.75ms (2.68+67µs) within Archive::Zip::Archive::BEGIN@7 which was called: # once (2.68ms+67µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 7
use File::Find ();
# spent 2.75ms making 1 call to Archive::Zip::Archive::BEGIN@7
8210µs12µs
# spent 2µs within Archive::Zip::Archive::BEGIN@8 which was called: # once (2µs+0s) by Spreadsheet::ParseXLSX::BEGIN@11 at line 8
use File::Spec ();
# spent 2µs making 1 call to Archive::Zip::Archive::BEGIN@8
9281µs11.40ms
# spent 1.40ms (1.11+292µs) within Archive::Zip::Archive::BEGIN@9 which was called: # once (1.11ms+292µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 9
use File::Copy ();
# spent 1.40ms making 1 call to Archive::Zip::Archive::BEGIN@9
10216µs250µs
# spent 28µs (6+22) within Archive::Zip::Archive::BEGIN@10 which was called: # once (6µs+22µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 10
use File::Basename;
# spent 28µs making 1 call to Archive::Zip::Archive::BEGIN@10 # spent 22µs making 1 call to Exporter::import
11216µs238µs
# spent 21µs (4+17) within Archive::Zip::Archive::BEGIN@11 which was called: # once (4µs+17µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 11
use Cwd;
# spent 21µs making 1 call to Archive::Zip::Archive::BEGIN@11 # spent 17µs making 1 call to Exporter::import
12272µs26.13ms
# spent 6.08ms (1.50+4.58) within Archive::Zip::Archive::BEGIN@12 which was called: # once (1.50ms+4.58ms) by Spreadsheet::ParseXLSX::BEGIN@11 at line 12
use Encode qw(encode_utf8 decode_utf8);
# spent 6.08ms making 1 call to Archive::Zip::Archive::BEGIN@12 # spent 47µs making 1 call to Exporter::import
13
14225µs236µs
# spent 21µs (5+16) within Archive::Zip::Archive::BEGIN@14 which was called: # once (5µs+16µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 14
use vars qw( $VERSION @ISA );
# spent 21µs making 1 call to Archive::Zip::Archive::BEGIN@14 # spent 16µs making 1 call to vars::import
15
16
# spent 7µs within Archive::Zip::Archive::BEGIN@16 which was called: # once (7µs+0s) by Spreadsheet::ParseXLSX::BEGIN@11 at line 19
BEGIN {
171200ns $VERSION = '1.68';
1817µs @ISA = qw( Archive::Zip );
19115µs17µs}
# spent 7µs making 1 call to Archive::Zip::Archive::BEGIN@16
20
2113µs1244µs
# spent 249µs (4+244) within Archive::Zip::Archive::BEGIN@21 which was called: # once (4µs+244µs) by Spreadsheet::ParseXLSX::BEGIN@11 at line 26
use Archive::Zip qw(
# spent 244µs making 1 call to Exporter::import
22 :CONSTANTS
23 :ERROR_CODES
24 :PKZIP_CONSTANTS
25 :UTILITY_METHODS
2613.47ms1249µs);
# spent 249µs making 1 call to Archive::Zip::Archive::BEGIN@21
27
28our $UNICODE;
2915µs11µsour $UNTAINT = qr/\A(.+)\z/;
# spent 1µs making 1 call to CORE::qr
30
31# Note that this returns undef on read errors, else new zip object.
32
33
# spent 12µs within Archive::Zip::Archive::new which was called: # once (12µs+0s) by Archive::Zip::new at line 343 of Archive/Zip.pm
sub new {
341200ns my $class = shift;
35 # Info-Zip 3.0 (I guess) seems to use the following values
36 # for the version fields in the zip64 EOCD record:
37 #
38 # version made by:
39 # 30 (plus upper byte indicating host system)
40 #
41 # version needed to extract:
42 # 45
4316µs my $self = bless(
44 {
45 'zip64' => 0,
46 'desiredZip64Mode' => ZIP64_AS_NEEDED,
47 'versionMadeBy' => 0,
48 'versionNeededToExtract' => 0,
49 'diskNumber' => 0,
50 'diskNumberWithStartOfCentralDirectory' =>
51 0,
52 'numberOfCentralDirectoriesOnThisDisk' =>
53 0, # should be # of members
54 'numberOfCentralDirectories' => 0, # should be # of members
55 'centralDirectorySize' => 0, # must re-compute on write
56 'centralDirectoryOffsetWRTStartingDiskNumber' =>
57 0, # must re-compute
58 'writeEOCDOffset' => 0,
59 'writeCentralDirectoryOffset' => 0,
60 'zipfileComment' => '',
61 'eocdOffset' => 0,
62 'fileName' => ''
63 },
64 $class
65 );
6613µs $self->{'members'} = [];
671900ns my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift;
681200ns if ($fileName) {
69 my $status = $self->read($fileName);
70 return $status == AZ_OK ? $self : undef;
71 }
7212µs return $self;
73}
74
75sub storeSymbolicLink {
76 my $self = shift;
77 $self->{'storeSymbolicLink'} = shift;
78}
79
80
# spent 9µs within Archive::Zip::Archive::members which was called 8 times, avg 1µs/call: # 7 times (8µs+0s) by Archive::Zip::Archive::membersMatching at line 106, avg 1µs/call # once (2µs+0s) by Archive::Zip::Archive::memberNamed at line 97
sub members {
81814µs @{shift->{'members'}};
82}
83
84sub numberOfMembers {
85 scalar(shift->members());
86}
87
88sub memberNames {
89 my $self = shift;
90 return map { $_->fileName() } $self->members();
91}
92
93# return ref to member with given name or undef
94
# spent 25µs (17+8) within Archive::Zip::Archive::memberNamed which was called: # once (17µs+8µs) by Spreadsheet::ParseXLSX::_extract_files at line 1004 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm
sub memberNamed {
951200ns my $self = shift;
9611µs my $fileName = (ref($_[0]) eq 'HASH') ? shift->{zipName} : shift;
9712µs12µs foreach my $member ($self->members()) {
# spent 2µs making 1 call to Archive::Zip::Archive::members
98106µs106µs return $member if $member->fileName() eq $fileName;
# spent 6µs making 10 calls to Archive::Zip::Member::fileName, avg 650ns/call
99 }
10012µs return undef;
101}
102
103
# spent 303µs (203+100) within Archive::Zip::Archive::membersMatching which was called 7 times, avg 43µs/call: # 7 times (203µs+100µs) by Spreadsheet::ParseXLSX::_zip_file_member at line 1042 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 43µs/call
sub membersMatching {
10471µs my $self = shift;
10575µs my $pattern = (ref($_[0]) eq 'HASH') ? shift->{regex} : shift;
10677225µs217100µs return grep { $_->fileName() =~ /$pattern/ } $self->members();
# spent 37µs making 70 calls to Archive::Zip::Member::fileName, avg 530ns/call # spent 31µs making 70 calls to CORE::match, avg 439ns/call # spent 24µs making 70 calls to CORE::regcomp, avg 350ns/call # spent 8µs making 7 calls to Archive::Zip::Archive::members, avg 1µs/call
107}
108
109
# spent 2µs within Archive::Zip::Archive::zip64 which was called: # once (2µs+0s) by Archive::Zip::Archive::readFromFileHandle at line 768
sub zip64 {
11012µs shift->{'zip64'};
111}
112
113sub desiredZip64Mode {
114 my $self = shift;
115 my $desiredZip64Mode = $self->{'desiredZip64Mode'};
116 if (@_) {
117 $self->{'desiredZip64Mode'} =
118 ref($_[0]) eq 'HASH' ? shift->{desiredZip64Mode} : shift;
119 }
120 return $desiredZip64Mode;
121}
122
123sub versionMadeBy {
124 shift->{'versionMadeBy'};
125}
126
127sub versionNeededToExtract {
128 shift->{'versionNeededToExtract'};
129}
130
131sub diskNumber {
132 shift->{'diskNumber'};
133}
134
135sub diskNumberWithStartOfCentralDirectory {
136 shift->{'diskNumberWithStartOfCentralDirectory'};
137}
138
139sub numberOfCentralDirectoriesOnThisDisk {
140 shift->{'numberOfCentralDirectoriesOnThisDisk'};
141}
142
143sub numberOfCentralDirectories {
144 shift->{'numberOfCentralDirectories'};
145}
146
147
# spent 1µs within Archive::Zip::Archive::centralDirectorySize which was called 2 times, avg 650ns/call: # once (1µs+0s) by Archive::Zip::Archive::readFromFileHandle at line 770 # once (200ns+0s) by Archive::Zip::Archive::readFromFileHandle at line 776
sub centralDirectorySize {
14822µs shift->{'centralDirectorySize'};
149}
150
151
# spent 1µs within Archive::Zip::Archive::centralDirectoryOffsetWRTStartingDiskNumber which was called: # once (1µs+0s) by Archive::Zip::Archive::readFromFileHandle at line 776
sub centralDirectoryOffsetWRTStartingDiskNumber {
15211µs shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
153}
154
155sub zipfileComment {
156 my $self = shift;
157 my $comment = $self->{'zipfileComment'};
158 if (@_) {
159 my $new_comment = (ref($_[0]) eq 'HASH') ? shift->{comment} : shift;
160 $self->{'zipfileComment'} = pack('C0a*', $new_comment); # avoid Unicode
161 }
162 return $comment;
163}
164
165
# spent 4µs within Archive::Zip::Archive::eocdOffset which was called 11 times, avg 400ns/call: # 11 times (4µs+0s) by Archive::Zip::Archive::readFromFileHandle at line 780, avg 400ns/call
sub eocdOffset {
166119µs shift->{'eocdOffset'};
167}
168
169# Return the name of the file last read.
170sub fileName {
171 shift->{'fileName'};
172}
173
174sub removeMember {
175 my $self = shift;
176 my $member = (ref($_[0]) eq 'HASH') ? shift->{memberOrZipName} : shift;
177 $member = $self->memberNamed($member) unless ref($member);
178 return undef unless $member;
179 my @newMembers = grep { $_ != $member } $self->members();
180 $self->{'members'} = \@newMembers;
181 return $member;
182}
183
184sub replaceMember {
185 my $self = shift;
186
187 my ($oldMember, $newMember);
188 if (ref($_[0]) eq 'HASH') {
189 $oldMember = $_[0]->{memberOrZipName};
190 $newMember = $_[0]->{newMember};
191 } else {
192 ($oldMember, $newMember) = @_;
193 }
194
195 $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
196 return undef unless $oldMember;
197 return undef unless $newMember;
198 my @newMembers =
199 map { ($_ == $oldMember) ? $newMember : $_ } $self->members();
200 $self->{'members'} = \@newMembers;
201 return $oldMember;
202}
203
204sub extractMember {
205 my $self = shift;
206
207 my ($member, $name);
208 if (ref($_[0]) eq 'HASH') {
209 $member = $_[0]->{memberOrZipName};
210 $name = $_[0]->{name};
211 } else {
212 ($member, $name) = @_;
213 }
214
215 $member = $self->memberNamed($member) unless ref($member);
216 return _error('member not found') unless $member;
217 my $originalSize = $member->compressedSize();
218 my ($volumeName, $dirName, $fileName);
219 if (defined($name)) {
220 ($volumeName, $dirName, $fileName) = File::Spec->splitpath($name);
221 $dirName = File::Spec->catpath($volumeName, $dirName, '');
222 } else {
223 $name = $member->fileName();
224 if ((my $ret = _extractionNameIsSafe($name))
225 != AZ_OK) { return $ret; }
226 ($dirName = $name) =~ s{[^/]*$}{};
227 $dirName = Archive::Zip::_asLocalName($dirName);
228 $name = Archive::Zip::_asLocalName($name);
229 }
230 if ($dirName && !-d $dirName) {
231 mkpath($dirName);
232 return _ioError("can't create dir $dirName") if (!-d $dirName);
233 }
234 my $rc = $member->extractToFileNamed($name, @_);
235
236 # TODO refactor this fix into extractToFileNamed()
237 $member->{'compressedSize'} = $originalSize;
238 return $rc;
239}
240
241sub extractMemberWithoutPaths {
242 my $self = shift;
243
244 my ($member, $name);
245 if (ref($_[0]) eq 'HASH') {
246 $member = $_[0]->{memberOrZipName};
247 $name = $_[0]->{name};
248 } else {
249 ($member, $name) = @_;
250 }
251
252 $member = $self->memberNamed($member) unless ref($member);
253 return _error('member not found') unless $member;
254 my $originalSize = $member->compressedSize();
255 return AZ_OK if $member->isDirectory();
256 unless ($name) {
257 $name = $member->fileName();
258 $name =~ s{.*/}{}; # strip off directories, if any
259 if ((my $ret = _extractionNameIsSafe($name))
260 != AZ_OK) { return $ret; }
261 $name = Archive::Zip::_asLocalName($name);
262 }
263 my $rc = $member->extractToFileNamed($name, @_);
264 $member->{'compressedSize'} = $originalSize;
265 return $rc;
266}
267
268sub addMember {
269 my $self = shift;
270 my $newMember = (ref($_[0]) eq 'HASH') ? shift->{member} : shift;
271 push(@{$self->{'members'}}, $newMember) if $newMember;
272 if($newMember && ($newMember->{bitFlag} & 0x800)
273 && !utf8::is_utf8($newMember->{fileName})){
274 $newMember->{fileName} = Encode::decode_utf8($newMember->{fileName});
275 }
276 return $newMember;
277}
278
279sub addFile {
280 my $self = shift;
281
282 my ($fileName, $newName, $compressionLevel);
283 if (ref($_[0]) eq 'HASH') {
284 $fileName = $_[0]->{filename};
285 $newName = $_[0]->{zipName};
286 $compressionLevel = $_[0]->{compressionLevel};
287 } else {
288 ($fileName, $newName, $compressionLevel) = @_;
289 }
290
291 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
292 $fileName = Win32::GetANSIPathName($fileName);
293 }
294
295 my $newMember = Archive::Zip::Member->newFromFile($fileName, $newName);
296 $newMember->desiredCompressionLevel($compressionLevel);
297 if ($self->{'storeSymbolicLink'} && -l $fileName) {
298 my $newMember =
299 Archive::Zip::Member->newFromString(readlink $fileName, $newName);
300
301 # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
302 $newMember->{'externalFileAttributes'} = 0xA1FF0000;
303 $self->addMember($newMember);
304 } else {
305 $self->addMember($newMember);
306 }
307
308 return $newMember;
309}
310
311sub addString {
312 my $self = shift;
313
314 my ($stringOrStringRef, $name, $compressionLevel);
315 if (ref($_[0]) eq 'HASH') {
316 $stringOrStringRef = $_[0]->{string};
317 $name = $_[0]->{zipName};
318 $compressionLevel = $_[0]->{compressionLevel};
319 } else {
320 ($stringOrStringRef, $name, $compressionLevel) = @_;
321 }
322
323 my $newMember =
324 Archive::Zip::Member->newFromString($stringOrStringRef, $name);
325 $newMember->desiredCompressionLevel($compressionLevel);
326 return $self->addMember($newMember);
327}
328
329sub addDirectory {
330 my $self = shift;
331
332 my ($name, $newName);
333 if (ref($_[0]) eq 'HASH') {
334 $name = $_[0]->{directoryName};
335 $newName = $_[0]->{zipName};
336 } else {
337 ($name, $newName) = @_;
338 }
339
340 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
341 $name = Win32::GetANSIPathName($name);
342 }
343
344 my $newMember = Archive::Zip::Member->newDirectoryNamed($name, $newName);
345 if ($self->{'storeSymbolicLink'} && -l $name) {
346 my $link = readlink $name;
347 ($newName =~ s{/$}{}) if $newName; # Strip trailing /
348 my $newMember = Archive::Zip::Member->newFromString($link, $newName);
349
350 # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
351 $newMember->{'externalFileAttributes'} = 0xA1FF0000;
352 $self->addMember($newMember);
353 } else {
354 $self->addMember($newMember);
355 }
356
357 return $newMember;
358}
359
360# add either a file or a directory.
361
362sub addFileOrDirectory {
363 my $self = shift;
364
365 my ($name, $newName, $compressionLevel);
366 if (ref($_[0]) eq 'HASH') {
367 $name = $_[0]->{name};
368 $newName = $_[0]->{zipName};
369 $compressionLevel = $_[0]->{compressionLevel};
370 } else {
371 ($name, $newName, $compressionLevel) = @_;
372 }
373
374 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
375 $name = Win32::GetANSIPathName($name);
376 }
377
378 $name =~ s{/$}{};
379 if ($newName) {
380 $newName =~ s{/$}{};
381 } else {
382 $newName = $name;
383 }
384 if (-f $name) {
385 return $self->addFile($name, $newName, $compressionLevel);
386 } elsif (-d $name) {
387 return $self->addDirectory($name, $newName);
388 } else {
389 return _error("$name is neither a file nor a directory");
390 }
391}
392
393sub contents {
394 my $self = shift;
395
396 my ($member, $newContents);
397 if (ref($_[0]) eq 'HASH') {
398 $member = $_[0]->{memberOrZipName};
399 $newContents = $_[0]->{contents};
400 } else {
401 ($member, $newContents) = @_;
402 }
403
404 my ($contents, $status) = (undef, AZ_OK);
405 if ($status == AZ_OK) {
406 $status = _error('No member name given') unless defined($member);
407 }
408 if ($status == AZ_OK && ! ref($member)) {
409 my $memberName = $member;
410 $member = $self->memberNamed($memberName);
411 $status = _error('No member named $memberName') unless defined($member);
412 }
413 if ($status == AZ_OK) {
414 ($contents, $status) = $member->contents($newContents);
415 }
416
417 return
418 wantarray
419 ? ($contents, $status)
420 : $contents;
421}
422
423sub writeToFileNamed {
424 my $self = shift;
425 my $fileName =
426 (ref($_[0]) eq 'HASH') ? shift->{filename} : shift; # local FS format
427 foreach my $member ($self->members()) {
428 if ($member->_usesFileNamed($fileName)) {
429 return _error("$fileName is needed by member "
430 . $member->fileName()
431 . "; consider using overwrite() or overwriteAs() instead.");
432 }
433 }
434 my ($status, $fh) = _newFileHandle($fileName, 'w');
435 return _ioError("Can't open $fileName for write") unless $status;
436 $status = $self->writeToFileHandle($fh, 1);
437 $fh->close();
438 $fh = undef;
439
440 return $status;
441}
442
443# It is possible to write data to the FH before calling this,
444# perhaps to make a self-extracting archive.
445sub writeToFileHandle {
446 my $self = shift;
447
448 my ($fh, $fhIsSeekable);
449 if (ref($_[0]) eq 'HASH') {
450 $fh = $_[0]->{fileHandle};
451 $fhIsSeekable =
452 exists($_[0]->{seek}) ? $_[0]->{seek} : _isSeekable($fh);
453 } else {
454 $fh = shift;
455 $fhIsSeekable = @_ ? shift : _isSeekable($fh);
456 }
457
458 return _error('No filehandle given') unless $fh;
459 return _ioError('filehandle not open') unless $fh->opened();
460 _binmode($fh);
461
462 # Find out where the current position is.
463 my $offset = $fhIsSeekable ? $fh->tell() : 0;
464 $offset = 0 if $offset < 0;
465
466 # (Re-)set the "was-successfully-written" flag so that the
467 # contract advertised in the documentation ("that member and
468 # *all following it* will return false from wasWritten()")
469 # also holds for members written more than once.
470 #
471 # Not sure whether that mechanism works, anyway. If method
472 # $member->_writeToFileHandle fails with an error below and
473 # user continues with calling $zip->writeCentralDirectory
474 # manually, we should end up with the following picture
475 # unless the user seeks back to writeCentralDirectoryOffset:
476 #
477 # ...
478 # [last successfully written member]
479 # <- writeCentralDirectoryOffset points here
480 # [half-written member junk with unknown size]
481 # [central directory entry 0]
482 # ...
483 foreach my $member ($self->members()) {
484 $member->{'wasWritten'} = 0;
485 }
486
487 foreach my $member ($self->members()) {
488
489 # (Re-)set object member zip64 flag. Here is what
490 # happens next to that flag:
491 #
492 # $member->_writeToFileHandle
493 # Determines a local flag value depending on
494 # necessity and user desire and ors it to
495 # the object member
496 # $member->_writeLocalFileHeader
497 # Queries the object member to write appropriate
498 # local header
499 # $member->_writeDataDescriptor
500 # Queries the object member to write appropriate
501 # data descriptor
502 # $member->_writeCentralDirectoryFileHeader
503 # Determines a local flag value depending on
504 # necessity and user desire. Writes a central
505 # directory header appropriate to the local flag.
506 # Ors the local flag to the object member.
507 $member->{'zip64'} = 0;
508
509 my ($status, $memberSize) =
510 $member->_writeToFileHandle($fh, $fhIsSeekable, $offset,
511 $self->desiredZip64Mode());
512 $member->endRead();
513 return $status if $status != AZ_OK;
514
515 $offset += $memberSize;
516
517 # Change this so it reflects write status and last
518 # successful position
519 $member->{'wasWritten'} = 1;
520 $self->{'writeCentralDirectoryOffset'} = $offset;
521 }
522
523 return $self->writeCentralDirectory($fh);
524}
525
526# Write zip back to the original file,
527# as safely as possible.
528# Returns AZ_OK if successful.
529sub overwrite {
530 my $self = shift;
531 return $self->overwriteAs($self->{'fileName'});
532}
533
534# Write zip to the specified file,
535# as safely as possible.
536# Returns AZ_OK if successful.
537sub overwriteAs {
538 my $self = shift;
539 my $zipName = (ref($_[0]) eq 'HASH') ? $_[0]->{filename} : shift;
540 return _error("no filename in overwriteAs()") unless defined($zipName);
541
542 my ($fh, $tempName) = Archive::Zip::tempFile();
543 return _error("Can't open temp file", $!) unless $fh;
544
545 (my $backupName = $zipName) =~ s{(\.[^.]*)?$}{.zbk};
546
547 my $status = $self->writeToFileHandle($fh);
548 $fh->close();
549 $fh = undef;
550
551 if ($status != AZ_OK) {
552 unlink($tempName);
553 _printError("Can't write to $tempName");
554 return $status;
555 }
556
557 my $err;
558
559 # rename the zip
560 if (-f $zipName && !rename($zipName, $backupName)) {
561 $err = $!;
562 unlink($tempName);
563 return _error("Can't rename $zipName as $backupName", $err);
564 }
565
566 # move the temp to the original name (possibly copying)
567 unless (File::Copy::move($tempName, $zipName)
568 || File::Copy::copy($tempName, $zipName)) {
569 $err = $!;
570 rename($backupName, $zipName);
571 unlink($tempName);
572 return _error("Can't move $tempName to $zipName", $err);
573 }
574
575 # unlink the backup
576 if (-f $backupName && !unlink($backupName)) {
577 $err = $!;
578 return _error("Can't unlink $backupName", $err);
579 }
580
581 return AZ_OK;
582}
583
584# Used only during writing
585sub _writeCentralDirectoryOffset {
586 shift->{'writeCentralDirectoryOffset'};
587}
588
589sub _writeEOCDOffset {
590 shift->{'writeEOCDOffset'};
591}
592
593# Expects to have _writeEOCDOffset() set
594sub _writeEndOfCentralDirectory {
595 my ($self, $fh, $membersZip64) = @_;
596
597 my $zip64 = 0;
598 my $versionMadeBy = $self->versionMadeBy();
599 my $versionNeededToExtract = $self->versionNeededToExtract();
600 my $diskNumber = 0;
601 my $diskNumberWithStartOfCentralDirectory = 0;
602 my $numberOfCentralDirectoriesOnThisDisk = $self->numberOfMembers();
603 my $numberOfCentralDirectories = $self->numberOfMembers();
604 my $centralDirectorySize =
605 $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset();
606 my $centralDirectoryOffsetWRTStartingDiskNumber =
607 $self->_writeCentralDirectoryOffset();
608 my $zipfileCommentLength = length($self->zipfileComment());
609
610 my $eocdDataZip64 = 0;
611 $eocdDataZip64 ||= $numberOfCentralDirectoriesOnThisDisk > 0xffff;
612 $eocdDataZip64 ||= $numberOfCentralDirectories > 0xffff;
613 $eocdDataZip64 ||= $centralDirectorySize > 0xffffffff;
614 $eocdDataZip64 ||= $centralDirectoryOffsetWRTStartingDiskNumber > 0xffffffff;
615
616 if ( $membersZip64
617 || $eocdDataZip64
618 || $self->desiredZip64Mode() == ZIP64_EOCD) {
619 return _zip64NotSupported() unless ZIP64_SUPPORTED;
620
621 $zip64 = 1;
622 $versionMadeBy = 45 if ($versionMadeBy == 0);
623 $versionNeededToExtract = 45 if ($versionNeededToExtract < 45);
624
625 $self->_print($fh, ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_SIGNATURE_STRING)
626 or return _ioError('writing zip64 EOCD record signature');
627
628 my $record = pack(
629 ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_FORMAT,
630 ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_LENGTH +
631 SIGNATURE_LENGTH - 12,
632 $versionMadeBy,
633 $versionNeededToExtract,
634 $diskNumber,
635 $diskNumberWithStartOfCentralDirectory,
636 $numberOfCentralDirectoriesOnThisDisk,
637 $numberOfCentralDirectories,
638 $centralDirectorySize,
639 $centralDirectoryOffsetWRTStartingDiskNumber
640 );
641 $self->_print($fh, $record)
642 or return _ioError('writing zip64 EOCD record');
643
644 $self->_print($fh, ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_SIGNATURE_STRING)
645 or return _ioError('writing zip64 EOCD locator signature');
646
647 my $locator = pack(
648 ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_FORMAT,
649 0,
650 $self->_writeEOCDOffset(),
651 1
652 );
653 $self->_print($fh, $locator)
654 or return _ioError('writing zip64 EOCD locator');
655 }
656
657 $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
658 or return _ioError('writing EOCD Signature');
659
660 my $header = pack(
661 END_OF_CENTRAL_DIRECTORY_FORMAT,
662 $diskNumber,
663 $diskNumberWithStartOfCentralDirectory,
664 $numberOfCentralDirectoriesOnThisDisk > 0xffff
665 ? 0xffff : $numberOfCentralDirectoriesOnThisDisk,
666 $numberOfCentralDirectories > 0xffff
667 ? 0xffff : $numberOfCentralDirectories,
668 $centralDirectorySize > 0xffffffff
669 ? 0xffffffff : $centralDirectorySize,
670 $centralDirectoryOffsetWRTStartingDiskNumber > 0xffffffff
671 ? 0xffffffff : $centralDirectoryOffsetWRTStartingDiskNumber,
672 $zipfileCommentLength
673 );
674 $self->_print($fh, $header)
675 or return _ioError('writing EOCD header');
676 if ($zipfileCommentLength) {
677 $self->_print($fh, $self->zipfileComment())
678 or return _ioError('writing zipfile comment');
679 }
680
681 # Adjust object members related to zip64 format
682 $self->{'zip64'} = $zip64;
683 $self->{'versionMadeBy'} = $versionMadeBy;
684 $self->{'versionNeededToExtract'} = $versionNeededToExtract;
685
686 return AZ_OK;
687}
688
689# $offset can be specified to truncate a zip file.
690sub writeCentralDirectory {
691 my $self = shift;
692
693 my ($fh, $offset);
694 if (ref($_[0]) eq 'HASH') {
695 $fh = $_[0]->{fileHandle};
696 $offset = $_[0]->{offset};
697 } else {
698 ($fh, $offset) = @_;
699 }
700
701 if (defined($offset)) {
702 $self->{'writeCentralDirectoryOffset'} = $offset;
703 $fh->seek($offset, IO::Seekable::SEEK_SET)
704 or return _ioError('seeking to write central directory');
705 } else {
706 $offset = $self->_writeCentralDirectoryOffset();
707 }
708
709 my $membersZip64 = 0;
710 foreach my $member ($self->members()) {
711 my ($status, $headerSize) =
712 $member->_writeCentralDirectoryFileHeader($fh, $self->desiredZip64Mode());
713 return $status if $status != AZ_OK;
714 $membersZip64 ||= $member->zip64();
715 $offset += $headerSize;
716 $self->{'writeEOCDOffset'} = $offset;
717 }
718
719 return $self->_writeEndOfCentralDirectory($fh, $membersZip64);
720}
721
722
# spent 851µs (10+841) within Archive::Zip::Archive::read which was called: # once (10µs+841µs) by Spreadsheet::ParseXLSX::parse at line 100 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm
sub read {
7231300ns my $self = shift;
7241600ns my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift;
7251200ns return _error('No filename given') unless $fileName;
72612µs138µs my ($status, $fh) = _newFileHandle($fileName, 'r');
# spent 38µs making 1 call to Archive::Zip::_newFileHandle
7271200ns return _ioError("opening $fileName for read") unless $status;
728
72912µs1797µs $status = $self->readFromFileHandle($fh, $fileName);
# spent 797µs making 1 call to Archive::Zip::Archive::readFromFileHandle
7301300ns return $status if $status != AZ_OK;
731
7321900ns16µs $fh->close();
# spent 6µs making 1 call to IO::Handle::close
7331500ns $self->{'fileName'} = $fileName;
73412µs return AZ_OK;
735}
736
737
# spent 797µs (115+682) within Archive::Zip::Archive::readFromFileHandle which was called: # once (115µs+682µs) by Archive::Zip::Archive::read at line 729
sub readFromFileHandle {
7381200ns my $self = shift;
739
7401200ns my ($fh, $fileName);
7411900ns if (ref($_[0]) eq 'HASH') {
742 $fh = $_[0]->{fileHandle};
743 $fileName = $_[0]->{filename};
744 } else {
7451600ns ($fh, $fileName) = @_;
746 }
747
7481400ns $fileName = $fh unless defined($fileName);
7491300ns return _error('No filehandle given') unless $fh;
75012µs12µs return _ioError('filehandle not open') unless $fh->opened();
# spent 2µs making 1 call to IO::Handle::opened
751
75211µs118µs _binmode($fh);
# spent 18µs making 1 call to Archive::Zip::_binmode
75311µs $self->{'fileName'} = "$fh";
754
755 # TODO: how to support non-seekable zips?
75612µs120µs return _error('file not seekable')
# spent 20µs making 1 call to Archive::Zip::_isSeekable
757 unless _isSeekable($fh);
758
75912µs15µs $fh->seek(0, 0); # rewind the file
# spent 5µs making 1 call to IO::Seekable::seek
760
76112µs131µs my $status = $self->_findEndOfCentralDirectory($fh);
7621700ns return $status if $status != AZ_OK;
763
7641100ns my $eocdPosition;
76512µs149µs ($status, $eocdPosition) = $self->_readEndOfCentralDirectory($fh, $fileName);
7661300ns return $status if $status != AZ_OK;
767
76812µs12µs my $zip64 = $self->zip64();
# spent 2µs making 1 call to Archive::Zip::Archive::zip64
769
77012µs23µs $fh->seek($eocdPosition - $self->centralDirectorySize(),
# spent 2µs making 1 call to IO::Seekable::seek # spent 1µs making 1 call to Archive::Zip::Archive::centralDirectorySize
771 IO::Seekable::SEEK_SET)
772 or return _ioError("Can't seek $fileName");
773
774 # Try to detect garbage at beginning of archives
775 # This should be 0
77612µs21µs $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
777 - $self->centralDirectoryOffsetWRTStartingDiskNumber();
778
7791200ns for (; ;) {
7801114µs22271µs my $newMember =
# spent 266µs making 11 calls to Archive::Zip::Member::_newFromZipFile, avg 24µs/call # spent 4µs making 11 calls to Archive::Zip::Archive::eocdOffset, avg 400ns/call
781 Archive::Zip::Member->_newFromZipFile($fh, $fileName, $zip64,
782 $self->eocdOffset());
78311800ns my $signature;
784117µs1156µs ($status, $signature) = _readSignature($fh, $fileName);
# spent 56µs making 11 calls to Archive::Zip::_readSignature, avg 5µs/call
785111µs return $status if $status != AZ_OK;
786113µs if (! $zip64) {
787117µs last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
788 }
789 else {
790 last if $signature == ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_SIGNATURE;
791 }
792106µs10178µs $status = $newMember->_readCentralDirectoryFileHeader();
# spent 178µs making 10 calls to Archive::Zip::ZipFileMember::_readCentralDirectoryFileHeader, avg 18µs/call
793101µs return $status if $status != AZ_OK;
794107µs1028µs $status = $newMember->endRead();
# spent 28µs making 10 calls to Archive::Zip::FileMember::endRead, avg 3µs/call
795101µs return $status if $status != AZ_OK;
796
797105µs1019µs if ($newMember->isDirectory()) {
# spent 19µs making 10 calls to Archive::Zip::ZipFileMember::isDirectory, avg 2µs/call
798 $newMember->_become('Archive::Zip::DirectoryMember');
799 # Ensure above call suceeded to avoid future trouble
800 $newMember->_ISA('Archive::Zip::DirectoryMember') or
801 return $self->_error('becoming Archive::Zip::DirectoryMember');
802 }
803
804102µs if(($newMember->{bitFlag} & 0x800) && !utf8::is_utf8($newMember->{fileName})){
805 $newMember->{fileName} = Encode::decode_utf8($newMember->{fileName});
806 }
807
808106µs push(@{$self->{'members'}}, $newMember);
809 }
810
81112µs return AZ_OK;
812}
813
814# Read EOCD, starting from position before signature.
815# Checks for a zip64 EOCD record and uses that if present.
816#
817# Return AZ_OK (in scalar context) or a pair (AZ_OK,
818# $eocdPosition) (in list context) on success:
819# ( $status, $eocdPosition ) = $zip->_readEndOfCentralDirectory( $fh, $fileName );
820# where the returned EOCD position either points to the beginning
821# of the EOCD or to the beginning of the zip64 EOCD record.
822#
823# APPNOTE.TXT as of version 6.3.6 is a bit vague on the
824# "ZIP64(tm) format". It has a lot of conditions like "if an
825# archive is in ZIP64 format", but never explicitly mentions
826# *when* an archive is in that format. (Or at least I haven't
827# found it.)
828#
829# So I decided that an archive is in ZIP64 format if zip64 EOCD
830# locator and zip64 EOCD record are present before the EOCD with
831# the format given in the specification.
832
# spent 49µs (25+24) within Archive::Zip::Archive::_readEndOfCentralDirectory which was called: # once (25µs+24µs) by Archive::Zip::Archive::readFromFileHandle at line 765
sub _readEndOfCentralDirectory {
8331200ns my $self = shift;
8341200ns my $fh = shift;
8351200ns my $fileName = shift;
836
837 # Remember current position, which is just before the EOCD
838 # signature
8391700ns11µs my $eocdPosition = $fh->tell();
# spent 1µs making 1 call to IO::Seekable::tell
840
841 # Reset the zip64 format flag
8421700ns $self->{'zip64'} = 0;
8431300ns my $zip64EOCDPosition;
844
845 # Check for zip64 EOCD locator and zip64 EOCD record. Be
846 # extra careful here to not interpret any random data as
847 # zip64 data structures. If in doubt, silently continue
848 # reading the regular EOCD.
849 NOZIP64:
850 {
851 # Do not even start looking for any zip64 structures if
852 # that would not be supported.
8531100ns if (! ZIP64_SUPPORTED) {
854 last NOZIP64;
855 }
856
8571400ns if ($eocdPosition < ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH + SIGNATURE_LENGTH) {
858 last NOZIP64;
859 }
860
861 # Skip to before potential zip64 EOCD locator
8621700ns12µs $fh->seek(-(ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH) - SIGNATURE_LENGTH,
# spent 2µs making 1 call to IO::Seekable::seek
863 IO::Seekable::SEEK_CUR)
864 or return _ioError("seeking to before zip 64 EOCD locator");
8651700ns my $zip64EOCDLocatorPosition =
866 $eocdPosition - ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH - SIGNATURE_LENGTH;
867
8681200ns my $status;
869 my $bytesRead;
870
871 # Read potential zip64 EOCD locator signature
87211µs113µs $status =
# spent 13µs making 1 call to Archive::Zip::_readSignature
873 _readSignature($fh, $fileName,
874 ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_SIGNATURE, 1);
8751300ns return $status if $status == AZ_IO_ERROR;
8761400ns if ($status == AZ_FORMAT_ERROR) {
877 $fh->seek($eocdPosition, IO::Seekable::SEEK_SET)
878 or return _ioError("seeking to EOCD");
879 last NOZIP64;
880 }
881
882 # Read potential zip64 EOCD locator and verify it
8831300ns my $locator = '';
8841900ns12µs $bytesRead = $fh->read($locator, ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH);
# spent 2µs making 1 call to IO::Handle::read
8851300ns if ($bytesRead != ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH) {
886 return _ioError("reading zip64 EOCD locator");
887 }
88813µs1800ns (undef, $zip64EOCDPosition, undef) =
# spent 800ns making 1 call to CORE::unpack
889 unpack(ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_FORMAT, $locator);
8901600ns if ($zip64EOCDPosition >
891 ($zip64EOCDLocatorPosition - ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_LENGTH - SIGNATURE_LENGTH)) {
892 # No need to seek to EOCD since we're already there
8931800ns last NOZIP64;
894 }
895
896 # Skip to potential zip64 EOCD record
897 $fh->seek($zip64EOCDPosition, IO::Seekable::SEEK_SET)
898 or return _ioError("seeking to zip64 EOCD record");
899
900 # Read potential zip64 EOCD record signature
901 $status =
902 _readSignature($fh, $fileName,
903 ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_SIGNATURE, 1);
904 return $status if $status == AZ_IO_ERROR;
905 if ($status == AZ_FORMAT_ERROR) {
906 $fh->seek($eocdPosition, IO::Seekable::SEEK_SET)
907 or return _ioError("seeking to EOCD");
908 last NOZIP64;
909 }
910
911 # Read potential zip64 EOCD record. Ignore the zip64
912 # extensible data sector.
913 my $record = '';
914 $bytesRead = $fh->read($record, ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_LENGTH);
915 if ($bytesRead != ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_LENGTH) {
916 return _ioError("reading zip64 EOCD record");
917 }
918
919 # Perform one final check, hoping that all implementors
920 # follow the recommendation of the specification
921 # regarding the size of the zip64 EOCD record
922 my ($zip64EODCRecordSize) = unpack("Q<", $record);
923 if ($zip64EOCDPosition + 12 + $zip64EODCRecordSize != $zip64EOCDLocatorPosition) {
924 $fh->seek($eocdPosition, IO::Seekable::SEEK_SET)
925 or return _ioError("seeking to EOCD");
926 last NOZIP64;
927 }
928
929 $self->{'zip64'} = 1;
930 (
931 undef,
932 $self->{'versionMadeBy'},
933 $self->{'versionNeededToExtract'},
934 $self->{'diskNumber'},
935 $self->{'diskNumberWithStartOfCentralDirectory'},
936 $self->{'numberOfCentralDirectoriesOnThisDisk'},
937 $self->{'numberOfCentralDirectories'},
938 $self->{'centralDirectorySize'},
939 $self->{'centralDirectoryOffsetWRTStartingDiskNumber'}
940 ) = unpack(ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_FORMAT, $record);
941
942 # Don't just happily bail out, we still need to read the
943 # zip file comment!
944 $fh->seek($eocdPosition, IO::Seekable::SEEK_SET)
945 or return _ioError("seeking to EOCD");
946 }
947
948 # Skip past signature
9491900ns13µs $fh->seek(SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR)
# spent 3µs making 1 call to IO::Seekable::seek
950 or return _ioError("seeking past EOCD signature");
951
9521400ns my $header = '';
9531800ns12µs my $bytesRead = $fh->read($header, END_OF_CENTRAL_DIRECTORY_LENGTH);
# spent 2µs making 1 call to IO::Handle::read
9541200ns if ($bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH) {
955 return _ioError("reading end of central directory");
956 }
957
9581300ns my $zipfileCommentLength;
9591600ns if (! $self->{'zip64'}) {
960 (
961 $self->{'diskNumber'},
962 $self->{'diskNumberWithStartOfCentralDirectory'},
963 $self->{'numberOfCentralDirectoriesOnThisDisk'},
964 $self->{'numberOfCentralDirectories'},
965 $self->{'centralDirectorySize'},
96613µs1600ns $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
# spent 600ns making 1 call to CORE::unpack
967 $zipfileCommentLength
968 ) = unpack(END_OF_CENTRAL_DIRECTORY_FORMAT, $header);
969
97012µs if ( $self->{'diskNumber'} == 0xffff
971 || $self->{'diskNumberWithStartOfCentralDirectory'} == 0xffff
972 || $self->{'numberOfCentralDirectoriesOnThisDisk'} == 0xffff
973 || $self->{'numberOfCentralDirectories'} == 0xffff
974 || $self->{'centralDirectorySize'} == 0xffffffff
975 || $self->{'centralDirectoryOffsetWRTStartingDiskNumber'} == 0xffffffff) {
976 if (ZIP64_SUPPORTED) {
977 return _formatError("unexpected zip64 marker values in EOCD");
978 }
979 else {
980 return _zip64NotSupported();
981 }
982 }
983 }
984 else {
985 (
986 undef,
987 undef,
988 undef,
989 undef,
990 undef,
991 undef,
992 $zipfileCommentLength
993 ) = unpack(END_OF_CENTRAL_DIRECTORY_FORMAT, $header);
994 }
995
9961300ns if ($zipfileCommentLength) {
997 my $zipfileComment = '';
998 $bytesRead = $fh->read($zipfileComment, $zipfileCommentLength);
999 if ($bytesRead != $zipfileCommentLength) {
1000 return _ioError("reading zipfile comment");
1001 }
1002 $self->{'zipfileComment'} = $zipfileComment;
1003 }
1004
100513µs if (! $self->{'zip64'}) {
1006 return
1007 wantarray
1008 ? (AZ_OK, $eocdPosition)
1009 : AZ_OK;
1010 }
1011 else {
1012 return
1013 wantarray
1014 ? (AZ_OK, $zip64EOCDPosition)
1015 : AZ_OK;
1016 }
1017}
1018
1019# Seek in my file to the end, then read backwards until we find the
1020# signature of the central directory record. Leave the file positioned right
1021# before the signature. Returns AZ_OK if success.
1022
# spent 31µs (16+15) within Archive::Zip::Archive::_findEndOfCentralDirectory which was called: # once (16µs+15µs) by Archive::Zip::Archive::readFromFileHandle at line 761
sub _findEndOfCentralDirectory {
10231200ns my $self = shift;
10241200ns my $fh = shift;
10251500ns my $data = '';
10261900ns12µs $fh->seek(0, IO::Seekable::SEEK_END)
# spent 2µs making 1 call to IO::Seekable::seek
1027 or return _ioError("seeking to end");
1028
102912µs14µs my $fileLength = $fh->tell();
# spent 4µs making 1 call to IO::Seekable::tell
10301500ns if ($fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4) {
1031 return _formatError("file is too short");
1032 }
1033
10341300ns my $seekOffset = 0;
10351200ns my $pos = -1;
10361200ns for (; ;) {
10371300ns $seekOffset += 512;
10381300ns $seekOffset = $fileLength if ($seekOffset > $fileLength);
103911µs12µs $fh->seek(-$seekOffset, IO::Seekable::SEEK_END)
# spent 2µs making 1 call to IO::Seekable::seek
1040 or return _ioError("seek failed");
10411700ns15µs my $bytesRead = $fh->read($data, $seekOffset);
# spent 5µs making 1 call to IO::Handle::read
10421200ns if ($bytesRead != $seekOffset) {
1043 return _ioError("read failed");
1044 }
104511µs $pos = rindex($data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING);
1046 last
10471700ns if ( $pos >= 0
1048 or $seekOffset == $fileLength
1049 or $seekOffset >= $Archive::Zip::ChunkSize);
1050 }
1051
10521400ns if ($pos >= 0) {
105311µs12µs $fh->seek($pos - $seekOffset, IO::Seekable::SEEK_CUR)
# spent 2µs making 1 call to IO::Seekable::seek
1054 or return _ioError("seeking to EOCD");
105512µs return AZ_OK;
1056 } else {
1057 return _formatError("can't find EOCD signature");
1058 }
1059}
1060
1061# Used to avoid taint problems when chdir'ing.
1062# Not intended to increase security in any way; just intended to shut up the -T
1063# complaints. If your Cwd module is giving you unreliable returns from cwd()
1064# you have bigger problems than this.
1065sub _untaintDir {
1066 my $dir = shift;
1067 $dir =~ m/$UNTAINT/s;
1068 return $1;
1069}
1070
1071sub addTree {
1072 my $self = shift;
1073
1074 my ($root, $dest, $pred, $compressionLevel);
1075 if (ref($_[0]) eq 'HASH') {
1076 $root = $_[0]->{root};
1077 $dest = $_[0]->{zipName};
1078 $pred = $_[0]->{select};
1079 $compressionLevel = $_[0]->{compressionLevel};
1080 } else {
1081 ($root, $dest, $pred, $compressionLevel) = @_;
1082 }
1083
1084 return _error("root arg missing in call to addTree()")
1085 unless defined($root);
1086 $dest = '' unless defined($dest);
1087 $pred = sub { -r }
1088 unless defined($pred);
1089
1090 my @files;
1091 my $startDir = _untaintDir(cwd());
1092
1093 return _error('undef returned by _untaintDir on cwd ', cwd())
1094 unless $startDir;
1095
1096 # This avoids chdir'ing in Find, in a way compatible with older
1097 # versions of File::Find.
1098 my $wanted = sub {
1099 local $main::_ = $File::Find::name;
1100 my $dir = _untaintDir($File::Find::dir);
1101 chdir($startDir);
1102 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
1103 push(@files, Win32::GetANSIPathName($File::Find::name)) if (&$pred);
1104 $dir = Win32::GetANSIPathName($dir);
1105 } else {
1106 push(@files, $File::Find::name) if (&$pred);
1107 }
1108 chdir($dir);
1109 };
1110
1111 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
1112 $root = Win32::GetANSIPathName($root);
1113 }
1114 # File::Find will not untaint unless you explicitly pass the flag and regex pattern.
1115 File::Find::find({ wanted => $wanted, untaint => 1, untaint_pattern => $UNTAINT }, $root);
1116
1117 my $rootZipName = _asZipDirName($root, 1); # with trailing slash
1118 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1119
1120 $dest = _asZipDirName($dest, 1); # with trailing slash
1121
1122 foreach my $fileName (@files) {
1123 my $isDir;
1124 if ($^O eq 'MSWin32' && $Archive::Zip::UNICODE) {
1125 $isDir = -d Win32::GetANSIPathName($fileName);
1126 } else {
1127 $isDir = -d $fileName;
1128 }
1129
1130 # normalize, remove leading ./
1131 my $archiveName = _asZipDirName($fileName, $isDir);
1132 if ($archiveName eq $rootZipName) { $archiveName = $dest }
1133 else { $archiveName =~ s{$pattern}{$dest} }
1134 next if $archiveName =~ m{^\.?/?$}; # skip current dir
1135 my $member =
1136 $isDir
1137 ? $self->addDirectory($fileName, $archiveName)
1138 : $self->addFile($fileName, $archiveName);
1139 $member->desiredCompressionLevel($compressionLevel);
1140
1141 return _error("add $fileName failed in addTree()") if !$member;
1142 }
1143 return AZ_OK;
1144}
1145
1146sub addTreeMatching {
1147 my $self = shift;
1148
1149 my ($root, $dest, $pattern, $pred, $compressionLevel);
1150 if (ref($_[0]) eq 'HASH') {
1151 $root = $_[0]->{root};
1152 $dest = $_[0]->{zipName};
1153 $pattern = $_[0]->{pattern};
1154 $pred = $_[0]->{select};
1155 $compressionLevel = $_[0]->{compressionLevel};
1156 } else {
1157 ($root, $dest, $pattern, $pred, $compressionLevel) = @_;
1158 }
1159
1160 return _error("root arg missing in call to addTreeMatching()")
1161 unless defined($root);
1162 $dest = '' unless defined($dest);
1163 return _error("pattern missing in call to addTreeMatching()")
1164 unless defined($pattern);
1165 my $matcher =
1166 $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
1167 return $self->addTree($root, $dest, $matcher, $compressionLevel);
1168}
1169
1170# Check if one of the components of a path to the file or the file name
1171# itself is an already existing symbolic link. If yes then return an
1172# error. Continuing and writing to a file traversing a link posseses
1173# a security threat, especially if the link was extracted from an
1174# attacker-supplied archive. This would allow writing to an arbitrary
1175# file. The same applies when using ".." to escape from a working
1176# directory. <https://bugzilla.redhat.com/show_bug.cgi?id=1591449>
1177sub _extractionNameIsSafe {
1178 my $name = shift;
1179 my ($volume, $directories) = File::Spec->splitpath($name, 1);
1180 my @directories = File::Spec->splitdir($directories);
1181 if (grep '..' eq $_, @directories) {
1182 return _error(
1183 "Could not extract $name safely: a parent directory is used");
1184 }
1185 my @path;
1186 my $path;
1187 for my $directory (@directories) {
1188 push @path, $directory;
1189 $path = File::Spec->catpath($volume, File::Spec->catdir(@path), '');
1190 if (-l $path) {
1191 return _error(
1192 "Could not extract $name safely: $path is an existing symbolic link");
1193 }
1194 if (!-e $path) {
1195 last;
1196 }
1197 }
1198 return AZ_OK;
1199}
1200
1201# $zip->extractTree( $root, $dest [, $volume] );
1202#
1203# $root and $dest are Unix-style.
1204# $volume is in local FS format.
1205#
1206sub extractTree {
1207 my $self = shift;
1208
1209 my ($root, $dest, $volume);
1210 if (ref($_[0]) eq 'HASH') {
1211 $root = $_[0]->{root};
1212 $dest = $_[0]->{zipName};
1213 $volume = $_[0]->{volume};
1214 } else {
1215 ($root, $dest, $volume) = @_;
1216 }
1217
1218 $root = '' unless defined($root);
1219 if (defined $dest) {
1220 if ($dest !~ m{/$}) {
1221 $dest .= '/';
1222 }
1223 } else {
1224 $dest = './';
1225 }
1226
1227 my $pattern = "^\Q$root";
1228 my @members = $self->membersMatching($pattern);
1229
1230 foreach my $member (@members) {
1231 my $fileName = $member->fileName(); # in Unix format
1232 $fileName =~ s{$pattern}{$dest}; # in Unix format
1233 # convert to platform format:
1234 $fileName = Archive::Zip::_asLocalName($fileName, $volume);
1235 if ((my $ret = _extractionNameIsSafe($fileName))
1236 != AZ_OK) { return $ret; }
1237 my $status = $member->extractToFileNamed($fileName);
1238 return $status if $status != AZ_OK;
1239 }
1240 return AZ_OK;
1241}
1242
1243# $zip->updateMember( $memberOrName, $fileName );
1244# Returns (possibly updated) member, if any; undef on errors.
1245
1246sub updateMember {
1247 my $self = shift;
1248
1249 my ($oldMember, $fileName);
1250 if (ref($_[0]) eq 'HASH') {
1251 $oldMember = $_[0]->{memberOrZipName};
1252 $fileName = $_[0]->{name};
1253 } else {
1254 ($oldMember, $fileName) = @_;
1255 }
1256
1257 if (!defined($fileName)) {
1258 _error("updateMember(): missing fileName argument");
1259 return undef;
1260 }
1261
1262 my @newStat = stat($fileName);
1263 if (!@newStat) {
1264 _ioError("Can't stat $fileName");
1265 return undef;
1266 }
1267
1268 my $isDir = -d _;
1269
1270 my $memberName;
1271
1272 if (ref($oldMember)) {
1273 $memberName = $oldMember->fileName();
1274 } else {
1275 $oldMember = $self->memberNamed($memberName = $oldMember)
1276 || $self->memberNamed($memberName =
1277 _asZipDirName($oldMember, $isDir));
1278 }
1279
1280 unless (defined($oldMember)
1281 && $oldMember->lastModTime() == $newStat[9]
1282 && $oldMember->isDirectory() == $isDir
1283 && ($isDir || ($oldMember->uncompressedSize() == $newStat[7]))) {
1284
1285 # create the new member
1286 my $newMember =
1287 $isDir
1288 ? Archive::Zip::Member->newDirectoryNamed($fileName, $memberName)
1289 : Archive::Zip::Member->newFromFile($fileName, $memberName);
1290
1291 unless (defined($newMember)) {
1292 _error("creation of member $fileName failed in updateMember()");
1293 return undef;
1294 }
1295
1296 # replace old member or append new one
1297 if (defined($oldMember)) {
1298 $self->replaceMember($oldMember, $newMember);
1299 } else {
1300 $self->addMember($newMember);
1301 }
1302
1303 return $newMember;
1304 }
1305
1306 return $oldMember;
1307}
1308
1309# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
1310#
1311# This takes the same arguments as addTree, but first checks to see
1312# whether the file or directory already exists in the zip file.
1313#
1314# If the fourth argument $mirror is true, then delete all my members
1315# if corresponding files were not found.
1316
1317sub updateTree {
1318 my $self = shift;
1319
1320 my ($root, $dest, $pred, $mirror, $compressionLevel);
1321 if (ref($_[0]) eq 'HASH') {
1322 $root = $_[0]->{root};
1323 $dest = $_[0]->{zipName};
1324 $pred = $_[0]->{select};
1325 $mirror = $_[0]->{mirror};
1326 $compressionLevel = $_[0]->{compressionLevel};
1327 } else {
1328 ($root, $dest, $pred, $mirror, $compressionLevel) = @_;
1329 }
1330
1331 return _error("root arg missing in call to updateTree()")
1332 unless defined($root);
1333 $dest = '' unless defined($dest);
1334 $pred = sub { -r }
1335 unless defined($pred);
1336
1337 $dest = _asZipDirName($dest, 1);
1338 my $rootZipName = _asZipDirName($root, 1); # with trailing slash
1339 my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
1340
1341 my @files;
1342 my $startDir = _untaintDir(cwd());
1343
1344 return _error('undef returned by _untaintDir on cwd ', cwd())
1345 unless $startDir;
1346
1347 # This avoids chdir'ing in Find, in a way compatible with older
1348 # versions of File::Find.
1349 my $wanted = sub {
1350 local $main::_ = $File::Find::name;
1351 my $dir = _untaintDir($File::Find::dir);
1352 chdir($startDir);
1353 push(@files, $File::Find::name) if (&$pred);
1354 chdir($dir);
1355 };
1356
1357 File::Find::find($wanted, $root);
1358
1359 # Now @files has all the files that I could potentially be adding to
1360 # the zip. Only add the ones that are necessary.
1361 # For each file (updated or not), add its member name to @done.
1362 my %done;
1363 foreach my $fileName (@files) {
1364 my @newStat = stat($fileName);
1365 my $isDir = -d _;
1366
1367 # normalize, remove leading ./
1368 my $memberName = _asZipDirName($fileName, $isDir);
1369 if ($memberName eq $rootZipName) { $memberName = $dest }
1370 else { $memberName =~ s{$pattern}{$dest} }
1371 next if $memberName =~ m{^\.?/?$}; # skip current dir
1372
1373 $done{$memberName} = 1;
1374 my $changedMember = $self->updateMember($memberName, $fileName);
1375 $changedMember->desiredCompressionLevel($compressionLevel);
1376 return _error("updateTree failed to update $fileName")
1377 unless ref($changedMember);
1378 }
1379
1380 # @done now has the archive names corresponding to all the found files.
1381 # If we're mirroring, delete all those members that aren't in @done.
1382 if ($mirror) {
1383 foreach my $member ($self->members()) {
1384 $self->removeMember($member)
1385 unless $done{$member->fileName()};
1386 }
1387 }
1388
1389 return AZ_OK;
1390}
1391
139213µs1;