From unknown Wed Jun 17 09:31:33 1992
SUB: TARO: tar organizer (Re: Tar Perl and Compress)
SUM: utashiro@InterTech.COM (Kazumasa Utashiro)->Perl-Users@fuggles.acc.Virginia.EDU

Archive-name: taro
Submitted-by: utashiro@sra.co.jp

In article <1992Jun16.214035.490@cse.uta.edu>
	turbo@cse.uta.edu (Chris Turbeville) writes:

>I'd like to be able to add files to tar.Z files without needing the disk
>space to hold the uncompressed tar.

This is not exactly what you want but probably very closed.
Using TARO, you can delete specified file from input tar
stream.  What you need is adding a feature to concatinate
two tar streams.  Workaround is dealing with terminator of
tar format which is two continuous null header block.

I made this program to retrieve some files in compressed tar
file in tar archive on tape (what a brain damaged format!).

--utashiro

#!/usr/local/bin/perl
;#
;# taro: tar organizer
;#	Copyright (c) 1991,1992 srekcah@sra.co.jp
;#	October 7 1991
;#
;#	Maintained by utashiro@sra.co.jp
;;	$rcsid = '$Id: taro.perl.mail,v 1.1 2000/03/27 07:34:35 eichin Exp $';
;#
$usage = <<_;
Usage:
	taro list tar-file				# list
	taro pick tar-file pattern [ pattern ... ]	# pick up some files
	taro throw tar-file pattern [ pattern ... ]	# throw away some files
	taro cat tar-file [ name ... ]			# show file contents
	taro edit tar-file perl-script			# edit filename
	taro s/foo/bar/ tar-file			# short-cut for edit
_
;#
;# SEE ALSO
;#	tar(1), tar(5)
;#
push(@INC, 'c:/etc/perl');
require('ctime.pl');

$header_size = 512;
$header_format = "a100 a8 a8 a8 a12 a12 a8 a a100 a*";
$nullblock = "\0" x $header_size;
%mode=(1, '--x', 2, '-r-', 3, '-wx', 4, 'r--', 5, 'r-x', 6, 'rw-', 7, 'rwx');

# initialize header index
$i = 0;
for (split(/ / ,'name mode uid gid size mtime chksum linkflag linkname pad')) {
    &eval(sprintf('$%s_i = %d;', $_, $i++));
}

# option handling
$opts = 'dtv';
while ($_ = $ARGV[0], /^-/ && shift) {
    next unless ($car, $cdr) = /^-?(.)(.*)/;
    if (index($opts, "$car:") >= $[) {
	&eval("\$opt_$car = length(\$cdr) ? \$cdr : \@ARGV ? shift : &usage");
	next;
    }
    if (index($opts, $car) >= $[) {
	&eval("\$opt_$car++"); $_ = $cdr; redo;
    }
    &usage("Unknown option: $car\n\n");
}

$command = shift || &usage;	# 1st argument is command
$tarfile = shift || '-';	# 2nd argument is archive file
command: {
    if ($command eq 'list') {
	last;
    }
    if ($command eq 'pick' || $command eq 'throw') {
	@patterns = @ARGV;
	for (@patterns) {
	    $_ = &wildcard($_);
	}
	($command, $negative) = ('pick', '!') if ($command eq 'throw');
	$sub = "sub pickit { local(\$_) = \@_; $negative(/"
	    . join('/ || /', @patterns) . "/); }\n";
	print STDERR $sub if $opt_d;
	&eval($sub);
	last;
    }
    if ($command eq 'cat' || $command eq 'extract') {
	$catall++ if (@ARGV == 0);
	for (@ARGV) {
	    $cat{$_}++;
	    $cat_cnt++;
	}
	last;
    }
    if ($command eq 'edit') {
	$script = shift;
    }
    if ($command =~ m/^s/) {
	$script = $command;
	$command = 'edit';
    }
    if ($command eq 'edit') {
	$sub_edit = "sub edit { local(\$_)=\@_; $script; \$_; }\n";
	&eval($sub_edit);
	print STDERR $sub_edit if $opt_d;
    }
    else {
	print "Unkown command: $command\n";
	&usage;
    }
}

open(TAR, $tarfile) || die("$tarfile: $!\n");
open(TAR, '-|') || exec('zcat', $tarfile) || die("zcat: $!\n")
    if ($tarfile =~ /\.Z$/);
while (($s = read(TAR, $header, $header_size)) == $header_size) {
    $print_header = $print_body = 1;
    if ($header eq $nullblock) {
	print $header if ($command eq 'pick' || $command eq 'edit');
	last if (++$null_count == 2);
	next;
    }
    $null_count = 0;

    @header = unpack($header_format, $header);
    ($name = $header[$name_i]) =~ s/\0*$//;

    if ($command eq 'list') {
	$print_header = $print_body = 0;
	&show_header(@header);
    }
    elsif ($command eq 'pick') {
	$print_header = $print_body = &pickit($name);
    }
    elsif ($command eq 'cat' || $command eq 'extract') {
	$print_header = $print_body = 0;
	$catit = $catall || $cat{$name};
	$catit = 0 if ($header[$linkflag_i] =~ /[12]/);
    }
    elsif ($command eq 'edit') {
	$header[$name_i] = &edit($header[$name_i]);
	$header[$linkname_i] = &edit($header[$linkname_i])
	    if ($header[$linkflag_i] =~ /1/);
	$header = &make_header(@header);
	$print_header = $print_body = 0 if ($header[$name_i] =~ /^\0/);
    }

    print $header if $print_header;

    if ($catit && $command eq 'extract') {
	if ($name =~ m|/$|) {
	    chop($name);
	    mkdir($name, oct($header[$mode_i])) || warn("$name: $!\n");
	    next;
	} else {
	    open(OUT, ">$name") || warn("$name: $!\n");
	    select(OUT);
	}
    }
    $bufsize = 8192;
    $size = oct($header[$size_i]);
    $size = 0 if ($header[$linkflag_i] =~ /1/);
    while ($size > 0) {
	$bufsize = 512 if ($size < $bufsize);
	if (($s = read(TAR, $buf, $bufsize)) != $bufsize) {
	    print "bufsize = $bufsize, size = $size, s = $s\n" if $opt_d;
	    die "Illegal EOF!\n";
	}
	print substr($buf, 0, $size) if $catit;
	print $buf if $print_body;
	$size -= $bufsize;
    }
    exit if ($catit && !--$cat_cnt);
    if ($catit && $command eq 'extract') {
	select(STDOUT);
	close(OUT);
	chmod oct($header[$mode_i]), $name;
    }
}
close(TAR);

exit(0);

######################################################################

sub usage {
    print $usage;
    exit 1;
}

;#
;# make header block by reculculating checksum
;#
sub make_header {
    local(@header, $header) = @_;
    $header = pack($header_format, @header[0..5], ' ' x 8, @header[7..9]);
    $header[6] = sprintf("% 6o\0 ", unpack("%16C*", $header));
    pack($header_format, @header);
}

;#
;# parse header block
;#
sub parse_header {
    local(@h) = @_;
    $h[$name_i] =~ s/\0+$//;
    $h[$linkname_i] =~ s/\0+$//;
    for (2..6) {
	$h[$_] =~ s/ \0//g;
	$h[$_] = oct($h[$_]);
    }
    @h;
}

;#
;# show "tar tv" like information from header
;#
sub show_header {
    ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $linkflag, $linkname)
	= &parse_header(@_);
    $ctime = &ctime($mtime);
    chop($ctime);

    # Sat Oct  5 10:46:00 PDT 1991
    # 0-->            16---->
    substr($ctime, 16, length($ctime) - 21) = '';
    substr($ctime, 0, 4) = '';
    $ctime =~ s/ (\d:\d\d)/0\1/;	# keep compatibility with tar

    printf("%s%3d/%d%7d %s ", &modeline($mode), $uid, $gid, $size, $ctime)
	unless $opt_t;		# terse

    print $name;

    if ($linkflag eq '1') {	# hard link
	print " linked to ", $linkname;
    }
    if ($linkflag eq '2') {	# symbolic link
	print " symbolic link to ", $linkname;
    }
    print " [chksum=$chksum]" if $opt_v;
    print "\n";
}

;#
;# make modeline like 'rw-r--r--'
;#
sub modeline {
    local($u, $g, $o) = $_[$[] =~ /(\d)(\d)(\d) \0$/;
    $mode{$u} . $mode{$g} . $mode{$o};
}

;#
;# wildcard to regex convert
;#
sub wildcard {
    local($_) = @_;
    s#\\?.#$_ = $&; s/\\?([_0-9A-Za-z])/$1/ || /\\./ || s/[*]/.*/ ||
	s/[|]/\$|^/ || tr/?{,}[]\-/.(|)[]\-/ || s/./\\$&/; $_;#ge;
    length($_) ? "(^|\\/)$_\(\\0|\$|\\/)" : undef;
}

;#
;# eval with error handling
;#
sub eval {
    local($exp) = @_;
    eval $exp;
    if ($@ ne '') {
	local($package, $filename, $line) = caller;
	warn "eval failed on line $line in file $filename\n";
	warn "exp = \"$exp\"\n";
	warn $@;
	exit 1;
    }
}