Profile of Archive/Zip/Archive.pm

← 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
Statements | Executed 374 statements in 4.26ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 2.68ms | 2.75ms | Archive::Zip::Archive::::BEGIN@7Archive::Zip::Archive::BEGIN@7
1 | 1 | 1 | 1.50ms | 6.08ms | Archive::Zip::Archive::::BEGIN@12Archive::Zip::Archive::BEGIN@12
1 | 1 | 1 | 1.11ms | 1.40ms | Archive::Zip::Archive::::BEGIN@9Archive::Zip::Archive::BEGIN@9
7 | 1 | 1 | 203µs | 303µs | Archive::Zip::Archive::::membersMatchingArchive::Zip::Archive::membersMatching
1 | 1 | 1 | 115µs | 797µs | Archive::Zip::Archive::::readFromFileHandleArchive::Zip::Archive::readFromFileHandle
1 | 1 | 1 | 25µs | 49µs | Archive::Zip::Archive::::_readEndOfCentralDirectoryArchive::Zip::Archive::_readEndOfCentralDirectory
1 | 1 | 1 | 17µs | 25µs | Archive::Zip::Archive::::memberNamedArchive::Zip::Archive::memberNamed
1 | 1 | 1 | 16µs | 31µs | Archive::Zip::Archive::::_findEndOfCentralDirectoryArchive::Zip::Archive::_findEndOfCentralDirectory
1 | 1 | 1 | 12µs | 12µs | Archive::Zip::Archive::::newArchive::Zip::Archive::new
1 | 1 | 1 | 11µs | 12µs | Archive::Zip::Archive::::BEGIN@5Archive::Zip::Archive::BEGIN@5
1 | 1 | 1 | 10µs | 851µs | Archive::Zip::Archive::::readArchive::Zip::Archive::read
8 | 2 | 1 | 9µs | 9µs | Archive::Zip::Archive::::membersArchive::Zip::Archive::members
1 | 1 | 1 | 7µs | 7µs | Archive::Zip::Archive::::BEGIN@16Archive::Zip::Archive::BEGIN@16
1 | 1 | 1 | 6µs | 28µs | Archive::Zip::Archive::::BEGIN@10Archive::Zip::Archive::BEGIN@10
1 | 1 | 1 | 5µs | 21µs | Archive::Zip::Archive::::BEGIN@14Archive::Zip::Archive::BEGIN@14
1 | 1 | 1 | 4µs | 249µs | Archive::Zip::Archive::::BEGIN@21Archive::Zip::Archive::BEGIN@21
11 | 1 | 1 | 4µs | 4µs | Archive::Zip::Archive::::eocdOffsetArchive::Zip::Archive::eocdOffset
1 | 1 | 1 | 4µs | 21µs | Archive::Zip::Archive::::BEGIN@11Archive::Zip::Archive::BEGIN@11
1 | 1 | 1 | 4µs | 22µs | Archive::Zip::Archive::::BEGIN@6Archive::Zip::Archive::BEGIN@6
1 | 1 | 1 | 2µs | 2µs | Archive::Zip::Archive::::BEGIN@8Archive::Zip::Archive::BEGIN@8
1 | 1 | 1 | 2µs | 2µs | Archive::Zip::Archive::::zip64Archive::Zip::Archive::zip64
2 | 2 | 1 | 1µs | 1µs | Archive::Zip::Archive::::centralDirectorySizeArchive::Zip::Archive::centralDirectorySize
1 | 1 | 1 | 1µs | 1µs | Archive::Zip::Archive::::centralDirectoryOffsetWRTStartingDiskNumberArchive::Zip::Archive::centralDirectoryOffsetWRTStartingDiskNumber
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::__ANON__[:1087]Archive::Zip::Archive::__ANON__[:1087]
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::__ANON__[:1109]Archive::Zip::Archive::__ANON__[:1109]
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::__ANON__[:1166]Archive::Zip::Archive::__ANON__[:1166]
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::__ANON__[:1334]Archive::Zip::Archive::__ANON__[:1334]
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::__ANON__[:1355]Archive::Zip::Archive::__ANON__[:1355]
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::_extractionNameIsSafeArchive::Zip::Archive::_extractionNameIsSafe
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::_untaintDirArchive::Zip::Archive::_untaintDir
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::_writeCentralDirectoryOffsetArchive::Zip::Archive::_writeCentralDirectoryOffset
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::_writeEOCDOffsetArchive::Zip::Archive::_writeEOCDOffset
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::_writeEndOfCentralDirectoryArchive::Zip::Archive::_writeEndOfCentralDirectory
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addDirectoryArchive::Zip::Archive::addDirectory
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addFileArchive::Zip::Archive::addFile
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addFileOrDirectoryArchive::Zip::Archive::addFileOrDirectory
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addMemberArchive::Zip::Archive::addMember
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addStringArchive::Zip::Archive::addString
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addTreeArchive::Zip::Archive::addTree
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::addTreeMatchingArchive::Zip::Archive::addTreeMatching
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::contentsArchive::Zip::Archive::contents
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::desiredZip64ModeArchive::Zip::Archive::desiredZip64Mode
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::diskNumberArchive::Zip::Archive::diskNumber
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::diskNumberWithStartOfCentralDirectoryArchive::Zip::Archive::diskNumberWithStartOfCentralDirectory
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::extractMemberArchive::Zip::Archive::extractMember
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::extractMemberWithoutPathsArchive::Zip::Archive::extractMemberWithoutPaths
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::extractTreeArchive::Zip::Archive::extractTree
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::fileNameArchive::Zip::Archive::fileName
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::memberNamesArchive::Zip::Archive::memberNames
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::numberOfCentralDirectoriesArchive::Zip::Archive::numberOfCentralDirectories
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::numberOfCentralDirectoriesOnThisDiskArchive::Zip::Archive::numberOfCentralDirectoriesOnThisDisk
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::numberOfMembersArchive::Zip::Archive::numberOfMembers
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::overwriteArchive::Zip::Archive::overwrite
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::overwriteAsArchive::Zip::Archive::overwriteAs
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::removeMemberArchive::Zip::Archive::removeMember
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::replaceMemberArchive::Zip::Archive::replaceMember
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::storeSymbolicLinkArchive::Zip::Archive::storeSymbolicLink
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::updateMemberArchive::Zip::Archive::updateMember
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::updateTreeArchive::Zip::Archive::updateTree
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::versionMadeByArchive::Zip::Archive::versionMadeBy
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::versionNeededToExtractArchive::Zip::Archive::versionNeededToExtract
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::writeCentralDirectoryArchive::Zip::Archive::writeCentralDirectory
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::writeToFileHandleArchive::Zip::Archive::writeToFileHandle
0 | 0 | 0 | 0s | 0s | Archive::Zip::Archive::::writeToFileNamedArchive::Zip::Archive::writeToFileNamed
0 | 0 | 0 | 0s | 0s | Archive::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Archive::Zip::Archive;
2 |  |  |  |  |
3 |  |  |  |  | # Represents a generic ZIP archive
4 |  |  |  |  |
5 | 2 | 20µs | 2 | 14µ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
6 | 2 | 14µs | 2 | 40µ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
7 | 2 | 94µs | 1 | 2.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
8 | 2 | 10µs | 1 | 2µ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
9 | 2 | 81µs | 1 | 1.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
10 | 2 | 16µs | 2 | 50µ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
11 | 2 | 16µs | 2 | 38µ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
12 | 2 | 72µs | 2 | 6.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 |  |  |  |  |
14 | 2 | 25µs | 2 | 36µ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 {
17 | 1 | 200ns |  |  | $VERSION = '1.68';
18 | 1 | 7µs |  |  | @ISA = qw( Archive::Zip );
19 | 1 | 15µs | 1 | 7µs | } # spent 7µs making 1 call to Archive::Zip::Archive::BEGIN@16
20 |  |  |  |  |
21 | 1 | 3µs | 1 | 244µ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
26 | 1 | 3.47ms | 1 | 249µs | ); # spent 249µs making 1 call to Archive::Zip::Archive::BEGIN@21
27 |  |  |  |  |
28 |  |  |  |  | our $UNICODE;
29 | 1 | 5µs | 1 | 1µs | our $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 {
34 | 1 | 200ns |  |  | 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
43 | 1 | 6µ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 |  |  |  |  | );
66 | 1 | 3µs |  |  | $self->{'members'} = [];
67 | 1 | 900ns |  |  | my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift;
68 | 1 | 200ns |  |  | if ($fileName) {
69 |  |  |  |  | my $status = $self->read($fileName);
70 |  |  |  |  | return $status == AZ_OK ? $self : undef;
71 |  |  |  |  | }
72 | 1 | 2µs |  |  | return $self;
73 |  |  |  |  | }
74 |  |  |  |  |
75 |  |  |  |  | sub 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 {
81 | 8 | 14µs |  |  | @{shift->{'members'}};
82 |  |  |  |  | }
83 |  |  |  |  |
84 |  |  |  |  | sub numberOfMembers {
85 |  |  |  |  | scalar(shift->members());
86 |  |  |  |  | }
87 |  |  |  |  |
88 |  |  |  |  | sub 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 {
95 | 1 | 200ns |  |  | my $self = shift;
96 | 1 | 1µs |  |  | my $fileName = (ref($_[0]) eq 'HASH') ? shift->{zipName} : shift;
97 | 1 | 2µs | 1 | 2µs | foreach my $member ($self->members()) { # spent 2µs making 1 call to Archive::Zip::Archive::members
98 | 10 | 6µs | 10 | 6µs | return $member if $member->fileName() eq $fileName; # spent 6µs making 10 calls to Archive::Zip::Member::fileName, avg 650ns/call
99 |  |  |  |  | }
100 | 1 | 2µ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 {
104 | 7 | 1µs |  |  | my $self = shift;
105 | 7 | 5µs |  |  | my $pattern = (ref($_[0]) eq 'HASH') ? shift->{regex} : shift;
106 | 77 | 225µs | 217 | 100µ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 {
110 | 1 | 2µs |  |  | shift->{'zip64'};
111 |  |  |  |  | }
112 |  |  |  |  |
113 |  |  |  |  | sub 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 |  |  |  |  |
123 |  |  |  |  | sub versionMadeBy {
124 |  |  |  |  | shift->{'versionMadeBy'};
125 |  |  |  |  | }
126 |  |  |  |  |
127 |  |  |  |  | sub versionNeededToExtract {
128 |  |  |  |  | shift->{'versionNeededToExtract'};
129 |  |  |  |  | }
130 |  |  |  |  |
131 |  |  |  |  | sub diskNumber {
132 |  |  |  |  | shift->{'diskNumber'};
133 |  |  |  |  | }
134 |  |  |  |  |
135 |  |  |  |  | sub diskNumberWithStartOfCentralDirectory {
136 |  |  |  |  | shift->{'diskNumberWithStartOfCentralDirectory'};
137 |  |  |  |  | }
138 |  |  |  |  |
139 |  |  |  |  | sub numberOfCentralDirectoriesOnThisDisk {
140 |  |  |  |  | shift->{'numberOfCentralDirectoriesOnThisDisk'};
141 |  |  |  |  | }
142 |  |  |  |  |
143 |  |  |  |  | sub 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 {
148 | 2 | 2µ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 {
152 | 1 | 1µs |  |  | shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
153 |  |  |  |  | }
154 |  |  |  |  |
155 |  |  |  |  | sub 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 {
166 | 11 | 9µs |  |  | shift->{'eocdOffset'};
167 |  |  |  |  | }
168 |  |  |  |  |
169 |  |  |  |  | # Return the name of the file last read.
170 |  |  |  |  | sub fileName {
171 |  |  |  |  | shift->{'fileName'};
172 |  |  |  |  | }
173 |  |  |  |  |
174 |  |  |  |  | sub 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 |  |  |  |  |
184 |  |  |  |  | sub 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 |  |  |  |  |
204 |  |  |  |  | sub 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 |  |  |  |  |
241 |  |  |  |  | sub 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 |  |  |  |  |
268 |  |  |  |  | sub 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 |  |  |  |  |
279 |  |  |  |  | sub 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 |  |  |  |  |
311 |  |  |  |  | sub 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 |  |  |  |  |
329 |  |  |  |  | sub 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 |  |  |  |  |
362 |  |  |  |  | sub 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 |  |  |  |  |
393 |  |  |  |  | sub 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 |  |  |  |  |
423 |  |  |  |  | sub 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.
445 |  |  |  |  | sub 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.
529 |  |  |  |  | sub 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.
537 |  |  |  |  | sub 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
585 |  |  |  |  | sub _writeCentralDirectoryOffset {
586 |  |  |  |  | shift->{'writeCentralDirectoryOffset'};
587 |  |  |  |  | }
588 |  |  |  |  |
589 |  |  |  |  | sub _writeEOCDOffset {
590 |  |  |  |  | shift->{'writeEOCDOffset'};
591 |  |  |  |  | }
592 |  |  |  |  |
593 |  |  |  |  | # Expects to have _writeEOCDOffset() set
594 |  |  |  |  | sub _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.
690 |  |  |  |  | sub 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 {
723 | 1 | 300ns |  |  | my $self = shift;
724 | 1 | 600ns |  |  | my $fileName = (ref($_[0]) eq 'HASH') ? shift->{filename} : shift;
725 | 1 | 200ns |  |  | return _error('No filename given') unless $fileName;
726 | 1 | 2µs | 1 | 38µs | my ($status, $fh) = _newFileHandle($fileName, 'r'); # spent 38µs making 1 call to Archive::Zip::_newFileHandle
727 | 1 | 200ns |  |  | return _ioError("opening $fileName for read") unless $status;
728 |  |  |  |  |
729 | 1 | 2µs | 1 | 797µs | $status = $self->readFromFileHandle($fh, $fileName); # spent 797µs making 1 call to Archive::Zip::Archive::readFromFileHandle
730 | 1 | 300ns |  |  | return $status if $status != AZ_OK;
731 |  |  |  |  |
732 | 1 | 900ns | 1 | 6µs | $fh->close(); # spent 6µs making 1 call to IO::Handle::close
733 | 1 | 500ns |  |  | $self->{'fileName'} = $fileName;
734 | 1 | 2µ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 {
738 | 1 | 200ns |  |  | my $self = shift;
739 |  |  |  |  |
740 | 1 | 200ns |  |  | my ($fh, $fileName);
741 | 1 | 900ns |  |  | if (ref($_[0]) eq 'HASH') {
742 |  |  |  |  | $fh = $_[0]->{fileHandle};
743 |  |  |  |  | $fileName = $_[0]->{filename};
744 |  |  |  |  | } else {
745 | 1 | 600ns |  |  | ($fh, $fileName) = @_;
746 |  |  |  |  | }
747 |  |  |  |  |
748 | 1 | 400ns |  |  | $fileName = $fh unless defined($fileName);
749 | 1 | 300ns |  |  | return _error('No filehandle given') unless $fh;
750 | 1 | 2µs | 1 | 2µs | return _ioError('filehandle not open') unless $fh->opened(); # spent 2µs making 1 call to IO::Handle::opened
751 |  |  |  |  |
752 | 1 | 1µs | 1 | 18µs | _binmode($fh); # spent 18µs making 1 call to Archive::Zip::_binmode
753 | 1 | 1µs |  |  | $self->{'fileName'} = "$fh";
754 |  |  |  |  |
755 |  |  |  |  | # TODO: how to support non-seekable zips?
756 | 1 | 2µs | 1 | 20µs | return _error('file not seekable') # spent 20µs making 1 call to Archive::Zip::_isSeekable
757 |  |  |  |  | unless _isSeekable($fh);
758 |  |  |  |  |
759 | 1 | 2µs | 1 | 5µs | $fh->seek(0, 0); # rewind the file # spent 5µs making 1 call to IO::Seekable::seek
760 |  |  |  |  |
761 | 1 | 2µs | 1 | 31µs | my $status = $self->_findEndOfCentralDirectory($fh); # spent 31µs making 1 call to Archive::Zip::Archive::_findEndOfCentralDirectory
762 | 1 | 700ns |  |  | return $status if $status != AZ_OK;
763 |  |  |  |  |
764 | 1 | 100ns |  |  | my $eocdPosition;
765 | 1 | 2µs | 1 | 49µs | ($status, $eocdPosition) = $self->_readEndOfCentralDirectory($fh, $fileName); # spent 49µs making 1 call to Archive::Zip::Archive::_readEndOfCentralDirectory
766 | 1 | 300ns |  |  | return $status if $status != AZ_OK;
767 |  |  |  |  |
768 | 1 | 2µs | 1 | 2µs | my $zip64 = $self->zip64(); # spent 2µs making 1 call to Archive::Zip::Archive::zip64
769 |  |  |  |  |
770 | 1 | 2µs | 2 | 3µ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
776 | 1 | 2µs | 2 | 1µs | $self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here # spent 1µs making 1 call to Archive::Zip::Archive::centralDirectoryOffsetWRTStartingDiskNumber # spent 200ns making 1 call to Archive::Zip::Archive::centralDirectorySize
777 |  |  |  |  | - $self->centralDirectoryOffsetWRTStartingDiskNumber();
778 |  |  |  |  |
779 | 1 | 200ns |  |  | for (; ;) {
780 | 11 | 14µs | 22 | 271µ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());
783 | 11 | 800ns |  |  | my $signature;
784 | 11 | 7µs | 11 | 56µs | ($status, $signature) = _readSignature($fh, $fileName); # spent 56µs making 11 calls to Archive::Zip::_readSignature, avg 5µs/call
785 | 11 | 1µs |  |  | return $status if $status != AZ_OK;
786 | 11 | 3µs |  |  | if (! $zip64) {
787 | 11 | 7µs |  |  | last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
788 |  |  |  |  | }
789 |  |  |  |  | else {
790 |  |  |  |  | last if $signature == ZIP64_END_OF_CENTRAL_DIRECTORY_RECORD_SIGNATURE;
791 |  |  |  |  | }
792 | 10 | 6µs | 10 | 178µs | $status = $newMember->_readCentralDirectoryFileHeader(); # spent 178µs making 10 calls to Archive::Zip::ZipFileMember::_readCentralDirectoryFileHeader, avg 18µs/call
793 | 10 | 1µs |  |  | return $status if $status != AZ_OK;
794 | 10 | 7µs | 10 | 28µs | $status = $newMember->endRead(); # spent 28µs making 10 calls to Archive::Zip::FileMember::endRead, avg 3µs/call
795 | 10 | 1µs |  |  | return $status if $status != AZ_OK;
796 |  |  |  |  |
797 | 10 | 5µs | 10 | 19µ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 |  |  |  |  |
804 | 10 | 2µs |  |  | if(($newMember->{bitFlag} & 0x800) && !utf8::is_utf8($newMember->{fileName})){
805 |  |  |  |  | $newMember->{fileName} = Encode::decode_utf8($newMember->{fileName});
806 |  |  |  |  | }
807 |  |  |  |  |
808 | 10 | 6µs |  |  | push(@{$self->{'members'}}, $newMember);
809 |  |  |  |  | }
810 |  |  |  |  |
811 | 1 | 2µ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 {
833 | 1 | 200ns |  |  | my $self = shift;
834 | 1 | 200ns |  |  | my $fh = shift;
835 | 1 | 200ns |  |  | my $fileName = shift;
836 |  |  |  |  |
837 |  |  |  |  | # Remember current position, which is just before the EOCD
838 |  |  |  |  | # signature
839 | 1 | 700ns | 1 | 1µs | my $eocdPosition = $fh->tell(); # spent 1µs making 1 call to IO::Seekable::tell
840 |  |  |  |  |
841 |  |  |  |  | # Reset the zip64 format flag
842 | 1 | 700ns |  |  | $self->{'zip64'} = 0;
843 | 1 | 300ns |  |  | 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.
853 | 1 | 100ns |  |  | if (! ZIP64_SUPPORTED) {
854 |  |  |  |  | last NOZIP64;
855 |  |  |  |  | }
856 |  |  |  |  |
857 | 1 | 400ns |  |  | if ($eocdPosition < ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH + SIGNATURE_LENGTH) {
858 |  |  |  |  | last NOZIP64;
859 |  |  |  |  | }
860 |  |  |  |  |
861 |  |  |  |  | # Skip to before potential zip64 EOCD locator
862 | 1 | 700ns | 1 | 2µ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");
865 | 1 | 700ns |  |  | my $zip64EOCDLocatorPosition =
866 |  |  |  |  | $eocdPosition - ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH - SIGNATURE_LENGTH;
867 |  |  |  |  |
868 | 1 | 200ns |  |  | my $status;
869 |  |  |  |  | my $bytesRead;
870 |  |  |  |  |
871 |  |  |  |  | # Read potential zip64 EOCD locator signature
872 | 1 | 1µs | 1 | 13µ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);
875 | 1 | 300ns |  |  | return $status if $status == AZ_IO_ERROR;
876 | 1 | 400ns |  |  | 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
883 | 1 | 300ns |  |  | my $locator = '';
884 | 1 | 900ns | 1 | 2µs | $bytesRead = $fh->read($locator, ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH); # spent 2µs making 1 call to IO::Handle::read
885 | 1 | 300ns |  |  | if ($bytesRead != ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_LENGTH) {
886 |  |  |  |  | return _ioError("reading zip64 EOCD locator");
887 |  |  |  |  | }
888 | 1 | 3µs | 1 | 800ns | (undef, $zip64EOCDPosition, undef) = # spent 800ns making 1 call to CORE::unpack
889 |  |  |  |  | unpack(ZIP64_END_OF_CENTRAL_DIRECTORY_LOCATOR_FORMAT, $locator);
890 | 1 | 600ns |  |  | 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
893 | 1 | 800ns |  |  | 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
949 | 1 | 900ns | 1 | 3µ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 |  |  |  |  |
952 | 1 | 400ns |  |  | my $header = '';
953 | 1 | 800ns | 1 | 2µs | my $bytesRead = $fh->read($header, END_OF_CENTRAL_DIRECTORY_LENGTH); # spent 2µs making 1 call to IO::Handle::read
954 | 1 | 200ns |  |  | if ($bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH) {
955 |  |  |  |  | return _ioError("reading end of central directory");
956 |  |  |  |  | }
957 |  |  |  |  |
958 | 1 | 300ns |  |  | my $zipfileCommentLength;
959 | 1 | 600ns |  |  | if (! $self->{'zip64'}) {
960 |  |  |  |  | (
961 |  |  |  |  | $self->{'diskNumber'},
962 |  |  |  |  | $self->{'diskNumberWithStartOfCentralDirectory'},
963 |  |  |  |  | $self->{'numberOfCentralDirectoriesOnThisDisk'},
964 |  |  |  |  | $self->{'numberOfCentralDirectories'},
965 |  |  |  |  | $self->{'centralDirectorySize'},
966 | 1 | 3µs | 1 | 600ns | $self->{'centralDirectoryOffsetWRTStartingDiskNumber'}, # spent 600ns making 1 call to CORE::unpack
967 |  |  |  |  | $zipfileCommentLength
968 |  |  |  |  | ) = unpack(END_OF_CENTRAL_DIRECTORY_FORMAT, $header);
969 |  |  |  |  |
970 | 1 | 2µ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 |  |  |  |  |
996 | 1 | 300ns |  |  | 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 |  |  |  |  |
1005 | 1 | 3µ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 {
1023 | 1 | 200ns |  |  | my $self = shift;
1024 | 1 | 200ns |  |  | my $fh = shift;
1025 | 1 | 500ns |  |  | my $data = '';
1026 | 1 | 900ns | 1 | 2µ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 |  |  |  |  |
1029 | 1 | 2µs | 1 | 4µs | my $fileLength = $fh->tell(); # spent 4µs making 1 call to IO::Seekable::tell
1030 | 1 | 500ns |  |  | if ($fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4) {
1031 |  |  |  |  | return _formatError("file is too short");
1032 |  |  |  |  | }
1033 |  |  |  |  |
1034 | 1 | 300ns |  |  | my $seekOffset = 0;
1035 | 1 | 200ns |  |  | my $pos = -1;
1036 | 1 | 200ns |  |  | for (; ;) {
1037 | 1 | 300ns |  |  | $seekOffset += 512;
1038 | 1 | 300ns |  |  | $seekOffset = $fileLength if ($seekOffset > $fileLength);
1039 | 1 | 1µs | 1 | 2µs | $fh->seek(-$seekOffset, IO::Seekable::SEEK_END) # spent 2µs making 1 call to IO::Seekable::seek
1040 |  |  |  |  | or return _ioError("seek failed");
1041 | 1 | 700ns | 1 | 5µs | my $bytesRead = $fh->read($data, $seekOffset); # spent 5µs making 1 call to IO::Handle::read
1042 | 1 | 200ns |  |  | if ($bytesRead != $seekOffset) {
1043 |  |  |  |  | return _ioError("read failed");
1044 |  |  |  |  | }
1045 | 1 | 1µs |  |  | $pos = rindex($data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING);
1046 |  |  |  |  | last
1047 | 1 | 700ns |  |  | if ( $pos >= 0
1048 |  |  |  |  | or $seekOffset == $fileLength
1049 |  |  |  |  | or $seekOffset >= $Archive::Zip::ChunkSize);
1050 |  |  |  |  | }
1051 |  |  |  |  |
1052 | 1 | 400ns |  |  | if ($pos >= 0) {
1053 | 1 | 1µs | 1 | 2µ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");
1055 | 1 | 2µ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.
1065 |  |  |  |  | sub _untaintDir {
1066 |  |  |  |  | my $dir = shift;
1067 |  |  |  |  | $dir =~ m/$UNTAINT/s;
1068 |  |  |  |  | return $1;
1069 |  |  |  |  | }
1070 |  |  |  |  |
1071 |  |  |  |  | sub 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 |  |  |  |  |
1146 |  |  |  |  | sub 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>
1177 |  |  |  |  | sub _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 |  |  |  |  | #
1206 |  |  |  |  | sub 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 |  |  |  |  |
1246 |  |  |  |  | sub 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 |  |  |  |  |
1317 |  |  |  |  | sub 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 |  |  |  |  |
1392 | 1 | 3µs |  |  | 1;