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