xref: /openbsd/usr.sbin/pkg_add/OpenBSD/Ustar.pm (revision 039cbdaa) 
1# ex:ts=8 sw=4:
2# $OpenBSD: Ustar.pm,v 1.96 2023/06/13 09:07:17 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
20use v5.36;
21
22package OpenBSD::Ustar;
23
24use constant {
25	FILE => "\0",
26	FILE1 => '0',
27	HARDLINK => '1',
28	SOFTLINK => '2',
29	CHARDEVICE => '3',
30	BLOCKDEVICE => '4',
31	DIR => '5',
32	FIFO => '6',
33	CONTFILE => '7',
34	USTAR_HEADER => 'a100a8a8a8a12a12a8aa100a6a2a32a32a8a8a155a12',
35	MAXFILENAME => 100,
36	MAXLINKNAME => 100,
37	MAXPREFIX => 155,
38	MAXUSERNAME => 32,
39	MAXGROUPNAME => 32,
40	XHDR => 'x',
41	# XXX those are NOT supported, just recognized
42	GHDR => 'g',
43	LONGLINK => 'K',
44	LONGNAME => 'L',
45};
46
47use File::Basename ();
48use OpenBSD::IdCache;
49use OpenBSD::Paths;
50
51our $uidcache = OpenBSD::UidCache->new;
52our $gidcache = OpenBSD::GidCache->new;
53our $unamecache = OpenBSD::UnameCache->new;
54our $gnamecache = OpenBSD::GnameCache->new;
55
56# This is a multiple of st_blksize everywhere....
57my $buffsize = 2 * 1024 * 1024;
58
59sub new($class, $fh, $state, $destdir = '')
60{
61	return bless {
62	    fh => $fh,
63	    swallow => 0,
64	    state => $state,
65	    key => {},
66	    destdir => $destdir} , $class;
67}
68
69# $self->set_description($description):
70#	application-level description of the archive for error messages
71sub set_description($self, $d)
72{
73	$self->{description} = $d;
74}
75
76# $self->set_callback(sub($size_done) {}):
77#	for large file extraction, provide intermediate callbacks with the
78#	size already done for progress meters and the likes
79sub set_callback($self, $code)
80{
81	$self->{callback} = $code;
82}
83
84sub _fatal($self, $msg, @args)
85{
86	$self->{state}->fatal("Ustar [#1][#2]: #3",
87	    $self->{description} // '?', $self->{lastname} // '?',
88	    $self->{state}->f($msg, @args));
89}
90
91sub _new_object($self, $h, $class)
92{
93	$h->{archive} = $self;
94	$h->{destdir} = $self->{destdir};
95	bless $h, $class;
96	return $h;
97}
98
99sub skip($self)
100{
101	my $temp;
102
103	while ($self->{swallow} > 0) {
104		my $toread = $self->{swallow};
105		if ($toread >$buffsize) {
106			$toread = $buffsize;
107		}
108		my $actual = read($self->{fh}, $temp, $toread);
109		if (!defined $actual) {
110			$self->_fatal("Error while skipping archive: #1", $!);
111		}
112		if ($actual == 0) {
113			$self->_fatal("Premature end of archive in header");
114		}
115		$self->{swallow} -= $actual;
116	}
117}
118
119my $types = {
120	DIR , 'OpenBSD::Ustar::Dir',
121	HARDLINK , 'OpenBSD::Ustar::HardLink',
122	SOFTLINK , 'OpenBSD::Ustar::SoftLink',
123	FILE , 'OpenBSD::Ustar::File',
124	FILE1 , 'OpenBSD::Ustar::File',
125	FIFO , 'OpenBSD::Ustar::Fifo',
126	CHARDEVICE , 'OpenBSD::Ustar::CharDevice',
127	BLOCKDEVICE , 'OpenBSD::Ustar::BlockDevice',
128};
129
130my $unsupported = {
131	XHDR => 'Extended header',
132	GHDR => 'GNU header',
133	LONGLINK => 'Long symlink',
134	LONGNAME => 'Long file',
135};
136
137# helpers for the XHDR type
138sub _read_records($self, $size)
139{
140	my $toread = $self->{swallow};
141	my $result = '';
142	while ($toread > 0) {
143		my $buffer;
144		my $maxread = $buffsize;
145		$maxread = $toread if $maxread > $toread;
146		my $actual = read($self->{fh}, $buffer, $maxread);
147		if (!defined $actual) {
148			$self->_fatal("Error reading from archive: #1", $!);
149		}
150		if ($actual == 0) {
151			$self->_fatal("Premature end of archive");
152		}
153		$self->{swallow} -= $actual;
154		$toread -= $actual;
155		$result .= $buffer;
156	}
157	return substr($result, 0, $size);
158}
159
160sub _parse_records($self, $result, $h)
161{
162	open(my $fh, '<', \$h);
163	while (<$fh>) {
164		chomp;
165		if (m/^(\d+)\s+(\w+?)\=(.*)$/) {
166			my ($k, $v) = ($2, $3);
167			if ($k eq 'path') {
168				$result->{name} = $v;
169			} elsif ($k eq 'linkpath') {
170				$result->{linkname} = $v;
171			}
172		}
173	}
174}
175
176sub next($self)
177{
178	# get rid of the current object
179	$self->skip;
180	my $header;
181	my $n = read($self->{fh}, $header, 512);
182	return if (defined $n) and $n == 0;
183	$self->_fatal("Error while reading header")
184	    unless defined $n and $n == 512;
185	if ($header eq "\0"x512) {
186		return $self->next;
187	}
188	# decode header
189	my ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
190	    $linkname, $magic, $version, $uname, $gname, $major, $minor,
191	    $prefix, $pad) = unpack(USTAR_HEADER, $header);
192	if ($magic ne "ustar\0" || $version ne '00') {
193		$self->_fatal("Not an ustar archive header");
194	}
195	# verify checksum
196	my $value = $header;
197	substr($value, 148, 8) = " "x8;
198	my $ck2 = unpack("%C*", $value);
199	if ($ck2 != oct($chksum)) {
200		$self->_fatal("Bad archive checksum");
201	}
202	$name =~ s/\0*$//o;
203	$mode = oct($mode) & 0xfff;
204	$uname =~ s/\0*$//o;
205	$gname =~ s/\0*$//o;
206	$linkname =~ s/\0*$//o;
207	$major = oct($major);
208	$minor = oct($minor);
209	$uid = oct($uid);
210	$gid = oct($gid);
211	$uid = $uidcache->lookup($uname, $uid);
212	$gid = $gidcache->lookup($gname, $gid);
213	{
214		no warnings; # XXX perl warns if oct converts >= 2^32 values
215		$mtime = oct($mtime);
216	}
217	unless ($prefix =~ m/^\0/o) {
218		$prefix =~ s/\0*$//o;
219		$name = "$prefix/$name";
220	}
221
222	$self->{lastname} = $name;
223	$size = oct($size);
224	my $result= {
225	    name => $name,
226	    mode => $mode,
227	    atime => $mtime,
228	    mtime => $mtime,
229	    linkname=> $linkname,
230	    uname => $uname,
231	    uid => $uid,
232	    gname => $gname,
233	    gid => $gid,
234	    size => $size,
235	    major => $major,
236	    minor => $minor,
237	};
238	# adjust swallow
239	$self->{swallow} = $size;
240	if ($size % 512) {
241		$self->{swallow} += 512 - $size % 512;
242	}
243	if ($type eq XHDR) {
244		my $h = $self->_read_records($size);
245		$result = $self->next;
246		$self->_parse_records($result, $h);
247		return $result;
248	}
249	if (defined $types->{$type}) {
250		$self->_new_object($result, $types->{$type});
251	} else {
252		$self->_fatal("Unsupported type #1 (#2)", $type,
253		    $unsupported->{$type} // "unknown");
254	}
255	if (!$result->isFile && $result->{size} != 0) {
256		$self->_fatal("Bad archive: non null size for #1 (#2)",
257		    $types->{$type}, $result->{name});
258	}
259
260	$self->{cachename} = $name;
261	return $result;
262}
263
264# helper for prepare: ustar has strong limitations wrt directory/filename
265sub _split_name($name)
266{
267	my $prefix = '';
268
269	my $l = length $name;
270	if ($l > MAXFILENAME && $l <= MAXFILENAME+MAXPREFIX+1) {
271		while (length($name) > MAXFILENAME &&
272		    $name =~ m/^(.*?\/)(.*)$/o) {
273			$prefix .= $1;
274			$name = $2;
275		}
276		$prefix =~ s|/$||;
277	}
278	return ($prefix, $name);
279}
280
281# helper for prepare
282sub _extended_record($k, $v)
283{
284	my $string = " $k=$v\n";
285	my $len = length($string);
286	if ($len < 995) {
287		return sprintf("%3d", $len+3).$string;
288	} elsif ($len < 9995) {
289		return sprintf("%04d", $len+4).$string;
290	} else {
291		return sprintf("%05d", $len+5).$string;
292	}
293}
294
295sub _pack_header($archive, $type, $size, $entry, $prefix, $name, $linkname,
296    $uname, $gname, $major, $minor)
297{
298
299	my $header;
300	my $cksum = ' 'x8;
301	for (1 .. 2) {
302		$header = pack(USTAR_HEADER,
303		    $name,
304		    sprintf("%07o", $entry->{mode}),
305		    sprintf("%07o", $entry->{uid} // 0),
306		    sprintf("%07o", $entry->{gid} // 0),
307		    sprintf("%011o", $size),
308		    sprintf("%011o", $entry->{mtime} // 0),
309		    $cksum,
310		    $type,
311		    $linkname,
312		    'ustar', '00',
313		    $uname,
314		    $gname,
315		    sprintf("%07o", $major),
316		    sprintf("%07o", $minor),
317		    $prefix, "\0");
318		$cksum = sprintf("%07o", unpack("%C*", $header));
319	}
320	return $header;
321}
322
323my $whatever = "usualSuspect000";
324
325sub _mkheader($archive, $entry, $type)
326{
327	my ($prefix, $name) = _split_name($entry->name);
328	my ($extendedname, $extendedlink);
329	my $linkname = $entry->{linkname};
330	my $size = $entry->{size};
331	my ($major, $minor);
332	if ($entry->isDevice) {
333		$major = $entry->{major};
334		$minor = $entry->{minor};
335	} else {
336		$major = 0;
337		$minor = 0;
338	}
339	my ($uname, $gname);
340	if (defined $entry->{uname}) {
341		$uname = $entry->{uname};
342	} else {
343		$uname = $entry->{uid};
344	}
345	if (defined $entry->{gname}) {
346		$gname = $entry->{gname};
347	} else {
348		$gname = $entry->{gid};
349	}
350
351	if (defined $entry->{cwd}) {
352		my $cwd = $entry->{cwd};
353		$cwd.='/' unless $cwd =~ m/\/$/o;
354		$linkname =~ s/^\Q$cwd\E//;
355	}
356	if (!defined $linkname) {
357		$linkname = '';
358	}
359	if (length $prefix > MAXPREFIX) {
360		$prefix = substr($prefix, 0, MAXPREFIX);
361		$extendedname = 1;
362	}
363	if (length $name > MAXFILENAME) {
364		$name = substr($name, 0, MAXPREFIX);
365		$extendedname = 1;
366	}
367	if (length $linkname > MAXLINKNAME) {
368		$linkname = substr($linkname, 0, MAXLINKNAME);
369		$extendedlink = 1;
370	}
371	if (length $uname > MAXUSERNAME) {
372		$archive->_fatal("Username too long #1", $uname);
373	}
374	if (length $gname > MAXGROUPNAME) {
375		$archive->_fatal("Groupname too long #1", $gname);
376	}
377	my $header = $archive->_pack_header($type, $size, $entry,
378	    $prefix, $name, $linkname, $uname, $gname, $major, $minor);
379	my $x;
380	if ($extendedname) {
381		$x .= _extended_record("path", $entry->name);
382	}
383	if ($extendedlink) {
384		$x .= _extended_record("linkpath",$entry->{linkname});
385	}
386	if ($x) {
387		my $extended = $archive->_pack_header(XHDR, length($x), $entry,
388		    '', $whatever, '', $uname, $gname, $major, $minor);
389		$whatever++;
390		if ((length $x) % 512) {
391			$x .= "\0" x (512 - ((length $x) % 512));
392		}
393		return $extended.$x.$header;
394	}
395	return $header;
396}
397
398sub prepare($self, $filename, $destdir = $self->{destdir})
399{
400	my $realname = "$destdir/$filename";
401
402	my ($dev, $ino, $mode, $uid, $gid, $rdev, $size, $mtime) =
403	    (lstat $realname)[0,1,2, 4,5,6,7, 9];
404
405	my $entry = {
406		key => "$dev/$ino",
407		name => $filename,
408		realname => $realname,
409		mode => $mode,
410		uid => $uid,
411		gid => $gid,
412		size => $size,
413		mtime => $mtime,
414		uname => $unamecache->lookup($uid),
415		gname => $gnamecache->lookup($gid),
416		major => $rdev/256,
417		minor => $rdev%256,
418	};
419	my $k = $entry->{key};
420	my $class = "OpenBSD::Ustar::File"; # default
421	if (defined $self->{key}{$k}) {
422		$entry->{linkname} = $self->{key}{$k};
423		$class = "OpenBSD::Ustar::HardLink";
424	} elsif (-l $realname) {
425		$entry->{linkname} = readlink($realname);
426		$class = "OpenBSD::Ustar::SoftLink";
427	} elsif (-p _) {
428		$class = "OpenBSD::Ustar::Fifo";
429	} elsif (-c _) {
430		$class = "OpenBSD::Ustar::CharDevice";
431	} elsif (-b _) {
432		$class ="OpenBSD::Ustar::BlockDevice";
433	} elsif (-d _) {
434		$class = "OpenBSD::Ustar::Dir";
435	}
436	$self->_new_object($entry, $class);
437	if (!$entry->isFile) {
438		$entry->{size} = 0;
439	}
440	return $entry;
441}
442
443sub _pad($self)
444{
445	my $fh = $self->{fh};
446	print $fh "\0"x1024 or
447	    $self->_fatal("Error writing to archive: #1", $!);
448}
449
450sub close($self)
451{
452	if (defined $self->{padout}) {
453		$self->_pad;
454	}
455	close($self->{fh});
456}
457
458sub destdir($self)
459{
460	return $self->{destdir};
461}
462
463sub set_destdir($self, $d)
464{
465	$self->{destdir} = $d;
466}
467
468sub fh($self)
469{
470	return $self->{fh};
471}
472
473package OpenBSD::Ustar::Object;
474
475sub recheck_owner($entry)
476{
477	# XXX weird format to prevent cvs from expanding OpenBSD id
478	$entry->{uid} //= $OpenBSD::Ustar::uidcache
479	    ->lookup($entry->{uname});
480	$entry->{gid} //= $OpenBSD::Ustar::gidcache
481	    ->lookup($entry->{gname});
482}
483
484sub _fatal($self, @args)
485{
486	$self->{archive}->_fatal(@args);
487}
488
489sub _left_todo($self, $toread)
490{
491	return if $toread == 0;
492	return unless defined $self->{archive}{callback};
493	&{$self->{archive}{callback}}($self->{size} - $toread);
494}
495
496sub name($self)
497{
498	return $self->{name};
499}
500
501sub fullname($self)
502{
503	return $self->{destdir}.$self->{name};
504}
505
506sub set_name($self, $v)
507{
508	$self->{name} = $v;
509}
510
511sub _set_modes_on_object($self, $o)
512{
513	chown $self->{uid}, $self->{gid}, $o;
514	chmod $self->{mode}, $o;
515	if (defined $self->{mtime} || defined $self->{atime}) {
516		utime $self->{atime} // time, $self->{mtime} // time, $o;
517	}
518}
519
520sub _set_modes($self)
521{
522	$self->_set_modes_on_object($self->fullname);
523}
524
525sub _ensure_dir($self, $dir)
526{
527	return if -d $dir;
528	$self->_ensure_dir(File::Basename::dirname($dir));
529	if (mkdir($dir)) {
530		return;
531	}
532	$self->_fatal("Error making directory #1: #2", $dir, $!);
533}
534
535sub _make_basedir($self)
536{
537	my $dir = $self->{destdir}.File::Basename::dirname($self->name);
538	$self->_ensure_dir($dir);
539}
540
541sub write($self)
542{
543	my $arc = $self->{archive};
544	my $out = $arc->{fh};
545
546	$arc->{padout} = 1;
547	my $header = $arc->_mkheader($self, $self->type);
548	print $out $header or
549	    $self->_fatal("Error writing to archive: #1", $!);
550	$self->write_contents($arc);
551	my $k = $self->{key};
552	if (!defined $arc->{key}{$k}) {
553		$arc->{key}{$k} = $self->name;
554	}
555}
556
557sub alias($self, $arc, $alias)
558{
559	my $k = $self->{archive}.":".$self->{archive}{cachename};
560	if (!defined $arc->{key}{$k}) {
561		$arc->{key}{$k} = $alias;
562	}
563}
564
565# $self->write_contents($arc)
566sub write_contents($, $)
567{
568	# only files have anything to write
569}
570
571# $self->resolve_links($arc)
572sub _resolve_links($, $)
573{
574	# only hard links must cheat
575}
576
577# $self->copy_contents($arc)
578sub copy_contents($, $)
579{
580	# only files need copying
581}
582
583sub copy($self, $wrarc)
584{
585	my $out = $wrarc->{fh};
586	$self->_resolve_links($wrarc);
587	$wrarc->{padout} = 1;
588	my $header = $wrarc->_mkheader($self, $self->type);
589	print $out $header or
590	    $self->_fatal("Error writing to archive: #1", $!);
591
592	$self->copy_contents($wrarc);
593}
594
595sub isDir($) { 0 }
596sub isFile($) { 0 }
597sub isDevice($) { 0 }
598sub isFifo($) { 0 }
599sub isLink($) { 0 }
600sub isSymLink($) { 0 }
601sub isHardLink($) { 0 }
602
603package OpenBSD::Ustar::Dir;
604our @ISA=qw(OpenBSD::Ustar::Object);
605
606sub create($self)
607{
608	$self->_ensure_dir($self->fullname);
609	$self->_set_modes;
610}
611
612sub isDir($) { 1 }
613
614sub type($) { OpenBSD::Ustar::DIR }
615
616package OpenBSD::Ustar::HardLink;
617our @ISA=qw(OpenBSD::Ustar::Object);
618
619sub create($self)
620{
621	$self->_make_basedir;
622	my $linkname = $self->{linkname};
623	if (defined $self->{cwd}) {
624		$linkname=$self->{cwd}.'/'.$linkname;
625	}
626	link $self->{destdir}.$linkname, $self->fullname or
627	    $self->_fatal("Can't link #1#2 to #1#3: #4",
628	    	$self->{destdir}, $linkname, $self->name, $!);
629}
630
631sub _resolve_links($self, $arc)
632{
633	my $k = $self->{archive}.":".$self->{linkname};
634	if (defined $arc->{key}{$k}) {
635		$self->{linkname} = $arc->{key}{$k};
636	} else {
637		print join("\n", keys(%{$arc->{key}})), "\n";
638		$self->_fatal("Can't copy link over: original for #1 NOT available", $k);
639	}
640}
641
642sub isLink($) { 1 }
643sub isHardLink($) { 1 }
644
645sub type($) { OpenBSD::Ustar::HARDLINK }
646
647package OpenBSD::Ustar::SoftLink;
648our @ISA=qw(OpenBSD::Ustar::Object);
649
650sub create($self)
651{
652	$self->_make_basedir;
653	symlink $self->{linkname}, $self->fullname or
654	    $self->_fatal("Can't symlink #1 to #2: #3",
655	    	$self->{linkname}, $self->fullname, $!);
656	require POSIX;
657	POSIX::lchown($self->{uid}, $self->{gid}, $self->fullname);
658}
659
660sub isLink($) { 1 }
661sub isSymLink($) { 1 }
662
663sub type($) { OpenBSD::Ustar::SOFTLINK }
664
665package OpenBSD::Ustar::Fifo;
666our @ISA=qw(OpenBSD::Ustar::Object);
667
668sub create($self)
669{
670	$self->_make_basedir;
671	require POSIX;
672	POSIX::mkfifo($self->fullname, $self->{mode}) or
673	    $self->_fatal("Can't create fifo #1: #2", $self->fullname, $!);
674	$self->_set_modes;
675}
676
677sub isFifo($) { 1 }
678sub type($) { OpenBSD::Ustar::FIFO }
679
680package OpenBSD::UStar::Device;
681our @ISA=qw(OpenBSD::Ustar::Object);
682
683sub create($self)
684{
685	$self->_make_basedir;
686	$self->{archive}{state}->system(OpenBSD::Paths->mknod,
687	    '-m', $self->{mode}, '--', $self->fullname,
688	    $self->devicetype, $self->{major}, $self->{minor});
689	$self->_set_modes;
690}
691
692sub isDevice($) { 1 }
693
694package OpenBSD::Ustar::BlockDevice;
695our @ISA=qw(OpenBSD::Ustar::Device);
696
697sub type($) { OpenBSD::Ustar::BLOCKDEVICE }
698sub devicetype($) { 'b' }
699
700package OpenBSD::Ustar::CharDevice;
701our @ISA=qw(OpenBSD::Ustar::Device);
702
703sub type($) { OpenBSD::Ustar::BLOCKDEVICE }
704sub devicetype($) { 'c' }
705
706
707# This is very specific to classic Unix: files with series of 0s should
708# have "gaps" created by using lseek while writing.
709package OpenBSD::CompactWriter;
710
711use constant {
712	FH => 0,
713	BS => 1,
714	ZEROES => 2,
715	UNFINISHED => 3,
716};
717
718sub new($class, $out)
719{
720	my $bs = (stat $out)[11];
721	my $zeroes;
722	if (defined $bs) {
723		$zeroes = "\x00"x$bs;
724	}
725	bless [ $out, $bs, $zeroes, 0 ], $class;
726}
727
728sub write($self, $buffer)
729{
730	my ($fh, $bs, $zeroes, $e) = @$self;
731START:
732	if (defined $bs) {
733		for (my $i = 0; $i + $bs <= length($buffer); $i+= $bs) {
734			if (substr($buffer, $i, $bs) eq $zeroes) {
735				my $r = syswrite($fh, $buffer, $i);
736				unless (defined $r && $r == $i) {
737					return 0;
738				}
739				$i+=$bs;
740				my $seek_forward = $bs;
741				while (substr($buffer, $i, $bs) eq $zeroes) {
742					$i += $bs;
743					$seek_forward += $bs;
744				}
745				defined(sysseek($fh, $seek_forward, 1))
746				    or return 0;
747				$buffer = substr($buffer, $i);
748				if (length $buffer == 0) {
749					$self->[UNFINISHED] = 1;
750					return 1;
751				}
752				goto START;
753			}
754		}
755	}
756	$self->[UNFINISHED] = 0;
757	my $r = syswrite($fh, $buffer);
758	if (defined $r && $r == length $buffer) {
759		return 1;
760	} else {
761		return 0;
762	}
763}
764
765sub close($self)
766{
767	if ($self->[UNFINISHED]) {
768		defined(sysseek($self->[FH], -1, 1)) or return 0;
769		defined(syswrite($self->[FH], "\0")) or return 0;
770	}
771	return 1;
772}
773
774package OpenBSD::Ustar::File;
775our @ISA=qw(OpenBSD::Ustar::Object);
776
777sub create($self)
778{
779	$self->_make_basedir;
780	open(my $fh, '>', $self->fullname) or
781	    $self->_fatal("Can't write to #1: #2", $self->fullname, $!);
782	$self->extract_to_fh($fh);
783}
784
785sub extract_to_fh($self, $fh)
786{
787	my $buffer;
788	my $out = OpenBSD::CompactWriter->new($fh);
789	my $toread = $self->{size};
790	if ($self->{partial}) {
791		$toread -= length($self->{partial});
792		unless ($out->write($self->{partial})) {
793			$self->_fatal("Error writing to #1: #2",
794			    $self->fullname, $!);
795		}
796	}
797	while ($toread > 0) {
798		my $maxread = $buffsize;
799		$maxread = $toread if $maxread > $toread;
800		my $actual = read($self->{archive}{fh}, $buffer, $maxread);
801		if (!defined $actual) {
802			$self->_fatal("Error reading from archive: #1", $!);
803		}
804		if ($actual == 0) {
805			$self->_fatal("Premature end of archive");
806		}
807		$self->{archive}{swallow} -= $actual;
808		unless ($out->write($buffer)) {
809			$self->_fatal("Error writing to #1: #2",
810			    $self->fullname, $!);
811		}
812
813		$toread -= $actual;
814		$self->_left_todo($toread);
815	}
816	$self->_set_modes_on_object($fh);
817	$out->close or $self->_fatal("Error closing #1: #2",
818	    $self->fullname, $!);
819}
820
821sub contents($self)
822{
823	my $toread = $self->{size};
824	my $buffer;
825	my $offset = 0;
826	if ($self->{partial}) {
827		$buffer = $self->{partial};
828		$offset = length($self->{partial});
829		$toread -= $offset;
830	}
831
832	while ($toread != 0) {
833		my $sz = $toread;
834		my $actual = read($self->{archive}{fh}, $buffer, $sz, $offset);
835		if (!defined $actual) {
836			$self->_fatal("Error reading from archive: #1", $!);
837		}
838		if ($actual != $sz) {
839			$self->_fatal("Error: short read from archive");
840		}
841		$self->{archive}{swallow} -= $actual;
842		$toread -= $actual;
843		$offset += $actual;
844	}
845
846	$self->{partial} = $buffer;
847	return $buffer;
848}
849
850sub write_contents($self, $arc)
851{
852	my $filename = $self->{realname};
853	my $size = $self->{size};
854	my $out = $arc->{fh};
855	open my $fh, "<", $filename or
856	    $self->_fatal("Can't read file #1: #2", $filename, $!);
857
858	my $buffer;
859	my $toread = $size;
860	while ($toread > 0) {
861		my $maxread = $buffsize;
862		$maxread = $toread if $maxread > $toread;
863		my $actual = read($fh, $buffer, $maxread);
864		if (!defined $actual) {
865			$self->_fatal("Error reading from file: #1", $!);
866		}
867		if ($actual == 0) {
868			$self->_fatal("Premature end of file");
869		}
870		unless (print $out $buffer) {
871			$self->_fatal("Error writing to archive: #1", $!);
872		}
873
874		$toread -= $actual;
875		$self->_left_todo($toread);
876	}
877	# explicitly pad archive to 512 bytes blocksize
878	if ($size % 512) {
879		print $out "\0" x (512 - $size % 512) or
880		    $self->_fatal("Error writing to archive: #1", $!);
881	}
882}
883
884sub copy_contents($self, $arc)
885{
886	my $out = $arc->{fh};
887	my $buffer;
888	my $size = $self->{size};
889	my $toread = $size;
890	while ($toread > 0) {
891		my $maxread = $buffsize;
892		$maxread = $toread if $maxread > $toread;
893		my $actual = read($self->{archive}{fh}, $buffer, $maxread);
894		if (!defined $actual) {
895			$self->_fatal("Error reading from archive: #1", $!);
896		}
897		if ($actual == 0) {
898			$self->_fatal("Premature end of archive");
899		}
900		$self->{archive}{swallow} -= $actual;
901		print $out $buffer or
902			$self->_fatal("Error writing to archive #1", $!);
903
904		$toread -= $actual;
905	}
906	# explicitly pad archive to 512 bytes blocksize
907	if ($size % 512) {
908		print $out "\0" x (512 - $size % 512) or
909		    $self->_fatal("Error writing to archive: #1", $!);
910	}
911	$self->alias($arc, $self->name);
912}
913
914sub isFile($) { 1 }
915
916sub type($) { OpenBSD::Ustar::FILE1 }
917
9181;
919