1# ex:ts=8 sw=4: 2# $OpenBSD: Ustar.pm,v 1.93 2023/05/16 16:45:04 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 left_todo 519{ 520 my ($self, $toread) = @_; 521 return if $toread == 0; 522 return unless defined $self->{archive}{callback}; 523 &{$self->{archive}{callback}}($self->{size} - $toread); 524} 525 526sub name 527{ 528 my $self = shift; 529 return $self->{name}; 530} 531 532sub fullname 533{ 534 my $self = shift; 535 return $self->{destdir}.$self->{name}; 536} 537 538sub set_name 539{ 540 my ($self, $v) = @_; 541 $self->{name} = $v; 542} 543 544sub set_modes_on_object 545{ 546 my ($self, $o) = @_; 547 chown $self->{uid}, $self->{gid}, $o; 548 chmod $self->{mode}, $o; 549 if (defined $self->{mtime} || defined $self->{atime}) { 550 utime $self->{atime} // time, $self->{mtime} // time, $o; 551 } 552} 553 554sub set_modes 555{ 556 my $self = shift; 557 $self->set_modes_on_object($self->fullname); 558} 559 560sub ensure_dir 561{ 562 my ($self, $dir) = @_; 563 return if -d $dir; 564 $self->ensure_dir(File::Basename::dirname($dir)); 565 if (mkdir($dir)) { 566 return; 567 } 568 $self->fatal("Error making directory #1: #2", $dir, $!); 569} 570 571sub make_basedir 572{ 573 my $self = shift; 574 my $dir = $self->{destdir}.File::Basename::dirname($self->name); 575 $self->ensure_dir($dir); 576} 577 578sub write 579{ 580 my $self = shift; 581 my $arc = $self->{archive}; 582 my $out = $arc->{fh}; 583 584 $arc->{padout} = 1; 585 my $header = $arc->mkheader($self, $self->type); 586 print $out $header or $self->fatal("Error writing to archive: #1", $!); 587 $self->write_contents($arc); 588 my $k = $self->{key}; 589 if (!defined $arc->{key}{$k}) { 590 $arc->{key}{$k} = $self->name; 591 } 592} 593 594sub alias 595{ 596 my ($self, $arc, $alias) = @_; 597 598 my $k = $self->{archive}.":".$self->{archive}{cachename}; 599 if (!defined $arc->{key}{$k}) { 600 $arc->{key}{$k} = $alias; 601 } 602} 603 604sub write_contents 605{ 606 # only files have anything to write 607} 608 609sub resolve_links 610{ 611 # only hard links must cheat 612} 613 614sub copy_contents 615{ 616 # only files need copying 617} 618 619sub copy 620{ 621 my ($self, $wrarc) = @_; 622 my $out = $wrarc->{fh}; 623 $self->resolve_links($wrarc); 624 $wrarc->{padout} = 1; 625 my $header = $wrarc->mkheader($self, $self->type); 626 print $out $header or $self->fatal("Error writing to archive: #1", $!); 627 628 $self->copy_contents($wrarc); 629} 630 631sub isDir() { 0 } 632sub isFile() { 0 } 633sub isDevice() { 0 } 634sub isFifo() { 0 } 635sub isLink() { 0 } 636sub isSymLink() { 0 } 637sub isHardLink() { 0 } 638 639package OpenBSD::Ustar::Dir; 640our @ISA=qw(OpenBSD::Ustar::Object); 641 642sub create 643{ 644 my $self = shift; 645 $self->ensure_dir($self->fullname); 646 $self->set_modes; 647} 648 649sub isDir() { 1 } 650 651sub type() { OpenBSD::Ustar::DIR } 652 653package OpenBSD::Ustar::HardLink; 654our @ISA=qw(OpenBSD::Ustar::Object); 655 656sub create 657{ 658 my $self = shift; 659 $self->make_basedir; 660 my $linkname = $self->{linkname}; 661 if (defined $self->{cwd}) { 662 $linkname=$self->{cwd}.'/'.$linkname; 663 } 664 link $self->{destdir}.$linkname, $self->fullname or 665 $self->fatal("Can't link #1#2 to #1#3: #4", 666 $self->{destdir}, $linkname, $self->name, $!); 667} 668 669sub resolve_links 670{ 671 my ($self, $arc) = @_; 672 673 my $k = $self->{archive}.":".$self->{linkname}; 674 if (defined $arc->{key}{$k}) { 675 $self->{linkname} = $arc->{key}{$k}; 676 } else { 677 print join("\n", keys(%{$arc->{key}})), "\n"; 678 $self->fatal("Can't copy link over: original for #1 NOT available", $k); 679 } 680} 681 682sub isLink() { 1 } 683sub isHardLink() { 1 } 684 685sub type() { OpenBSD::Ustar::HARDLINK } 686 687package OpenBSD::Ustar::SoftLink; 688our @ISA=qw(OpenBSD::Ustar::Object); 689 690sub create 691{ 692 my $self = shift; 693 $self->make_basedir; 694 symlink $self->{linkname}, $self->fullname or 695 $self->fatal("Can't symlink #1 to #2: #3", 696 $self->{linkname}, $self->fullname, $!); 697 require POSIX; 698 POSIX::lchown($self->{uid}, $self->{gid}, $self->fullname); 699} 700 701sub isLink() { 1 } 702sub isSymLink() { 1 } 703 704sub type() { OpenBSD::Ustar::SOFTLINK } 705 706package OpenBSD::Ustar::Fifo; 707our @ISA=qw(OpenBSD::Ustar::Object); 708 709sub create 710{ 711 my $self = shift; 712 $self->make_basedir; 713 require POSIX; 714 POSIX::mkfifo($self->fullname, $self->{mode}) or 715 $self->fatal("Can't create fifo #1: #2", $self->fullname, $!); 716 $self->set_modes; 717} 718 719sub isFifo() { 1 } 720sub type() { OpenBSD::Ustar::FIFO } 721 722package OpenBSD::UStar::Device; 723our @ISA=qw(OpenBSD::Ustar::Object); 724 725sub create 726{ 727 my $self = shift; 728 $self->make_basedir; 729 $self->{archive}{state}->system(OpenBSD::Paths->mknod, 730 '-m', $self->{mode}, '--', $self->fullname, 731 $self->devicetype, $self->{major}, $self->{minor}); 732 $self->set_modes; 733} 734 735sub isDevice() { 1 } 736 737package OpenBSD::Ustar::BlockDevice; 738our @ISA=qw(OpenBSD::Ustar::Device); 739 740sub type() { OpenBSD::Ustar::BLOCKDEVICE } 741sub devicetype() { 'b' } 742 743package OpenBSD::Ustar::CharDevice; 744our @ISA=qw(OpenBSD::Ustar::Device); 745 746sub type() { OpenBSD::Ustar::BLOCKDEVICE } 747sub devicetype() { 'c' } 748 749# This is very specific to classic Unix: files with series of 0s should 750# have "gaps" created by using lseek while writing. 751package OpenBSD::CompactWriter; 752 753use constant { 754 FH => 0, 755 BS => 1, 756 ZEROES => 2, 757 UNFINISHED => 3, 758}; 759 760sub new 761{ 762 my ($class, $out) = @_; 763 my $bs = (stat $out)[11]; 764 my $zeroes; 765 if (defined $bs) { 766 $zeroes = "\x00"x$bs; 767 } 768 bless [ $out, $bs, $zeroes, 0 ], $class; 769} 770 771sub write 772{ 773 my ($self, $buffer) = @_; 774 my ($fh, $bs, $zeroes, $e) = @$self; 775START: 776 if (defined $bs) { 777 for (my $i = 0; $i + $bs <= length($buffer); $i+= $bs) { 778 if (substr($buffer, $i, $bs) eq $zeroes) { 779 my $r = syswrite($fh, $buffer, $i); 780 unless (defined $r && $r == $i) { 781 return 0; 782 } 783 $i+=$bs; 784 my $seek_forward = $bs; 785 while (substr($buffer, $i, $bs) eq $zeroes) { 786 $i += $bs; 787 $seek_forward += $bs; 788 } 789 defined(sysseek($fh, $seek_forward, 1)) 790 or return 0; 791 $buffer = substr($buffer, $i); 792 if (length $buffer == 0) { 793 $self->[UNFINISHED] = 1; 794 return 1; 795 } 796 goto START; 797 } 798 } 799 } 800 $self->[UNFINISHED] = 0; 801 my $r = syswrite($fh, $buffer); 802 if (defined $r && $r == length $buffer) { 803 return 1; 804 } else { 805 return 0; 806 } 807} 808 809sub close 810{ 811 my ($self) = @_; 812 if ($self->[UNFINISHED]) { 813 defined(sysseek($self->[FH], -1, 1)) or return 0; 814 defined(syswrite($self->[FH], "\0")) or return 0; 815 } 816 return 1; 817} 818 819package OpenBSD::Ustar::File; 820our @ISA=qw(OpenBSD::Ustar::Object); 821 822sub create 823{ 824 my $self = shift; 825 $self->make_basedir; 826 open(my $fh, '>', $self->fullname) or 827 $self->fatal("Can't write to #1: #2", $self->fullname, $!); 828 $self->extract_to_fh($fh); 829} 830 831sub extract_to_fh 832{ 833 my ($self, $fh) = @_; 834 my $buffer; 835 my $out = OpenBSD::CompactWriter->new($fh); 836 my $toread = $self->{size}; 837 if ($self->{partial}) { 838 $toread -= length($self->{partial}); 839 unless ($out->write($self->{partial})) { 840 $self->fatal("Error writing to #1: #2", 841 $self->fullname, $!); 842 } 843 } 844 while ($toread > 0) { 845 my $maxread = $buffsize; 846 $maxread = $toread if $maxread > $toread; 847 my $actual = read($self->{archive}{fh}, $buffer, $maxread); 848 if (!defined $actual) { 849 $self->fatal("Error reading from archive: #1", $!); 850 } 851 if ($actual == 0) { 852 $self->fatal("Premature end of archive"); 853 } 854 $self->{archive}{swallow} -= $actual; 855 unless ($out->write($buffer)) { 856 $self->fatal("Error writing to #1: #2", 857 $self->fullname, $!); 858 } 859 860 $toread -= $actual; 861 $self->left_todo($toread); 862 } 863 $self->set_modes_on_object($fh); 864 $out->close or $self->fatal("Error closing #1: #2", 865 $self->fullname, $!); 866} 867 868sub contents 869{ 870 my $self = shift; 871 my $toread = $self->{size}; 872 my $buffer; 873 my $offset = 0; 874 if ($self->{partial}) { 875 $buffer = $self->{partial}; 876 $offset = length($self->{partial}); 877 $toread -= $offset; 878 } 879 880 while ($toread != 0) { 881 my $sz = $toread; 882 my $actual = read($self->{archive}{fh}, $buffer, $sz, $offset); 883 if (!defined $actual) { 884 $self->fatal("Error reading from archive: #1", $!); 885 } 886 if ($actual != $sz) { 887 $self->fatal("Error: short read from archive"); 888 } 889 $self->{archive}{swallow} -= $actual; 890 $toread -= $actual; 891 $offset += $actual; 892 } 893 894 $self->{partial} = $buffer; 895 return $buffer; 896} 897 898sub write_contents 899{ 900 my ($self, $arc) = @_; 901 my $filename = $self->{realname}; 902 my $size = $self->{size}; 903 my $out = $arc->{fh}; 904 open my $fh, "<", $filename or $self->fatal("Can't read file #1: #2", 905 $filename, $!); 906 907 my $buffer; 908 my $toread = $size; 909 while ($toread > 0) { 910 my $maxread = $buffsize; 911 $maxread = $toread if $maxread > $toread; 912 my $actual = read($fh, $buffer, $maxread); 913 if (!defined $actual) { 914 $self->fatal("Error reading from file: #1", $!); 915 } 916 if ($actual == 0) { 917 $self->fatal("Premature end of file"); 918 } 919 unless (print $out $buffer) { 920 $self->fatal("Error writing to archive: #1", $!); 921 } 922 923 $toread -= $actual; 924 $self->left_todo($toread); 925 } 926 if ($size % 512) { 927 print $out "\0" x (512 - $size % 512) or 928 $self->fatal("Error writing to archive: #1", $!); 929 } 930} 931 932sub copy_contents 933{ 934 my ($self, $arc) = @_; 935 my $out = $arc->{fh}; 936 my $buffer; 937 my $size = $self->{size}; 938 my $toread = $size; 939 while ($toread > 0) { 940 my $maxread = $buffsize; 941 $maxread = $toread if $maxread > $toread; 942 my $actual = read($self->{archive}{fh}, $buffer, $maxread); 943 if (!defined $actual) { 944 $self->fatal("Error reading from archive: #1", $!); 945 } 946 if ($actual == 0) { 947 $self->fatal("Premature end of archive"); 948 } 949 $self->{archive}{swallow} -= $actual; 950 unless (print $out $buffer) { 951 $self->fatal("Error writing to archive #1", $!); 952 } 953 954 $toread -= $actual; 955 } 956 if ($size % 512) { 957 print $out "\0" x (512 - $size % 512) or 958 $self->fatal("Error writing to archive: #1", $!); 959 } 960 $self->alias($arc, $self->name); 961} 962 963sub isFile() { 1 } 964 965sub type() { OpenBSD::Ustar::FILE1 } 966 9671; 968