#!/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,v 1.3 1992/04/13 18:30:37 utashiro 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;
    }
}