← Index
NYTProf Performance Profile   « line view »
For /usr/sbin/pkg_info
  Run on Fri Aug 4 10:12:01 2017
Reported on Fri Aug 4 10:12:17 2017

Filename/usr/libdata/perl5/OpenBSD/Ustar.pm
StatementsExecuted 165 statements in 6.71ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.55ms1.74msOpenBSD::Ustar::::BEGIN@48 OpenBSD::Ustar::BEGIN@48
111541µs581µsOpenBSD::Ustar::::BEGIN@49 OpenBSD::Ustar::BEGIN@49
211214µs642µsOpenBSD::Ustar::::next OpenBSD::Ustar::next
21144µs124µsOpenBSD::Ustar::File::::contents OpenBSD::Ustar::File::contents
21138µs38µsOpenBSD::Ustar::::new OpenBSD::Ustar::new
21137µs127µsOpenBSD::Ustar::::CORE:read OpenBSD::Ustar::CORE:read (opcode)
84128µs28µsOpenBSD::Ustar::::CORE:subst OpenBSD::Ustar::CORE:subst (opcode)
11126µs577µsOpenBSD::Ustar::::BEGIN@25 OpenBSD::Ustar::BEGIN@25
21123µs23µsOpenBSD::Ustar::::new_object OpenBSD::Ustar::new_object
11121µs27µsOpenBSD::PackageLocation::::BEGIN@20OpenBSD::PackageLocation::BEGIN@20
42120µs20µsOpenBSD::Ustar::::CORE:unpack OpenBSD::Ustar::CORE:unpack (opcode)
11116µs28µsOpenBSD::PackageLocation::::BEGIN@21OpenBSD::PackageLocation::BEGIN@21
11114µs36µsOpenBSD::Ustar::::BEGIN@221 OpenBSD::Ustar::BEGIN@221
11114µs166µsOpenBSD::CompactWriter::::BEGIN@738 OpenBSD::CompactWriter::BEGIN@738
11111µs11µsOpenBSD::Ustar::::BEGIN@50 OpenBSD::Ustar::BEGIN@50
21110µs10µsOpenBSD::Ustar::::set_description OpenBSD::Ustar::set_description
21110µs80µsOpenBSD::Ustar::File::::CORE:read OpenBSD::Ustar::File::CORE:read (opcode)
2119µs9µsOpenBSD::Ustar::::skip OpenBSD::Ustar::skip
2116µs6µsOpenBSD::Ustar::::CORE:match OpenBSD::Ustar::CORE:match (opcode)
4224µs4µsOpenBSD::Ustar::File::::isFile OpenBSD::Ustar::File::isFile (xsub)
0000s0sOpenBSD::CompactWriter::::close OpenBSD::CompactWriter::close
0000s0sOpenBSD::CompactWriter::::new OpenBSD::CompactWriter::new
0000s0sOpenBSD::CompactWriter::::write OpenBSD::CompactWriter::write
0000s0sOpenBSD::UStar::Device::::create OpenBSD::UStar::Device::create
0000s0sOpenBSD::Ustar::Dir::::create OpenBSD::Ustar::Dir::create
0000s0sOpenBSD::Ustar::Fifo::::create OpenBSD::Ustar::Fifo::create
0000s0sOpenBSD::Ustar::File::::copy_contents OpenBSD::Ustar::File::copy_contents
0000s0sOpenBSD::Ustar::File::::create OpenBSD::Ustar::File::create
0000s0sOpenBSD::Ustar::File::::write_contents OpenBSD::Ustar::File::write_contents
0000s0sOpenBSD::Ustar::HardLink::::createOpenBSD::Ustar::HardLink::create
0000s0sOpenBSD::Ustar::HardLink::::resolve_linksOpenBSD::Ustar::HardLink::resolve_links
0000s0sOpenBSD::Ustar::Object::::alias OpenBSD::Ustar::Object::alias
0000s0sOpenBSD::Ustar::Object::::copy OpenBSD::Ustar::Object::copy
0000s0sOpenBSD::Ustar::Object::::copy_contents OpenBSD::Ustar::Object::copy_contents
0000s0sOpenBSD::Ustar::Object::::ensure_dir OpenBSD::Ustar::Object::ensure_dir
0000s0sOpenBSD::Ustar::Object::::errsay OpenBSD::Ustar::Object::errsay
0000s0sOpenBSD::Ustar::Object::::fatal OpenBSD::Ustar::Object::fatal
0000s0sOpenBSD::Ustar::Object::::left_todo OpenBSD::Ustar::Object::left_todo
0000s0sOpenBSD::Ustar::Object::::make_basedir OpenBSD::Ustar::Object::make_basedir
0000s0sOpenBSD::Ustar::Object::::name OpenBSD::Ustar::Object::name
0000s0sOpenBSD::Ustar::Object::::recheck_owner OpenBSD::Ustar::Object::recheck_owner
0000s0sOpenBSD::Ustar::Object::::resolve_links OpenBSD::Ustar::Object::resolve_links
0000s0sOpenBSD::Ustar::Object::::set_modes OpenBSD::Ustar::Object::set_modes
0000s0sOpenBSD::Ustar::Object::::set_name OpenBSD::Ustar::Object::set_name
0000s0sOpenBSD::Ustar::Object::::system OpenBSD::Ustar::Object::system
0000s0sOpenBSD::Ustar::Object::::write OpenBSD::Ustar::Object::write
0000s0sOpenBSD::Ustar::Object::::write_contents OpenBSD::Ustar::Object::write_contents
0000s0sOpenBSD::Ustar::SoftLink::::createOpenBSD::Ustar::SoftLink::create
0000s0sOpenBSD::Ustar::::close OpenBSD::Ustar::close
0000s0sOpenBSD::Ustar::::destdir OpenBSD::Ustar::destdir
0000s0sOpenBSD::Ustar::::extended_record OpenBSD::Ustar::extended_record
0000s0sOpenBSD::Ustar::::fatal OpenBSD::Ustar::fatal
0000s0sOpenBSD::Ustar::::fh OpenBSD::Ustar::fh
0000s0sOpenBSD::Ustar::::mkheader OpenBSD::Ustar::mkheader
0000s0sOpenBSD::Ustar::::pack_header OpenBSD::Ustar::pack_header
0000s0sOpenBSD::Ustar::::pad OpenBSD::Ustar::pad
0000s0sOpenBSD::Ustar::::parse_records OpenBSD::Ustar::parse_records
0000s0sOpenBSD::Ustar::::prepare OpenBSD::Ustar::prepare
0000s0sOpenBSD::Ustar::::read_records OpenBSD::Ustar::read_records
0000s0sOpenBSD::Ustar::::set_callback OpenBSD::Ustar::set_callback
0000s0sOpenBSD::Ustar::::split_name OpenBSD::Ustar::split_name
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# ex:ts=8 sw=4:
2# $OpenBSD: Ustar.pm,v 1.88 2017/07/23 10:34:44 espie Exp $
3#
4# Copyright (c) 2002-2014 Marc Espie <espie@openbsd.org>
5#
6# Permission to use, copy, modify, and distribute this software for any
7# purpose with or without fee is hereby granted, provided that the above
8# copyright notice and this permission notice appear in all copies.
9#
10# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
18# Handle utar archives
19
20255µs232µs
# spent 27µs (21+6) within OpenBSD::PackageLocation::BEGIN@20 which was called: # once (21µs+6µs) by OpenBSD::PackageLocation::_opened at line 20
use strict;
# spent 27µs making 1 call to OpenBSD::PackageLocation::BEGIN@20 # spent 6µs making 1 call to strict::import
212108µs241µs
# spent 28µs (16+12) within OpenBSD::PackageLocation::BEGIN@21 which was called: # once (16µs+12µs) by OpenBSD::PackageLocation::_opened at line 21
use warnings;
# spent 28µs making 1 call to OpenBSD::PackageLocation::BEGIN@21 # spent 12µs making 1 call to warnings::import
22
23package OpenBSD::Ustar;
24
25
# spent 577µs (26+551) within OpenBSD::Ustar::BEGIN@25 which was called: # once (26µs+551µs) by OpenBSD::PackageLocation::_opened at line 46
use constant {
2611µs FILE => "\0",
27 FILE1 => '0',
28 HARDLINK => '1',
29 SOFTLINK => '2',
30 CHARDEVICE => '3',
31 BLOCKDEVICE => '4',
32 DIR => '5',
33 FIFO => '6',
34 CONTFILE => '7',
35 USTAR_HEADER => 'a100a8a8a8a12a12a8aa100a6a2a32a32a8a8a155a12',
36 MAXFILENAME => 100,
37 MAXLINKNAME => 100,
38 MAXPREFIX => 155,
39 MAXUSERNAME => 32,
40 MAXGROUPNAME => 32,
41 XHDR => 'x',
42 # XXX those are NOT supported, just recognized
43 GHDR => 'g',
44 LONGLINK => 'K',
45 LONGNAME => 'L',
46155µs21.13ms};
# spent 577µs making 1 call to OpenBSD::Ustar::BEGIN@25 # spent 551µs making 1 call to constant::import
47
482193µs11.74ms
# spent 1.74ms (1.55+184µs) within OpenBSD::Ustar::BEGIN@48 which was called: # once (1.55ms+184µs) by OpenBSD::PackageLocation::_opened at line 48
use File::Basename ();
# spent 1.74ms making 1 call to OpenBSD::Ustar::BEGIN@48
492127µs1581µs
# spent 581µs (541+40) within OpenBSD::Ustar::BEGIN@49 which was called: # once (541µs+40µs) by OpenBSD::PackageLocation::_opened at line 49
use OpenBSD::IdCache;
# spent 581µs making 1 call to OpenBSD::Ustar::BEGIN@49
5021.93ms111µs
# spent 11µs within OpenBSD::Ustar::BEGIN@50 which was called: # once (11µs+0s) by OpenBSD::PackageLocation::_opened at line 50
use OpenBSD::Paths;
# spent 11µs making 1 call to OpenBSD::Ustar::BEGIN@50
51
5216µs14µsour $uidcache = new OpenBSD::UidCache;
# spent 4µs making 1 call to OpenBSD::SimpleIdCache::new
5314µs13µsour $gidcache = new OpenBSD::GidCache;
# spent 3µs making 1 call to OpenBSD::SimpleIdCache::new
5413µs12µsour $unamecache = new OpenBSD::UnameCache;
# spent 2µs making 1 call to OpenBSD::SimpleIdCache::new
5513µs12µsour $gnamecache = new OpenBSD::GnameCache;
# spent 2µs making 1 call to OpenBSD::SimpleIdCache::new
56
57# This is a multiple of st_blksize everywhere....
581600nsmy $buffsize = 2 * 1024 * 1024;
59
60sub new
61
# spent 38µs within OpenBSD::Ustar::new which was called 2 times, avg 19µs/call: # 2 times (38µs+0s) by OpenBSD::PackageLocation::_opened at line 87 of OpenBSD/PackageLocation.pm, avg 19µs/call
{
6224µs my ($class, $fh, $state, $destdir) = @_;
63
6422µs $destdir = '' unless defined $destdir;
65
66230µs return bless {
67 fh => $fh,
68 swallow => 0,
69 state => $state,
70 key => {},
71 destdir => $destdir} , $class;
72}
73
74sub set_description
75
# spent 10µs within OpenBSD::Ustar::set_description which was called 2 times, avg 5µs/call: # 2 times (10µs+0s) by OpenBSD::PackageLocation::_opened at line 88 of OpenBSD/PackageLocation.pm, avg 5µs/call
{
7622µs my ($self, $d) = @_;
77213µs $self->{description} = $d;
78}
79
80sub set_callback
81{
82 my ($self, $code) = @_;
83 $self->{callback} = $code;
84}
85
86sub fatal
87{
88 my ($self, $msg, @args) = @_;
89 $self->{state}->fatal("Ustar [#1][#2]: #3",
90 $self->{description} // '?', $self->{lastname} // '?',
91 $self->{state}->f($msg, @args));
92}
93
94sub new_object
95
# spent 23µs within OpenBSD::Ustar::new_object which was called 2 times, avg 12µs/call: # 2 times (23µs+0s) by OpenBSD::Ustar::next at line 256, avg 12µs/call
{
9622µs my ($self, $h, $class) = @_;
9723µs $h->{archive} = $self;
9822µs $h->{destdir} = $self->{destdir};
9928µs bless $h, $class;
10028µs return $h;
101}
102
103sub skip
104
# spent 9µs within OpenBSD::Ustar::skip which was called 2 times, avg 5µs/call: # 2 times (9µs+0s) by OpenBSD::Ustar::next at line 186, avg 5µs/call
{
10522µs my $self = shift;
10622µs my $temp;
107
108214µs while ($self->{swallow} > 0) {
109 my $toread = $self->{swallow};
110 if ($toread >$buffsize) {
111 $toread = $buffsize;
112 }
113 my $actual = read($self->{fh}, $temp, $toread);
114 if (!defined $actual) {
115 $self->fatal("Error while skipping archive: #1", $!);
116 }
117 if ($actual == 0) {
118 $self->fatal("Premature end of archive in header: #1", $!);
119 }
120 $self->{swallow} -= $actual;
121 }
122}
123
12415µsmy $types = {
125 DIR , 'OpenBSD::Ustar::Dir',
126 HARDLINK , 'OpenBSD::Ustar::HardLink',
127 SOFTLINK , 'OpenBSD::Ustar::SoftLink',
128 FILE , 'OpenBSD::Ustar::File',
129 FILE1 , 'OpenBSD::Ustar::File',
130 FIFO , 'OpenBSD::Ustar::Fifo',
131 CHARDEVICE , 'OpenBSD::Ustar::CharDevice',
132 BLOCKDEVICE , 'OpenBSD::Ustar::BlockDevice',
133};
134
13512µsmy $unsupported = {
136 XHDR => 'Extended header',
137 GHDR => 'GNU header',
138 LONGLINK => 'Long symlink',
139 LONGNAME => 'Long file',
140};
141
142sub read_records
143{
144 my ($self, $size) = @_;
145 my $toread = $self->{swallow};
146 my $result = '';
147 while ($toread > 0) {
148 my $buffer;
149 my $maxread = $buffsize;
150 $maxread = $toread if $maxread > $toread;
151 my $actual = read($self->{fh}, $buffer, $maxread);
152 if (!defined $actual) {
153 $self->fatal("Error reading from archive: #1", $!);
154 }
155 if ($actual == 0) {
156 $self->fatal("Premature end of archive");
157 }
158 $self->{swallow} -= $actual;
159 $toread -= $actual;
160 $result .= $buffer;
161 }
162 return substr($result, 0, $size);
163}
164
165sub parse_records
166{
167 my ($self, $result, $h) = @_;
168 open(my $fh, '<', \$h);
169 while (<$fh>) {
170 chomp;
171 if (m/^(\d+)\s+(\w+?)\=(.*)$/) {
172 my ($k, $v) = ($2, $3);
173 if ($k eq 'path') {
174 $result->{name} = $v;
175 } elsif ($k eq 'linkpath') {
176 $result->{linkname} = $v;
177 }
178 }
179 }
180}
181
182sub next
183
# spent 642µs (214+429) within OpenBSD::Ustar::next which was called 2 times, avg 321µs/call: # 2 times (214µs+429µs) by OpenBSD::PackageLocation::getNext at line 319 of OpenBSD/PackageLocation.pm, avg 321µs/call
{
18422µs my $self = shift;
185 # get rid of the current object
18626µs29µs $self->skip;
# spent 9µs making 2 calls to OpenBSD::Ustar::skip, avg 5µs/call
18722µs my $header;
188241µs4217µs my $n = read($self->{fh}, $header, 512);
# spent 127µs making 2 calls to OpenBSD::Ustar::CORE:read, avg 63µs/call # spent 90µs making 2 calls to IO::Uncompress::Base::read, avg 45µs/call
18922µs return if (defined $n) and $n == 0;
19022µs $self->fatal("Error while reading header")
191 unless defined $n and $n == 512;
19222µs if ($header eq "\0"x512) {
193 return $self->next;
194 }
195 # decode header
196231µs215µs my ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
# spent 15µs making 2 calls to OpenBSD::Ustar::CORE:unpack, avg 7µs/call
197 $linkname, $magic, $version, $uname, $gname, $major, $minor,
198 $prefix, $pad) = unpack(USTAR_HEADER, $header);
19922µs if ($magic ne "ustar\0" || $version ne '00') {
200 $self->fatal("Not an ustar archive header");
201 }
202 # verify checksum
20324µs my $value = $header;
20422µs substr($value, 148, 8) = " "x8;
205211µs25µs my $ck2 = unpack("%C*", $value);
# spent 5µs making 2 calls to OpenBSD::Ustar::CORE:unpack, avg 3µs/call
20622µs if ($ck2 != oct($chksum)) {
207 $self->fatal("Bad archive checksum");
208 }
209226µs216µs $name =~ s/\0*$//o;
# spent 16µs making 2 calls to OpenBSD::Ustar::CORE:subst, avg 8µs/call
21022µs $mode = oct($mode) & 0xfff;
211211µs26µs $uname =~ s/\0*$//o;
# spent 6µs making 2 calls to OpenBSD::Ustar::CORE:subst, avg 3µs/call
21229µs24µs $gname =~ s/\0*$//o;
# spent 4µs making 2 calls to OpenBSD::Ustar::CORE:subst, avg 2µs/call
21328µs23µs $linkname =~ s/\0*$//o;
# spent 3µs making 2 calls to OpenBSD::Ustar::CORE:subst, avg 1µs/call
21422µs $major = oct($major);
21522µs $minor = oct($minor);
21621µs $uid = oct($uid);
21721µs $gid = oct($gid);
218213µs2120µs $uid = $uidcache->lookup($uname, $uid);
# spent 120µs making 2 calls to OpenBSD::IdCache::lookup, avg 60µs/call
21927µs292µs $gid = $gidcache->lookup($gname, $gid);
# spent 92µs making 2 calls to OpenBSD::IdCache::lookup, avg 46µs/call
220 {
22142.72ms257µs
# spent 36µs (14+21) within OpenBSD::Ustar::BEGIN@221 which was called: # once (14µs+21µs) by OpenBSD::PackageLocation::_opened at line 221
no warnings; # XXX perl warns if oct converts >= 2^32 values
# spent 36µs making 1 call to OpenBSD::Ustar::BEGIN@221 # spent 21µs making 1 call to warnings::unimport
22222µs $mtime = oct($mtime);
223 }
224214µs26µs unless ($prefix =~ m/^\0/o) {
# spent 6µs making 2 calls to OpenBSD::Ustar::CORE:match, avg 3µs/call
225 $prefix =~ s/\0*$//o;
226 $name = "$prefix/$name";
227 }
228
22925µs $self->{lastname} = $name;
23022µs $size = oct($size);
231230µs my $result= {
232 name => $name,
233 mode => $mode,
234 atime => $mtime,
235 mtime => $mtime,
236 linkname=> $linkname,
237 uname => $uname,
238 uid => $uid,
239 gname => $gname,
240 gid => $gid,
241 size => $size,
242 major => $major,
243 minor => $minor,
244 };
245 # adjust swallow
24622µs $self->{swallow} = $size;
24724µs if ($size % 512) {
248 $self->{swallow} += 512 - $size % 512;
249 }
25022µs if ($type eq XHDR) {
251 my $h = $self->read_records($size);
252 $result = $self->next;
253 $self->parse_records($result, $h);
254 return $result;
255 }
256211µs223µs if (defined $types->{$type}) {
# spent 23µs making 2 calls to OpenBSD::Ustar::new_object, avg 12µs/call
257 $self->new_object($result, $types->{$type});
258 } else {
259 $self->fatal("Unsupported type #1 (#2)", $type,
260 $unsupported->{$type} // "unknown");
261 }
262212µs23µs if (!$result->isFile && $result->{size} != 0) {
# spent 3µs making 2 calls to OpenBSD::Ustar::File::isFile, avg 1µs/call
263 $self->fatal("Bad archive: non null size for #1 (#2)",
264 $types->{$type}, $result->{name});
265 }
266
26727µs $self->{cachename} = $name;
26829µs return $result;
269}
270
271sub split_name
272{
273 my $name = shift;
274 my $prefix = '';
275
276 my $l = length $name;
277 if ($l > MAXFILENAME && $l <= MAXFILENAME+MAXPREFIX+1) {
278 while (length($name) > MAXFILENAME &&
279 $name =~ m/^(.*?\/)(.*)$/o) {
280 $prefix .= $1;
281 $name = $2;
282 }
283 $prefix =~ s|/$||;
284 }
285 return ($prefix, $name);
286}
287
288sub extended_record
289{
290 my ($k, $v) = @_;
291 my $string = " $k=$v\n";
292 my $len = length($string);
293 if ($len < 995) {
294 return sprintf("%3d", $len+3).$string;
295 } elsif ($len < 9995) {
296 return sprintf("%04d", $len+4).$string;
297 } else {
298 return sprintf("%05d", $len+5).$string;
299 }
300}
301
302sub pack_header
303{
304 my ($archive, $type, $size, $entry, $prefix, $name, $linkname,
305 $uname, $gname, $major, $minor) = @_;
306
307 my $header;
308 my $cksum = ' 'x8;
309 for (1 .. 2) {
310 $header = pack(USTAR_HEADER,
311 $name,
312 sprintf("%07o", $entry->{mode}),
313 sprintf("%07o", $entry->{uid} // 0),
314 sprintf("%07o", $entry->{gid} // 0),
315 sprintf("%011o", $size),
316 sprintf("%011o", $entry->{mtime} // 0),
317 $cksum,
318 $type,
319 $linkname,
320 'ustar', '00',
321 $uname,
322 $gname,
323 sprintf("%07o", $major),
324 sprintf("%07o", $minor),
325 $prefix, "\0");
326 $cksum = sprintf("%07o", unpack("%C*", $header));
327 }
328 return $header;
329}
330
3311700nsmy $whatever = "usualSuspect000";
332
333sub mkheader
334{
335 my ($archive, $entry, $type) = @_;
336 my ($prefix, $name) = split_name($entry->name);
337 my ($extendedname, $extendedlink);
338 my $linkname = $entry->{linkname};
339 my $size = $entry->{size};
340 my ($major, $minor);
341 if ($entry->isDevice) {
342 $major = $entry->{major};
343 $minor = $entry->{minor};
344 } else {
345 $major = 0;
346 $minor = 0;
347 }
348 my ($uname, $gname);
349 if (defined $entry->{uname}) {
350 $uname = $entry->{uname};
351 } else {
352 $uname = $entry->{uid};
353 }
354 if (defined $entry->{gname}) {
355 $gname = $entry->{gname};
356 } else {
357 $gname = $entry->{gid};
358 }
359
360 if (defined $entry->{cwd}) {
361 my $cwd = $entry->{cwd};
362 $cwd.='/' unless $cwd =~ m/\/$/o;
363 $linkname =~ s/^\Q$cwd\E//;
364 }
365 if (!defined $linkname) {
366 $linkname = '';
367 }
368 if (length $prefix > MAXPREFIX) {
369 $prefix = substr($prefix, 0, MAXPREFIX);
370 $extendedname = 1;
371 }
372 if (length $name > MAXFILENAME) {
373 $name = substr($name, 0, MAXPREFIX);
374 $extendedname = 1;
375 }
376 if (length $linkname > MAXLINKNAME) {
377 $linkname = substr($linkname, 0, MAXLINKNAME);
378 $extendedlink = 1;
379 }
380 if (length $uname > MAXUSERNAME) {
381 $archive->fatal("Username too long #1", $uname);
382 }
383 if (length $gname > MAXGROUPNAME) {
384 $archive->fatal("Groupname too long #1", $gname);
385 }
386 my $header = $archive->pack_header($type, $size, $entry,
387 $prefix, $name, $linkname, $uname, $gname, $major, $minor);
388 my $x;
389 if ($extendedname) {
390 $x .= extended_record("path", $entry->name);
391 }
392 if ($extendedlink) {
393 $x .= extended_record("linkpath",$entry->{linkname});
394 }
395 if ($x) {
396 my $extended = $archive->pack_header(XHDR, length($x), $entry,
397 '', $whatever, '', $uname, $gname, $major, $minor);
398 $whatever++;
399 if ((length $x) % 512) {
400 $x .= "\0" x (512 - ((length $x) % 512));
401 }
402 return $extended.$x.$header;
403 }
404 return $header;
405}
406
407sub prepare
408{
409 my ($self, $filename, $destdir) = @_;
410
411 $destdir //= $self->{destdir};
412 my $realname = "$destdir/$filename";
413
414 my ($dev, $ino, $mode, $uid, $gid, $rdev, $size, $mtime) =
415 (lstat $realname)[0,1,2, 4,5,6,7, 9];
416
417 my $entry = {
418 key => "$dev/$ino",
419 name => $filename,
420 realname => $realname,
421 mode => $mode,
422 uid => $uid,
423 gid => $gid,
424 size => $size,
425 mtime => $mtime,
426 uname => $unamecache->lookup($uid),
427 gname => $gnamecache->lookup($gid),
428 major => $rdev/256,
429 minor => $rdev%256,
430 };
431 my $k = $entry->{key};
432 my $class = "OpenBSD::Ustar::File"; # default
433 if (defined $self->{key}{$k}) {
434 $entry->{linkname} = $self->{key}{$k};
435 $class = "OpenBSD::Ustar::HardLink";
436 } elsif (-l $realname) {
437 $entry->{linkname} = readlink($realname);
438 $class = "OpenBSD::Ustar::SoftLink";
439 } elsif (-p _) {
440 $class = "OpenBSD::Ustar::Fifo";
441 } elsif (-c _) {
442 $class = "OpenBSD::Ustar::CharDevice";
443 } elsif (-b _) {
444 $class ="OpenBSD::Ustar::BlockDevice";
445 } elsif (-d _) {
446 $class = "OpenBSD::Ustar::Dir";
447 }
448 $self->new_object($entry, $class);
449 if (!$entry->isFile) {
450 $entry->{size} = 0;
451 }
452 return $entry;
453}
454
455sub pad
456{
457 my $self = shift;
458 my $fh = $self->{fh};
459 print $fh "\0"x1024 or $self->fatal("Error writing to archive: #1", $!);
460}
461
462sub close
463{
464 my $self = shift;
465 if (defined $self->{padout}) {
466 $self->pad;
467 }
468 close($self->{fh});
469}
470
471sub destdir
472{
473 my $self = shift;
474 if (@_ > 0) {
475 $self->{destdir} = shift;
476 } else {
477 return $self->{destdir};
478 }
479}
480
481sub fh
482{
483 return $_[0]->{fh};
484}
485
486package OpenBSD::Ustar::Object;
487
488sub recheck_owner
489{
490 my $entry = shift;
491 # XXX weird format to prevent cvs from expanding OpenBSD id
492 $entry->{uid} //= $OpenBSD::Ustar::uidcache
493 ->lookup($entry->{uname});
494 $entry->{gid} //= $OpenBSD::Ustar::gidcache
495 ->lookup($entry->{gname});
496}
497
498sub fatal
499{
500 my ($self, @args) = @_;
501 $self->{archive}->fatal(@args);
502}
503
504sub system
505{
506 my ($self, @args) = @_;
507 $self->{archive}{state}->system(@args);
508}
509
510sub errsay
511{
512 my ($self, @args) = @_;
513 $self->{archive}{state}->errsay(@args);
514}
515sub left_todo
516{
517 my ($self, $toread) = @_;
518 return if $toread == 0;
519 return unless defined $self->{archive}{callback};
520 &{$self->{archive}{callback}}($self->{size} - $toread);
521}
522
523sub name
524{
525 my $self = shift;
526 return $self->{name};
527}
528
529sub set_name
530{
531 my ($self, $v) = @_;
532 $self->{name} = $v;
533}
534
535sub set_modes
536{
537 my $self = shift;
538 chown $self->{uid}, $self->{gid}, $self->{destdir}.$self->name;
539 chmod $self->{mode}, $self->{destdir}.$self->name;
540 if (defined $self->{mtime} || defined $self->{atime}) {
541 utime $self->{atime} // time, $self->{mtime} // time,
542 $self->{destdir}.$self->name;
543 }
544}
545
546sub ensure_dir
547{
548 my ($self, $dir) = @_;
549 return if -d $dir;
550 $self->ensure_dir(File::Basename::dirname($dir));
551 if (mkdir($dir)) {
552 return;
553 }
554 $self->fatal("Error making directory #1: #2", $dir, $!);
555}
556
557sub make_basedir
558{
559 my $self = shift;
560 my $dir = $self->{destdir}.File::Basename::dirname($self->name);
561 $self->ensure_dir($dir);
562}
563
564sub write
565{
566 my $self = shift;
567 my $arc = $self->{archive};
568 my $out = $arc->{fh};
569
570 $arc->{padout} = 1;
571 my $header = $arc->mkheader($self, $self->type);
572 print $out $header or $self->fatal("Error writing to archive: #1", $!);
573 $self->write_contents($arc);
574 my $k = $self->{key};
575 if (!defined $arc->{key}{$k}) {
576 $arc->{key}{$k} = $self->name;
577 }
578}
579
580sub alias
581{
582 my ($self, $arc, $alias) = @_;
583
584 my $k = $self->{archive}.":".$self->{archive}{cachename};
585 if (!defined $arc->{key}{$k}) {
586 $arc->{key}{$k} = $alias;
587 }
588}
589
590sub write_contents
591{
592 # only files have anything to write
593}
594
595sub resolve_links
596{
597 # only hard links must cheat
598}
599
600sub copy_contents
601{
602 # only files need copying
603}
604
605sub copy
606{
607 my ($self, $wrarc) = @_;
608 my $out = $wrarc->{fh};
609 $self->resolve_links($wrarc);
610 $wrarc->{padout} = 1;
611 my $header = $wrarc->mkheader($self, $self->type);
612 print $out $header or $self->fatal("Error writing to archive: #1", $!);
613
614 $self->copy_contents($wrarc);
615}
616
617sub isDir() { 0 }
618sub isFile() { 0 }
619sub isDevice() { 0 }
620sub isFifo() { 0 }
621sub isLink() { 0 }
622sub isSymLink() { 0 }
623sub isHardLink() { 0 }
624
625package OpenBSD::Ustar::Dir;
62616µsour @ISA=qw(OpenBSD::Ustar::Object);
627
628sub create
629{
630 my $self = shift;
631 $self->ensure_dir($self->{destdir}.$self->name);
632 $self->set_modes;
633}
634
635sub isDir() { 1 }
636
637sub type() { OpenBSD::Ustar::DIR }
638
639package OpenBSD::Ustar::HardLink;
64013µsour @ISA=qw(OpenBSD::Ustar::Object);
641
642sub create
643{
644 my $self = shift;
645 $self->make_basedir;
646 my $linkname = $self->{linkname};
647 if (defined $self->{cwd}) {
648 $linkname=$self->{cwd}.'/'.$linkname;
649 }
650 link $self->{destdir}.$linkname, $self->{destdir}.$self->name or
651 $self->fatal("Can't link #1#2 to #1#3: #4",
652 $self->{destdir}, $linkname, $self->name, $!);
653}
654
655sub resolve_links
656{
657 my ($self, $arc) = @_;
658
659 my $k = $self->{archive}.":".$self->{linkname};
660 if (defined $arc->{key}{$k}) {
661 $self->{linkname} = $arc->{key}{$k};
662 } else {
663 print join("\n", keys(%{$arc->{key}})), "\n";
664 $self->fatal("Can't copy link over: original for #1 NOT available", $k);
665 }
666}
667
668sub isLink() { 1 }
669sub isHardLink() { 1 }
670
671sub type() { OpenBSD::Ustar::HARDLINK }
672
673package OpenBSD::Ustar::SoftLink;
67413µsour @ISA=qw(OpenBSD::Ustar::Object);
675
676sub create
677{
678 my $self = shift;
679 $self->make_basedir;
680 symlink $self->{linkname}, $self->{destdir}.$self->name or
681 $self->fatal("Can't symlink #1 to #2#3: #4",
682 $self->{linkname}, $self->{destdir}, $self->name, $!);
683 require POSIX;
684 POSIX::lchown($self->{uid}, $self->{gid}, $self->{destdir}.$self->name);
685}
686
687sub isLink() { 1 }
688sub isSymLink() { 1 }
689
690sub type() { OpenBSD::Ustar::SOFTLINK }
691
692package OpenBSD::Ustar::Fifo;
69313µsour @ISA=qw(OpenBSD::Ustar::Object);
694
695sub create
696{
697 my $self = shift;
698 $self->make_basedir;
699 require POSIX;
700 POSIX::mkfifo($self->{destdir}.$self->name, $self->{mode}) or
701 $self->fatal("Can't create fifo #1#2: #3", $self->{destdir},
702 $self->name, $!);
703 $self->set_modes;
704}
705
706sub isFifo() { 1 }
707sub type() { OpenBSD::Ustar::FIFO }
708
709package OpenBSD::UStar::Device;
71012µsour @ISA=qw(OpenBSD::Ustar::Object);
711
712sub create
713{
714 my $self = shift;
715 $self->make_basedir;
716 $self->system(OpenBSD::Paths->mknod,
717 '-m', $self->{mode}, '--', $self->{destdir}.$self->name,
718 $self->devicetype, $self->{major}, $self->{minor});
719 $self->set_modes;
720}
721
722sub isDevice() { 1 }
723
724package OpenBSD::Ustar::BlockDevice;
72514µsour @ISA=qw(OpenBSD::Ustar::Device);
726
727sub type() { OpenBSD::Ustar::BLOCKDEVICE }
728sub devicetype() { 'b' }
729
730package OpenBSD::Ustar::CharDevice;
73113µsour @ISA=qw(OpenBSD::Ustar::Device);
732
733sub type() { OpenBSD::Ustar::BLOCKDEVICE }
734sub devicetype() { 'c' }
735
736package OpenBSD::CompactWriter;
737
738
# spent 166µs (14+153) within OpenBSD::CompactWriter::BEGIN@738 which was called: # once (14µs+153µs) by OpenBSD::PackageLocation::_opened at line 743
use constant {
73911µs FH => 0,
740 BS => 1,
741 ZEROES => 2,
742 UNFINISHED => 3,
74311.03ms2319µs};
# spent 166µs making 1 call to OpenBSD::CompactWriter::BEGIN@738 # spent 153µs making 1 call to constant::import
744
745sub new
746{
747 my ($class, $fname) = @_;
748 open (my $out, '>', $fname) or return;
749 my $bs = (stat $out)[11];
750 my $zeroes;
751 if (defined $bs) {
752 $zeroes = "\x00"x$bs;
753 }
754 bless [ $out, $bs, $zeroes, 0 ], $class;
755}
756
757sub write
758{
759 my ($self, $buffer) = @_;
760 my ($fh, $bs, $zeroes, $e) = @$self;
761START:
762 if (defined $bs) {
763 for (my $i = 0; $i + $bs <= length($buffer); $i+= $bs) {
764 if (substr($buffer, $i, $bs) eq $zeroes) {
765 my $r = syswrite($fh, $buffer, $i);
766 unless (defined $r && $r == $i) {
767 return 0;
768 }
769 $i+=$bs;
770 my $seek_forward = $bs;
771 while (substr($buffer, $i, $bs) eq $zeroes) {
772 $i += $bs;
773 $seek_forward += $bs;
774 }
775 defined(sysseek($fh, $seek_forward, 1))
776 or return 0;
777 $buffer = substr($buffer, $i);
778 if (length $buffer == 0) {
779 $self->[UNFINISHED] = 1;
780 return 1;
781 }
782 goto START;
783 }
784 }
785 }
786 $self->[UNFINISHED] = 0;
787 my $r = syswrite($fh, $buffer);
788 if (defined $r && $r == length $buffer) {
789 return 1;
790 } else {
791 return 0;
792 }
793}
794
795sub close
796{
797 my ($self) = @_;
798 if ($self->[UNFINISHED]) {
799 defined(sysseek($self->[FH], -1, 1)) or return 0;
800 defined(syswrite($self->[FH], "\0")) or return 0;
801 }
802 return 1;
803}
804
805package OpenBSD::Ustar::File;
80612µsour @ISA=qw(OpenBSD::Ustar::Object);
807
808sub create
809{
810 my $self = shift;
811 $self->make_basedir;
812 my $buffer;
813 my $out = OpenBSD::CompactWriter->new($self->{destdir}.$self->name);
814 if (!defined $out) {
815 $self->fatal("Can't write to #1#2: #3", $self->{destdir},
816 $self->name, $!);
817 }
818 my $toread = $self->{size};
819 if ($self->{partial}) {
820 $toread -= length($self->{partial});
821 unless ($out->write($self->{partial})) {
822 $self->fatal("Error writing to #1#2: #3",
823 $self->{destdir}, $self->name, $!);
824 }
825 }
826 while ($toread > 0) {
827 my $maxread = $buffsize;
828 $maxread = $toread if $maxread > $toread;
829 my $actual = read($self->{archive}{fh}, $buffer, $maxread);
830 if (!defined $actual) {
831 $self->fatal("Error reading from archive: #1", $!);
832 }
833 if ($actual == 0) {
834 $self->fatal("Premature end of archive");
835 }
836 $self->{archive}{swallow} -= $actual;
837 unless ($out->write($buffer)) {
838 $self->fatal("Error writing to #1#2: #3",
839 $self->{destdir}, $self->name, $!);
840 }
841
842 $toread -= $actual;
843 $self->left_todo($toread);
844 }
845 $out->close or $self->fatal("Error closing #1#2: #3",
846 $self->{destdir}, $self->name, $!);
847 $self->set_modes;
848}
849
850sub contents
851
# spent 124µs (44+80) within OpenBSD::Ustar::File::contents which was called 2 times, avg 62µs/call: # 2 times (44µs+80µs) by OpenBSD::PackageLocation::find_contents at line 119 of OpenBSD/PackageLocation.pm, avg 62µs/call
{
85222µs my ($self, $lookfor) = @_;
85322µs my $toread = $self->{size};
85422µs my $buffer;
85521µs my $offset = 0;
85622µs if ($self->{partial}) {
857 $buffer = $self->{partial};
858 $offset = length($self->{partial});
859 $toread -= $offset;
860 }
861
86223µs while ($toread != 0) {
86321µs my $sz = $toread;
86422µs if (defined $lookfor) {
865 last if (defined $buffer) and &$lookfor($buffer);
866 $sz = 1024 if $sz > 1024;
867 }
868216µs4150µs my $actual = read($self->{archive}{fh}, $buffer, $sz, $offset);
# spent 80µs making 2 calls to OpenBSD::Ustar::File::CORE:read, avg 40µs/call # spent 70µs making 2 calls to IO::Uncompress::Base::read, avg 35µs/call
86921µs if (!defined $actual) {
870 $self->fatal("Error reading from archive: #1", $!);
871 }
87222µs if ($actual != $sz) {
873 $self->fatal("Error: short read from archive");
874 }
87522µs $self->{archive}{swallow} -= $actual;
87622µs $toread -= $actual;
87723µs $offset += $actual;
878 }
879
88022µs $self->{partial} = $buffer;
881215µs return $buffer;
882}
883
884sub write_contents
885{
886 my ($self, $arc) = @_;
887 my $filename = $self->{realname};
888 my $size = $self->{size};
889 my $out = $arc->{fh};
890 open my $fh, "<", $filename or $self->fatal("Can't read file #1: #2",
891 $filename, $!);
892
893 my $buffer;
894 my $toread = $size;
895 while ($toread > 0) {
896 my $maxread = $buffsize;
897 $maxread = $toread if $maxread > $toread;
898 my $actual = read($fh, $buffer, $maxread);
899 if (!defined $actual) {
900 $self->fatal("Error reading from file: #1", $!);
901 }
902 if ($actual == 0) {
903 $self->fatal("Premature end of file");
904 }
905 unless (print $out $buffer) {
906 $self->fatal("Error writing to archive: #1", $!);
907 }
908
909 $toread -= $actual;
910 $self->left_todo($toread);
911 }
912 if ($size % 512) {
913 print $out "\0" x (512 - $size % 512) or
914 $self->fatal("Error writing to archive: #1", $!);
915 }
916}
917
918sub copy_contents
919{
920 my ($self, $arc) = @_;
921 my $out = $arc->{fh};
922 my $buffer;
923 my $size = $self->{size};
924 my $toread = $size;
925 while ($toread > 0) {
926 my $maxread = $buffsize;
927 $maxread = $toread if $maxread > $toread;
928 my $actual = read($self->{archive}{fh}, $buffer, $maxread);
929 if (!defined $actual) {
930 $self->fatal("Error reading from archive: #1", $!);
931 }
932 if ($actual == 0) {
933 $self->fatal("Premature end of archive");
934 }
935 $self->{archive}{swallow} -= $actual;
936 unless (print $out $buffer) {
937 $self->fatal("Error writing to archive #1", $!);
938 }
939
940 $toread -= $actual;
941 }
942 if ($size % 512) {
943 print $out "\0" x (512 - $size % 512) or
944 $self->fatal("Error writing to archive: #1", $!);
945 }
946 $self->alias($arc, $self->name);
947}
948
949sub isFile() { 1 }
950
951sub type() { OpenBSD::Ustar::FILE1 }
952
953110µs1;
 
# spent 6µs within OpenBSD::Ustar::CORE:match which was called 2 times, avg 3µs/call: # 2 times (6µs+0s) by OpenBSD::Ustar::next at line 224, avg 3µs/call
sub OpenBSD::Ustar::CORE:match; # opcode
# spent 127µs (37+90) within OpenBSD::Ustar::CORE:read which was called 2 times, avg 63µs/call: # 2 times (37µs+90µs) by OpenBSD::Ustar::next at line 188, avg 63µs/call
sub OpenBSD::Ustar::CORE:read; # opcode
# spent 28µs within OpenBSD::Ustar::CORE:subst which was called 8 times, avg 4µs/call: # 2 times (16µs+0s) by OpenBSD::Ustar::next at line 209, avg 8µs/call # 2 times (6µs+0s) by OpenBSD::Ustar::next at line 211, avg 3µs/call # 2 times (4µs+0s) by OpenBSD::Ustar::next at line 212, avg 2µs/call # 2 times (3µs+0s) by OpenBSD::Ustar::next at line 213, avg 1µs/call
sub OpenBSD::Ustar::CORE:subst; # opcode
# spent 20µs within OpenBSD::Ustar::CORE:unpack which was called 4 times, avg 5µs/call: # 2 times (15µs+0s) by OpenBSD::Ustar::next at line 196, avg 7µs/call # 2 times (5µs+0s) by OpenBSD::Ustar::next at line 205, avg 3µs/call
sub OpenBSD::Ustar::CORE:unpack; # opcode
# spent 80µs (10+70) within OpenBSD::Ustar::File::CORE:read which was called 2 times, avg 40µs/call: # 2 times (10µs+70µs) by OpenBSD::Ustar::File::contents at line 868, avg 40µs/call
sub OpenBSD::Ustar::File::CORE:read; # opcode
# spent 4µs within OpenBSD::Ustar::File::isFile which was called 4 times, avg 1µs/call: # 2 times (3µs+0s) by OpenBSD::Ustar::next at line 262, avg 1µs/call # 2 times (2µs+0s) by OpenBSD::PackageLocation::find_contents at line 116 of OpenBSD/PackageLocation.pm, avg 950ns/call
sub OpenBSD::Ustar::File::isFile; # xsub
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.