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