#!/usr/local/bin/perl
;#
;# tarfs: tar file browser
;#
;# Copyright (c) 1997 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;#
;# Copyright (c) 1992,1993 Kazumasa Utashiro
;# Software Research Associates, Inc.
;# Original: October 1992
;#
;# Redistribution for non-commercial purpose, with or without
;# modification, is granted as long as all copyright notices are
;# retained.  THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES ARE DISCLAIMED.
;#
;; $rcsid = q$Id: tarfs,v 1.9 1997/03/13 12:43:17 utashiro Exp $;
;#
;; ($myname = $0) =~ s,.*/,,;
;;								$_=<<";#.";
Usage: $myname [-vh] [tarfile]
Options:
	-h	show this message
	-v	print file information during read
;#.
;; ($usage = $_) =~ s/(^|\n);# ?/\1/g;
;######################################################################
;#
;# &usage2opts: Generate getopts string from usage
;#
sub usage2opts {
    local($_, $opts) = shift;
    while (/(^|\n)\t-(\w)(\t|\s\s)?/g) {
	$opts .= $2 . ($3 ? '' : ':');
    }
    $opts;
}
require 'getopts.pl';
sub usage { print $usage, "\n$rcsid\n"; exit 1; }
&Getopts(&usage2opts($usage)) || &usage;
&usage if $opt_h;
;######################################################################

require('shellwords.pl');
require('ctime.pl');

$version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';

;#
;# Perl library tree.pl is embedded at the end of this script while it
;# can be used individually.
;#
if (defined(&tree'init)) {
    &tree'init();
} else {
    require('tree.pl');
}

&tree'newattr('OFFSET');		# Add new attribute 

$header_size = 512;
$header_format = "a100 a8 a8 a8 a12 a12 a8 a a100 a*";
$nullblock = "\0" x $header_size;

@mode{undef, 0..7} = ('---','---','--x','-w-','-wx','r--','r-x','rw-','rwx');

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

$tarfile = shift || '-';

open(TAR, $tarfile) || die("$tarfile: $!\n");
if ($tarfile =~ /\.Z$/) {
    open(TAR, '-|') || exec('zcat', $tarfile) || die("zcat: $!\n");
}
elsif ($tarfile =~ /\.(z|gz|tz)$/) {
    open(TAR, '-|') || exec('gunzip', '-c', $tarfile) || die("gunzip: $!\n");
}

$root = &tree'rooti;			# get root inode
&tree'setattr($root, 'MODE', '777', 'UID', 0, 'GID', 0, 'MTIME', time);

;#
;# read data
;#
print "Scanning data file \"$tarfile\".\n";
while (($s = read(TAR, $header, $header_size)) == $header_size) {
    if ($header eq $nullblock) {
	last if (++$null_count == 2);
	next;
    }
    $null_count = 0;

    @header = unpack($header_format, $header);
    ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $linkflag, $linkname)
	= &parse_header(@header);
    die "Illegal header\n" unless $name;
    $size = 0 if $linkflag_i =~ /1/;

    if ($name =~ s@/$@@ || $mode =~ /4\d{4}/) {
	$i = &tree'mkdir($root, $name);	# directory
	print "$name/\n" if $opt_v;
    } else {
	$i = &tree'creat($root, $name);	# file
	print "$name ($size bytes)\n" if $opt_v;
    }

    &tree'setattr($i, 'SIZE', $size, 'MODE', $mode, 'UID', $uid,
		  'GID', $gid, 'MTIME', $mtime);

    &tree'setattr($i, 'OFFSET', $offset = tell(TAR));
    next if $size == 0;
    if ($offset >= 0) {
	seek(TAR, ($size + 511) & ~511, 1) || warn "seek: $!\n";
    } else {
	read(TAR, $buf, $size);
	&tree'setattr($i, 'DATA', $buf);
	read(TAR, $buf, -$size % 512);
    }
}
print "done\n";

$| = 1;
$cwd = $root;
-t STDIN || (close(STDIN), open(STDIN, '/dev/tty')) || die "/dev/tty: $!\n";

%alias = (
    '?',	'help',
    'cd',	'chdir',
    'dirs',	'pwd',
    'quit',	'exit',
    'ls',	'ls -F',
    'date',	'!date',
    'clear',	'!clear',
    'cat',	'pipeto cat',
    'more',	'pipeto more',
    'less',	'pipeto less',
);
&setvar('prompt', '%F:%D > ');
&setvar('cwd', '/');
&setvar('tarfile', $tarfile eq '-' ? 'stdin' : $tarfile);
&setvar('version', $version);

if ($home = $ENV{'HOME'} || $ENV{'LOGDIR'} || (getpwuid($<))[7]) {
    &setvar('home', $home);
    if (open(RC, "$home/.tarfsrc")) {
	while (<RC>) {
	    next if /^\s*#/;
	    eval { &process($_); };
	}
	close(RC);
    }
}

sub process {

    if (defined($varlist{'verbose'})) {
	print;
    }

    chop if /\n$/;
    s/^\s+//;
    next if $_ eq '';

    #
    # process alias
    #
    undef %aliased;
    while (1) {
	($cmd, @arg) = &shellwords($_);
	last if !defined($alias{$cmd}) || $aliased{$cmd}++;
	$_ = "$alias{$cmd} @arg";
    }

    #
    # !command -> system command
    #
    if ($cmd =~ s/^!//) {
	unshift(@arg, $cmd);
	$cmd = 'system';
    }

    if (defined($varlist{'echo'})) {
	print join(' ', $cmd, @arg), "\n";
    }

    #
    # expand wildcard
    #
    unless ($N{$cmd}) {
	@oldarg = @arg;
	@arg = ();
	for (@oldarg) {
	    if (/[\*\?\[\]\{\,\}]/) {
		$pattern = &wildcard($_);
		for (grep(s/\0.*//, sort &tree'readdir($cwd))) {
		    push(@arg, $_) if /$pattern/ && !/^\.{1,2}$/;
		}
	    } else {
		push(@arg, $_);
	    }
	}
    }

    #
    # call x_subroutine
    #
    $x_cmd = "x_$cmd";
    do $x_cmd(@arg);
}

;#
$H {'exit'} = 'exit tarfs';
;#
sub x_exit {
    exit;
}

;#
$H {'set'} = 'set variable';
$N {'set'} = 1;
$H {'unset'} = 'unset variable';
$N {'unset'} = 1;
;#
sub x_set {
    if (@_ == 0) {
	for (sort keys %varlist) {
	    print $_, "\t", $varlist{$_}, "\n";
	}
    } else {
	&setvar(@_);
    }
    next;
}
sub x_unset {
    foreach (@_) {
	delete $varlist{$_};
    }
    next;
}

;#
$H {'pwd'} = 'print working directory';
;#
sub x_pwd {
    print &tree'getpath($cwd), "\n";
    return 1;
}

;#
$H {'alias'} = 'set alias';
$H {'unalias'} = 'unset alias';
;#
sub x_alias {
    if (@_ == 0) {
	for (sort keys %alias) {
	    print "$_\t$alias{$_}\n";
	}
    } elsif (@_ == 1) {
	print "$_[0]\t$alias{$_[0]}\n" if $alias{$_[0]};
    } else {
	$alias{$_[0]} = "@_[1..$#_]";
    }
    return 1;
}
sub x_unalias {
    foreach (@_) {
	delete $alias{$_};
    }
    return 1;
}

;#
$H {'ls'} = 'show file list [-lsF]';
;#
sub x_ls {
    local($flag);
    while ($_[0] =~ /^-(.*)/) {
	$flag .= $1;
	shift;
    }
    &ls($cwd, $flag, @_);
    return 1;
}

;#
$H {'chdir'} = 'change directory';
;#
sub x_chdir {
    $next = &tree'namei($cwd, $_[0] || '/');
    if (&tree'type($next) eq 'd') {
	$cwd = $next;
	&setvar('cwd', &tree'getpath($cwd));
    } else {
	print "$_[0]: No such directory\n";
    }
    return 1;
}

;#
$H {'pipeto'} = 'pipe files into command';
;#
sub x_pipeto {
    local($cmd) = shift;
    for (@_) {
	&copy_file($cwd, $_, "|$cmd");
    }
    return 1;
}

;#
$H {'cp'} = 'copy files on real filesystem';
;#
sub x_cp {
    $to = pop(@_);
    if (@_ > 1 && !-d $to) {
	warn("$to is not a directory\n");
	return 1;
    }
    for $from (@_) {
	$from =~ m#[^/]*$#;
	$target = -d $to ? "$to/$&" : $to;
	warn("$target exists.\n"), next if -e $target;
	print "$from -> $target\n";
	$target = ">$target" unless $target =~ /^\|/;
	&copy_file($cwd, $from, $target);
    }
    return 1;
}

;#
$H {'system'} = 'execute command';
;#
sub x_system {
    system(@_);
}

;#
$H {'help'} = 'show help';
;#
sub x_help {
    local(@list) = @_ ? @_ : sort keys %H;
    for (@list) {
	if ($H{$_}) {
	    print $_, "\t", $H{$_}, "\n";
	} else {
	    print "$_: no help available\n";
	}
    }
}

;#
;# command loop
;#

$SIG{'INT'} = INT;
sub INT { die "\nInterrupted\n"; }

while (&prompt(), $_ = <>) {
    eval { &process($_) };
    if ($@ && $@ !~ /Interrupted/) {
	print "$cmd: Command not found\n";
    };
}

######################################################################
;#
;# parse header block
;#
sub parse_header {
    local(@h) = @_;
    $h[$name_i] =~ s/\0+$// || return undef;
    $h[$linkname_i] =~ s/\0+$//;
    for (2..6) {
	$h[$_] =~ s/ \0//g;
	$h[$_] = oct($h[$_]);
    }
    @h;
}
;#
;# implement ls
;#
sub ls {
    local($i, $flag, @list) = @_;
    local($name, @dirs);
    local($decend) = @list && $flag !~ /d/;

    @dirs = &_ls;		# use same arguments
    while ($decend && @dirs >= 2) {
	($name, $i) = splice(@dirs, 0, 2);
	print "\n$name:\n";
	&_ls($i, $flag);
    }
}
sub _ls {
    local($i, $flag, @list) = @_;
    local($_, @files) = ($flag);
    local($_a, $_R, $_l, $_F, $_i, $_s)
	= (/a/+0, /R/+0, /l/+0, /F/+0, /i/+0, /s/+0);
    local($name, $inum, @dirs);

    if (@list == 0) {
	@list = sort &tree'readdir($i);
	@list = grep(!/^\./, @list) unless $_a;
    }
    for (@list) {
	if (/\0/) {
	    ($name, $inum) = split("\0", $_);
	} else {
	    unless ($inum = &tree'namei($i, $_)) {
		warn "$_: No such file or direcotry\n";
		next;
	    }
	    $name = $_;
	}
	($type, $mode, $size, $mtime, $uid, $gid) =
	    &tree'getattr($inum,
			  'TYPE', 'MODE', 'SIZE', 'MTIME', 'UID', 'GID');
	push(@dirs, $name, $inum) if $type eq 'd';
	$name .= &filemark($inum) if $_F;
	$name = sprintf("%4d $name", $inum) if $_i;
	$name = sprintf("%4d $name", int(($size+511)/512)) if $_s;
	if ($_l) {
	    print $type eq 'd' ? 'd' : '-', &modeline($mode);
	    printf " %6s/%-6s %6d ", $uid, $gid, $size;
	    ($ctime = &ctime($mtime)) =~ s/^....(.{12}).*(\d{4})\n/\1 \2/;
	    print "$ctime $name\n";
	} else {
	    push(@files, $name);
	}
    }
    &column_out(@files) unless $_l;
    @dirs;
}
;#
;# implement ls -C
;#
sub column_out {
    local(@item) = @_;
    local($[) = 0;
    local($W, $w, $c, $l, $p, $_) = (80, 8);

    return unless @item;
    for (@item) { $w = (length() + 1 + 7) & ~7 if length() > $w - 1; } # width
    $c = $w >= $W ? 1 : int($W / $w);	# column
    $l = int((@item + $c - 1) / $c);	# line

    for (sort {$a % $l <=> $b % $l || $a <=> $b} $[ .. $#item) {
	print $_ < $p + $l ? "\n" : ' ' x ($w - length($item[$p])) if $_;
	print $item[$_];
	$p = $_;
    }
    print "\n";
}
;#
;# return mark for ls -F
;#
sub filemark {
    local($type, $mode) = &tree'getattr(shift, 'TYPE', 'MODE');
    $mode =~ s/^.*(...)$/$1/;
    $type eq 'd' ? '/' : $mode =~ /[1357]/ ? '*' : '';
}
;#
;# make modeline like 'rw-r--r--'
;#
sub modeline {
    local($o, $g, $u, $sxid) = reverse($_[$[] =~ /\d/g);
    local($_) = $mode{$u} . $mode{$g} . $mode{$o};
    if ($sxid) {
	substr($_, 2, 1) = 's' if $sxid & 1;
	substr($_, 5, 1) = 's' if $sxid & 2;
	substr($_, 8, 1) = 't' if $sxid & 4;
    }
    $_;
}
;#
;# copy "$from" in TAR to "$to" on real filesystem
;#
sub copy_file {
    local($cwd, $from, $to) = @_;
    local($parent, $i) = &tree'namei($cwd, $from);
    $i || do { warn "$from: No such file or directory\n"; return; };
    local($offset, $size) = &tree'getattr($i, 'OFFSET', 'SIZE');
    local($buf, $s);

    $SIG{'PIPE'} = 'IGNORE';
    open(TO, $to) || return;
    if ($offset >= 0) {
	seek(TAR, $offset, 0) || (close(TO), return);
	while ($size > 0) {
	    ($s = read(TAR, $buf, $size > 8192 ? 8192 : $size)) > 0 || last;
	    print TO $buf;
	    $size -= $s;
	}
    } else {
	($data) = &tree'getattr($i, 'DATA');
	print TO $data;
    }
    close(TO);
}
;#
;# wildcard to regex convert
;#
sub wildcard {
    local($_) = @_;
    s#\\?.#$_ = $&; s/\\?([_0-9A-Za-z])/$1/ || /\\./ || s/[*]/.*/ ||
	s/[|]/\$|^/ || tr/?{,}[]\-/.(|)[]\-/ || s/./\\$&/; $_;#ge;
    length($_) ? "^$_\$" : undef;
}
;#
;# set variable
;#
sub setvar {
    local($varname, $val);

    $varname = shift;
    if ($varname =~ s/=(.*)//) {
	$val = ($1 ne '') ? $1 : shift;
    }
    else {
	$val = shift;
	if ($val =~ s/^=// && $' eq '') {
	    $val = shift;
	}
    }
    $varlist{$varname} = $val;
}
;#
;# show prompt
;#
sub prompt {
    local($_) = $varlist{'prompt'} || 'tarfs > ';

    s/\%F/$varlist{'tarfile'}/g;
    s/\%D/$varlist{'cwd'}/g;
    print;
}

;#####################################################################
package tree;
;#####################################################################
;#
;# tree.pl: package for tree structure
;#
;# Copyright (c) 1997 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;#
;# Copyright (c) 1992,1993 Kazumasa Utashiro
;# Software Research Associates, Inc.
;# Original: October 1992
;#
;; $rcsid = q$Id: tarfs,v 1.9 1997/03/13 12:43:17 utashiro Exp $;
;#

;#
;# Call initialize function if it is not called yet.  This may sound
;# strange but it makes easy to embed this library at the end of
;# script.  Call &tree'init at the beginning of the script in that
;# case.
;#
&init unless defined $version;

;#
;# Initialize variables.
;#
sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';

    $ROOTI = 2;
    $ILEN = 5;
    $lasti = $ROOTI;
    @freei = ();

    &newattr('TYPE', 'DATA', 'LINK', 'SIZE', 'MODE', 'MTIME', 'UID', 'GID');

    $_TYPE[$ROOTI] = 'd';
    &add_dirent($ROOTI, '.', 2, '..', 2);
}

sub rooti { $ROOTI; }
sub mkdir { &mknode(@_[0,1], 'd'); }
sub creat { &mknode(@_[0,1], 'f'); }
sub newi  { (@freei && pop(@freei)) || sprintf("%0${ILEN}d", ++$lasti); }
sub type  { $_TYPE[shift]; }
sub data  { $_DATA[shift]; }

sub newattr {
    local($setattr, $getattr, $init);

    @ATTRIBUTES{@_} = (1) x @_;
    undef &setattr; undef &getattr;

    $setattr = 'sub setattr {
    local($i, @attrlist) = @_;
    local($attr, $val);
    while (@attrlist >= 2) {
	($attr, $val) = splice(@attrlist, 0, 2);' . "\n";

    $getattr = 'sub getattr {
    local($i, @attrlist) = @_;
    local($attr, @values);
    while ($attr = shift(@attrlist)) {' . "\n";

    for (keys %ATTRIBUTES) {
	$setattr.="\t\$_$_\[\$i\] = \$val, next if \$attr eq '$_';\n";
	$getattr.="\tpush(\@values, \$_$_\[\$i\]), next if \$attr eq '$_';\n";
    }
    $setattr .= "\twarn \"Bad attribute \$attr\\n\";\n    }\n}\n";
    $getattr .= "\twarn \"Bad attribute \$attr\\n\";\n    }\n    \@values}\n";
    eval $setattr;
    eval $getattr;
}

sub symlink {
    local($i, $name, $linkname) = @_;
    local($newi);
    ($newi = &mknode($i, $name, 'l')) || return undef;
    &setattr($newi, 'DATA', $linkname);
    $newi;
}

sub readlink {
    local($parent, $i) = &namei(@_);
    $i && $_TYPE[$i] eq 'l' ? $_DATA[$i] : undef;
}    

sub mknode {
    local($i, $name, $type) = @_;
    local($newi);

    $_TYPE[$i] eq 'd' || return undef;
    while ($name =~ s@^([^/]*)/+@@) {
	$i = $ROOTI, next if $1 eq '';
	$i = &mkdir($i, $1), next unless $next = &geti($i, $1);
	if ($_TYPE[$next] eq 'd') {
	    $i = $next;
	} else {
	    return undef;
	}
    }
    return undef if &geti($i, $name);
    $newi = &newi;
    &add_dirent($i, $name, $newi);
    $_TYPE[$newi] = $type;
    &add_dirent($newi, '.', $newi, '..', $i) if $type eq 'd';
    $newi;
}

sub add_dirent {
    local($i, @list) = @_;
    local($name, $newi);
    while (($name, $newi) = splice(@list, 0, 2)) {
	$_DATA[$i] .= "/$name\0$newi";
    }
}

sub readdir {
    local($i) = @_;
    $_TYPE[$i] eq 'd' || return undef;
    $_DATA[$i] =~ m@[^/]+\0\d+@g;
}

sub geti {
    local($i, $name) = @_;
    $_TYPE[$i] eq 'd' || return undef;
    $name =~ s/[^\w]/\\$&/g;
    ($_DATA[$i] =~ m@/($name)\0(\d+)@) ? $2 : undef;
}

sub namei {
    local($parent, $_, $i) = @_;
    local($isdir) = s/\/+$//;

    $i = $parent;
    while (s:^([^/]*)(/*)::) {
	if ($1 eq '') {
	    $parent = $i = $ROOTI;
	} else {
	    return (undef, undef) if $_TYPE[$i] ne 'd';
	    $parent = $i;
	    $i = &geti($i, $1);
	}
	return (undef, undef) if $isdir && $_TYPE[$i] ne 'd';
	if ($_ eq '' || !defined($i)) {
	    return ($parent, $i);
	}
    }
}

sub getpath {
    local($dot) = @_;
    local(@path, $dotdot);

    $_TYPE[$dot] eq 'd' || return undef;
    while ($dot != $ROOTI) {
	$dotdot = &geti($dot, '..');
	die "Invalid inumber" unless $dotdot;
	for (&readdir($dotdot)) {
	    unshift(@path, $1), last if /(.*)\0(.*)/ && $2 == $dot;
	}
	$dot = $dotdot;
    }
    '/' . join('/', @path);
}

sub dump {
    local($i, $prefix) = @_;
    local(@dirent);
    local($name, $inum);

    @dirent = &readdir($i);
    for (@dirent) {
	(($name, $inum) = m/(.*)\0(.*)/ ) || next;
	print "$prefix/$name\n";
	next if $_TYPE[$inum] ne 'd' || $name eq '.' || $name eq '..';
	&dump($inum, "$prefix/$name");
    }
}

1;