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 |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.68ms | 2.75ms | BEGIN@7 | Archive::Zip::Archive::
1 | 1 | 1 | 1.50ms | 6.08ms | BEGIN@12 | Archive::Zip::Archive::
1 | 1 | 1 | 1.11ms | 1.40ms | BEGIN@9 | Archive::Zip::Archive::
7 | 1 | 1 | 203µs | 303µs | membersMatching | Archive::Zip::Archive::
1 | 1 | 1 | 115µs | 797µs | readFromFileHandle | Archive::Zip::Archive::
1 | 1 | 1 | 25µs | 49µs | _readEndOfCentralDirectory | Archive::Zip::Archive::
1 | 1 | 1 | 17µs | 25µs | memberNamed | Archive::Zip::Archive::
1 | 1 | 1 | 16µs | 31µs | _findEndOfCentralDirectory | Archive::Zip::Archive::
1 | 1 | 1 | 12µs | 12µs | new | Archive::Zip::Archive::
1 | 1 | 1 | 11µs | 12µs | BEGIN@5 | Archive::Zip::Archive::
1 | 1 | 1 | 10µs | 851µs | read | Archive::Zip::Archive::
8 | 2 | 1 | 9µs | 9µs | members | Archive::Zip::Archive::
1 | 1 | 1 | 7µs | 7µs | BEGIN@16 | Archive::Zip::Archive::
1 | 1 | 1 | 6µs | 28µs | BEGIN@10 | Archive::Zip::Archive::
1 | 1 | 1 | 5µs | 21µs | BEGIN@14 | Archive::Zip::Archive::
1 | 1 | 1 | 4µs | 249µs | BEGIN@21 | Archive::Zip::Archive::
11 | 1 | 1 | 4µs | 4µs | eocdOffset | Archive::Zip::Archive::
1 | 1 | 1 | 4µs | 21µs | BEGIN@11 | Archive::Zip::Archive::
1 | 1 | 1 | 4µs | 22µs | BEGIN@6 | Archive::Zip::Archive::
1 | 1 | 1 | 2µs | 2µs | BEGIN@8 | Archive::Zip::Archive::
1 | 1 | 1 | 2µs | 2µs | zip64 | Archive::Zip::Archive::
2 | 2 | 1 | 1µs | 1µs | centralDirectorySize | Archive::Zip::Archive::
1 | 1 | 1 | 1µs | 1µs | centralDirectoryOffsetWRTStartingDiskNumber | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | __ANON__[:1087] | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | __ANON__[:1109] | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | __ANON__[:1166] | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | __ANON__[:1334] | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | __ANON__[:1355] | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | _extractionNameIsSafe | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | _untaintDir | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | _writeCentralDirectoryOffset | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | _writeEOCDOffset | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | _writeEndOfCentralDirectory | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addDirectory | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addFile | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addFileOrDirectory | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addMember | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addString | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addTree | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | addTreeMatching | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | contents | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | desiredZip64Mode | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | diskNumber | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | diskNumberWithStartOfCentralDirectory | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | extractMember | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | extractMemberWithoutPaths | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | extractTree | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | fileName | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | memberNames | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | numberOfCentralDirectories | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | numberOfCentralDirectoriesOnThisDisk | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | numberOfMembers | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | overwrite | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | overwriteAs | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | removeMember | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | replaceMember | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | storeSymbolicLink | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | updateMember | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | updateTree | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | versionMadeBy | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | versionNeededToExtract | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | writeCentralDirectory | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | writeToFileHandle | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | writeToFileNamed | Archive::Zip::Archive::
0 | 0 | 0 | 0s | 0s | zipfileComment | Archive::Zip::Archive::
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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
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 # 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 | ||||
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 | 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 | ||||
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 | ||||
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 | ||||
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 | 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 | ||||
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 | ||||
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 | ||||
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 | ||||
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 | ||||
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 | ||||
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; |