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