xref: /openbsd/usr.sbin/pkg_add/OpenBSD/Ustar.pm (revision 73471bf0) 
1# ex:ts=8 sw=4:
2# $OpenBSD: Ustar.pm,v 1.89 2021/08/09 16:40:20 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 = new OpenBSD::UidCache;
53our $gidcache = new OpenBSD::GidCache;
54our $unamecache = new OpenBSD::UnameCache;
55our $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 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{
96	my ($self, $h, $class) = @_;
97	$h->{archive} = $self;
98	$h->{destdir} = $self->{destdir};
99	bless $h, $class;
100	return $h;
101}
102
103sub skip
104{
105	my $self = shift;
106	my $temp;
107
108	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
124my $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
135my $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{
184	my $self = shift;
185	# get rid of the current object
186	$self->skip;
187	my $header;
188	my $n = read($self->{fh}, $header, 512);
189	return if (defined $n) and $n == 0;
190	$self->fatal("Error while reading header")
191	    unless defined $n and $n == 512;
192	if ($header eq "\0"x512) {
193		return $self->next;
194	}
195	# decode header
196	my ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
197	    $linkname, $magic, $version, $uname, $gname, $major, $minor,
198	    $prefix, $pad) = unpack(USTAR_HEADER, $header);
199	if ($magic ne "ustar\0" || $version ne '00') {
200		$self->fatal("Not an ustar archive header");
201	}
202	# verify checksum
203	my $value = $header;
204	substr($value, 148, 8) = " "x8;
205	my $ck2 = unpack("%C*", $value);
206	if ($ck2 != oct($chksum)) {
207		$self->fatal("Bad archive checksum");
208	}
209	$name =~ s/\0*$//o;
210	$mode = oct($mode) & 0xfff;
211	$uname =~ s/\0*$//o;
212	$gname =~ s/\0*$//o;
213	$linkname =~ s/\0*$//o;
214	$major = oct($major);
215	$minor = oct($minor);
216	$uid = oct($uid);
217	$gid = oct($gid);
218	$uid = $uidcache->lookup($uname, $uid);
219	$gid = $gidcache->lookup($gname, $gid);
220	{
221		no warnings; # XXX perl warns if oct converts >= 2^32 values
222		$mtime = oct($mtime);
223	}
224	unless ($prefix =~ m/^\0/o) {
225		$prefix =~ s/\0*$//o;
226		$name = "$prefix/$name";
227	}
228
229	$self->{lastname} = $name;
230	$size = oct($size);
231	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
246	$self->{swallow} = $size;
247	if ($size % 512) {
248		$self->{swallow} += 512 - $size % 512;
249	}
250	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	}
256	if (defined $types->{$type}) {
257		$self->new_object($result, $types->{$type});
258	} else {
259		$self->fatal("Unsupported type #1 (#2)", $type,
260		    $unsupported->{$type} // "unknown");
261	}
262	if (!$result->isFile && $result->{size} != 0) {
263		$self->fatal("Bad archive: non null size for #1 (#2)",
264		    $types->{$type}, $result->{name});
265	}
266
267	$self->{cachename} = $name;
268	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
331my $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 fullname
530{
531	my $self = shift;
532	return $self->{destdir}.$self->{name};
533}
534
535sub set_name
536{
537	my ($self, $v) = @_;
538	$self->{name} = $v;
539}
540
541sub set_modes_on_object
542{
543	my ($self, $o) = @_;
544	chown $self->{uid}, $self->{gid}, $o;
545	chmod $self->{mode}, $o;
546	if (defined $self->{mtime} || defined $self->{atime}) {
547		utime $self->{atime} // time, $self->{mtime} // time, $o;
548	}
549}
550
551sub set_modes
552{
553	my $self = shift;
554	$self->set_modes_on_object($self->fullname);
555}
556
557sub ensure_dir
558{
559	my ($self, $dir) = @_;
560	return if -d $dir;
561	$self->ensure_dir(File::Basename::dirname($dir));
562	if (mkdir($dir)) {
563		return;
564	}
565	$self->fatal("Error making directory #1: #2", $dir, $!);
566}
567
568sub make_basedir
569{
570	my $self = shift;
571	my $dir = $self->{destdir}.File::Basename::dirname($self->name);
572	$self->ensure_dir($dir);
573}
574
575sub write
576{
577	my $self = shift;
578	my $arc = $self->{archive};
579	my $out = $arc->{fh};
580
581	$arc->{padout} = 1;
582	my $header = $arc->mkheader($self, $self->type);
583	print $out $header or $self->fatal("Error writing to archive: #1", $!);
584	$self->write_contents($arc);
585	my $k = $self->{key};
586	if (!defined $arc->{key}{$k}) {
587		$arc->{key}{$k} = $self->name;
588	}
589}
590
591sub alias
592{
593	my ($self, $arc, $alias) = @_;
594
595	my $k = $self->{archive}.":".$self->{archive}{cachename};
596	if (!defined $arc->{key}{$k}) {
597		$arc->{key}{$k} = $alias;
598	}
599}
600
601sub write_contents
602{
603	# only files have anything to write
604}
605
606sub resolve_links
607{
608	# only hard links must cheat
609}
610
611sub copy_contents
612{
613	# only files need copying
614}
615
616sub copy
617{
618	my ($self, $wrarc) = @_;
619	my $out = $wrarc->{fh};
620	$self->resolve_links($wrarc);
621	$wrarc->{padout} = 1;
622	my $header = $wrarc->mkheader($self, $self->type);
623	print $out $header or $self->fatal("Error writing to archive: #1", $!);
624
625	$self->copy_contents($wrarc);
626}
627
628sub isDir() { 0 }
629sub isFile() { 0 }
630sub isDevice() { 0 }
631sub isFifo() { 0 }
632sub isLink() { 0 }
633sub isSymLink() { 0 }
634sub isHardLink() { 0 }
635
636package OpenBSD::Ustar::Dir;
637our @ISA=qw(OpenBSD::Ustar::Object);
638
639sub create
640{
641	my $self = shift;
642	$self->ensure_dir($self->fullname);
643	$self->set_modes;
644}
645
646sub isDir() { 1 }
647
648sub type() { OpenBSD::Ustar::DIR }
649
650package OpenBSD::Ustar::HardLink;
651our @ISA=qw(OpenBSD::Ustar::Object);
652
653sub create
654{
655	my $self = shift;
656	$self->make_basedir;
657	my $linkname = $self->{linkname};
658	if (defined $self->{cwd}) {
659		$linkname=$self->{cwd}.'/'.$linkname;
660	}
661	link $self->{destdir}.$linkname, $self->fullname or
662	    $self->fatal("Can't link #1#2 to #1#3: #4",
663	    	$self->{destdir}, $linkname, $self->name, $!);
664}
665
666sub resolve_links
667{
668	my ($self, $arc) = @_;
669
670	my $k = $self->{archive}.":".$self->{linkname};
671	if (defined $arc->{key}{$k}) {
672		$self->{linkname} = $arc->{key}{$k};
673	} else {
674		print join("\n", keys(%{$arc->{key}})), "\n";
675		$self->fatal("Can't copy link over: original for #1 NOT available", $k);
676	}
677}
678
679sub isLink() { 1 }
680sub isHardLink() { 1 }
681
682sub type() { OpenBSD::Ustar::HARDLINK }
683
684package OpenBSD::Ustar::SoftLink;
685our @ISA=qw(OpenBSD::Ustar::Object);
686
687sub create
688{
689	my $self = shift;
690	$self->make_basedir;
691	symlink $self->{linkname}, $self->fullname or
692	    $self->fatal("Can't symlink #1 to #2: #3",
693	    	$self->{linkname}, $self->fullname, $!);
694	require POSIX;
695	POSIX::lchown($self->{uid}, $self->{gid}, $self->fullname);
696}
697
698sub isLink() { 1 }
699sub isSymLink() { 1 }
700
701sub type() { OpenBSD::Ustar::SOFTLINK }
702
703package OpenBSD::Ustar::Fifo;
704our @ISA=qw(OpenBSD::Ustar::Object);
705
706sub create
707{
708	my $self = shift;
709	$self->make_basedir;
710	require POSIX;
711	POSIX::mkfifo($self->fullname, $self->{mode}) or
712	    $self->fatal("Can't create fifo #1: #2", $self->fullname, $!);
713	$self->set_modes;
714}
715
716sub isFifo() { 1 }
717sub type() { OpenBSD::Ustar::FIFO }
718
719package OpenBSD::UStar::Device;
720our @ISA=qw(OpenBSD::Ustar::Object);
721
722sub create
723{
724	my $self = shift;
725	$self->make_basedir;
726	$self->system(OpenBSD::Paths->mknod,
727	    '-m', $self->{mode}, '--', $self->fullname,
728	    $self->devicetype, $self->{major}, $self->{minor});
729	$self->set_modes;
730}
731
732sub isDevice() { 1 }
733
734package OpenBSD::Ustar::BlockDevice;
735our @ISA=qw(OpenBSD::Ustar::Device);
736
737sub type() { OpenBSD::Ustar::BLOCKDEVICE }
738sub devicetype() { 'b' }
739
740package OpenBSD::Ustar::CharDevice;
741our @ISA=qw(OpenBSD::Ustar::Device);
742
743sub type() { OpenBSD::Ustar::BLOCKDEVICE }
744sub devicetype() { 'c' }
745
746package OpenBSD::CompactWriter;
747
748use constant {
749	FH => 0,
750	BS => 1,
751	ZEROES => 2,
752	UNFINISHED => 3,
753};
754
755sub new
756{
757	my ($class, $out) = @_;
758	my $bs = (stat $out)[11];
759	my $zeroes;
760	if (defined $bs) {
761		$zeroes = "\x00"x$bs;
762	}
763	bless [ $out, $bs, $zeroes, 0 ], $class;
764}
765
766sub write
767{
768	my ($self, $buffer) = @_;
769	my ($fh, $bs, $zeroes, $e) = @$self;
770START:
771	if (defined $bs) {
772		for (my $i = 0; $i + $bs <= length($buffer); $i+= $bs) {
773			if (substr($buffer, $i, $bs) eq $zeroes) {
774				my $r = syswrite($fh, $buffer, $i);
775				unless (defined $r && $r == $i) {
776					return 0;
777				}
778				$i+=$bs;
779				my $seek_forward = $bs;
780				while (substr($buffer, $i, $bs) eq $zeroes) {
781					$i += $bs;
782					$seek_forward += $bs;
783				}
784				defined(sysseek($fh, $seek_forward, 1))
785				    or return 0;
786				$buffer = substr($buffer, $i);
787				if (length $buffer == 0) {
788					$self->[UNFINISHED] = 1;
789					return 1;
790				}
791				goto START;
792			}
793		}
794	}
795	$self->[UNFINISHED] = 0;
796	my $r = syswrite($fh, $buffer);
797	if (defined $r && $r == length $buffer) {
798		return 1;
799	} else {
800		return 0;
801	}
802}
803
804sub close
805{
806	my ($self) = @_;
807	if ($self->[UNFINISHED]) {
808		defined(sysseek($self->[FH], -1, 1)) or return 0;
809		defined(syswrite($self->[FH], "\0")) or return 0;
810	}
811	return 1;
812}
813
814package OpenBSD::Ustar::File;
815our @ISA=qw(OpenBSD::Ustar::Object);
816
817sub create
818{
819	my $self = shift;
820	$self->make_basedir;
821	open(my $fh, '>', $self->fullname) or
822	    $self->fatal("Can't write to #1: #2", $self->fullname, $!);
823	$self->extract_to_fh($fh);
824}
825
826sub extract_to_fh
827{
828	my ($self, $fh) = @_;
829	my $buffer;
830	my $out = OpenBSD::CompactWriter->new($fh);
831	my $toread = $self->{size};
832	if ($self->{partial}) {
833		$toread -= length($self->{partial});
834		unless ($out->write($self->{partial})) {
835			$self->fatal("Error writing to #1: #2",
836			    $self->fullname, $!);
837		}
838	}
839	while ($toread > 0) {
840		my $maxread = $buffsize;
841		$maxread = $toread if $maxread > $toread;
842		my $actual = read($self->{archive}{fh}, $buffer, $maxread);
843		if (!defined $actual) {
844			$self->fatal("Error reading from archive: #1", $!);
845		}
846		if ($actual == 0) {
847			$self->fatal("Premature end of archive");
848		}
849		$self->{archive}{swallow} -= $actual;
850		unless ($out->write($buffer)) {
851			$self->fatal("Error writing to #1: #2",
852			    $self->fullname, $!);
853		}
854
855		$toread -= $actual;
856		$self->left_todo($toread);
857	}
858	$self->set_modes_on_object($fh);
859	$out->close or $self->fatal("Error closing #1: #2",
860	    $self->fullname, $!);
861}
862
863sub contents
864{
865	my ($self, $lookfor) = @_;
866	my $toread = $self->{size};
867	my $buffer;
868	my $offset = 0;
869	if ($self->{partial}) {
870		$buffer = $self->{partial};
871		$offset = length($self->{partial});
872		$toread -= $offset;
873	}
874
875	while ($toread != 0) {
876		my $sz = $toread;
877		if (defined $lookfor) {
878			last if (defined $buffer) and &$lookfor($buffer);
879			$sz = 1024 if $sz > 1024;
880		}
881		my $actual = read($self->{archive}{fh}, $buffer, $sz, $offset);
882		if (!defined $actual) {
883			$self->fatal("Error reading from archive: #1", $!);
884		}
885		if ($actual != $sz) {
886			$self->fatal("Error: short read from archive");
887		}
888		$self->{archive}{swallow} -= $actual;
889		$toread -= $actual;
890		$offset += $actual;
891	}
892
893	$self->{partial} = $buffer;
894	return $buffer;
895}
896
897sub write_contents
898{
899	my ($self, $arc) = @_;
900	my $filename = $self->{realname};
901	my $size = $self->{size};
902	my $out = $arc->{fh};
903	open my $fh, "<", $filename or $self->fatal("Can't read file #1: #2",
904	    $filename, $!);
905
906	my $buffer;
907	my $toread = $size;
908	while ($toread > 0) {
909		my $maxread = $buffsize;
910		$maxread = $toread if $maxread > $toread;
911		my $actual = read($fh, $buffer, $maxread);
912		if (!defined $actual) {
913			$self->fatal("Error reading from file: #1", $!);
914		}
915		if ($actual == 0) {
916			$self->fatal("Premature end of file");
917		}
918		unless (print $out $buffer) {
919			$self->fatal("Error writing to archive: #1", $!);
920		}
921
922		$toread -= $actual;
923		$self->left_todo($toread);
924	}
925	if ($size % 512) {
926		print $out "\0" x (512 - $size % 512) or
927		    $self->fatal("Error writing to archive: #1", $!);
928	}
929}
930
931sub copy_contents
932{
933	my ($self, $arc) = @_;
934	my $out = $arc->{fh};
935	my $buffer;
936	my $size = $self->{size};
937	my $toread = $size;
938	while ($toread > 0) {
939		my $maxread = $buffsize;
940		$maxread = $toread if $maxread > $toread;
941		my $actual = read($self->{archive}{fh}, $buffer, $maxread);
942		if (!defined $actual) {
943			$self->fatal("Error reading from archive: #1", $!);
944		}
945		if ($actual == 0) {
946			$self->fatal("Premature end of archive");
947		}
948		$self->{archive}{swallow} -= $actual;
949		unless (print $out $buffer) {
950			$self->fatal("Error writing to archive #1", $!);
951		}
952
953		$toread -= $actual;
954	}
955	if ($size % 512) {
956		print $out "\0" x (512 - $size % 512) or
957		    $self->fatal("Error writing to archive: #1", $!);
958	}
959	$self->alias($arc, $self->name);
960}
961
962sub isFile() { 1 }
963
964sub type() { OpenBSD::Ustar::FILE1 }
965
9661;
967