#!/usr/bin/perl -w
require 5;
use File::stat;
use Fcntl;
# use Fcntl ':mode';
$0=~s!(.*/)!!;
my $programdir=$1 || "";

BEGIN {
	open(ERRORS, ">&STDERR");
	open(STDERR, ">/dev/null");
	unless (eval "import Fcntl ':mode'; 1")
	{
		*{"main::S_IFMT"} = sub { 0170000 };
		*{"main::S_IFSOCK"} = sub { 0140000 };
		*{"main::S_IFLNK"} = sub { 0120000 };
		*{"main::S_IFREG"} = sub { 0100000 };
		*{"main::S_IFBLK"} = sub { 0060000 };
		*{"main::S_IFDIR"} = sub { 0040000 };
		*{"main::S_IFCHR"} = sub { 0020000 };
		*{"main::S_IFIFO"} = sub { 0010000 };
	}
	open(STDERR, ">&ERRORS");
	close(ERRORS);
}

use strict;

$|=1;
my $ftserver=$programdir."ftserver";

my $machine=$ARGV[0] || die("Usage: $0 hostname\n");
my $packedintlen=length(pack("i", 0));

open(FTSERVER, $ftserver) || die("open $ftserver: $!\n");
my $pid=makeconnection($machine);
my ($instream, $outstream)=(*READFROMCHILD, *WRITETOCHILD);
sendserverprogram(*FTSERVER, $outstream);
close(FTSERVER);
print recvdataitem();
print "\n";
my $rcwd=recvdataitem();
my $lcwd=`pwd`;
chomp($lcwd);
print "Remote directory: $rcwd\n";
print "Local directory: $lcwd\n";
my @work;
my %filelist;
my %filestat;
my $interactive=1;
my $exitrequested=0;

my $helpstr=
    "Interactive commands:\n".
    "  help                Print this message\n".
    "\n".
    "  ls                  Remote directory list\n".
    "  dir                 Remote directory list (long format)\n".
    "  cd                  Remote change directory\n".
    "  cat                 Remote show file contents\n".
    "\n".
    "  lls                 Local directory list\n".
    "  ldir                Local directory list (long format)\n".
    "  lcd                 Local change directory\n".
    "  lcat                Local show file contents\n".
    "\n".
    "  go                  Run deferred commands immediately\n".
    "  exit (or <EOF>)     Exit the interpreter and run deferred commands\n".
    "                      (Output is returned via email)\n".
    "\n".
    "Deferred commands:\n".
    "  get                 Retreive a file from the remote server\n".
    "  put                 Store a file on the remote server\n".
    "\n".
    " Queue management commands:\n".
    "  show                Show deferred commands\n".
    "  undo                Remove the most recent deferred command\n".
    "  abort               Clear list of deferred commands\n";

while (defined($_=getcommand()))
{
    s/^\s+//;
    /^(\w+)\s*(.*)/ || next;
    my @tokens=tokenize($_);
    next unless defined($tokens[0]);

    unless ($tokens[0]=~/^(\w+)$/)
    {
	    warn("Invalid character in command name\n");
	    next;
    }
    my $cmd=$1;
    shift(@tokens);
    my $ref;
    eval("\$ref=\\&cmd_$cmd");
    eval { &$ref(@tokens); 1; } || warn("Bad command: $cmd\n");
    next unless $exitrequested;
}
print "\n";

if (!@work)
{
    senddataitem("close");
    exit(0);
}

$interactive=0;
print "Work queue:\n";
for (@work)
{
    my ($action, $local, $remote, $file)=@$_;
    print "\U$action\E $file\n";
}

my $newpid=fork();
die("fork: $!\n") unless defined($newpid);
exit(0) if $newpid;

$SIG{"PIPE"}="IGNORE";
$SIG{"HUP"}="IGNORE";
open(STDIN, "</dev/null");
open(STDERR, ">/dev/null");
open(STDERR, ">/dev/null");

cmd_go(0);
senddataitem("close");

my $user=$ENV{'USER'};
open(MAIL, "|/bin/mail -s 'Results of file transfer' $user") || die("$0: popen mail: $!\n");
for (@work)
{
    my ($action, $local, $remote, $file, $err)=@$_;
    $err="success" unless defined($err);
    print MAIL "\U$action\E $file: $err\n";
}
close(MAIL) || die("$0: mail: $!\n");

sub getcommand
{
    print "$machine> ";
    my $line=<STDIN>;
    chomp($line) if defined($line);
    return $line;
}

sub tokenize
{
	my $line=shift;
	my @token;
	my $original=$line;
	my $failmsg;

	while ($line)
	{
		if ($line=~/^\s+(.*)/)
		{
			$line=$1;
			next;
		}
		if ($line=~/^[-\\\w\$%\(\)+=:~\.\/]/)
		{
			my $string="";
			while ($line=~/^([-\\\w\$%\(\)+=:~\.\/])(.*)/)
			{
				$line=~/^\\(.)(.*)/ if $1 eq "\\";
				unless (defined($1))
				{
					$failmsg="Missing character after ".
					    "\"\\\"";
					goto fail;
				}
				$string.=$1;
				$line=$2;
			}
			push(@token, $string);
			next;
		}
		if ($line=~/^\"(.*)/)
		{
			$line=$1;
			my $string="";
			while ($line=~/^([^\"])(.*)/)
			{
				$line=~/^\\(.)(.*)/ if $1 eq "\\";
				unless (defined($1))
				{
					$failmsg="Missing character after ".
					    "\"\\\"";
					goto fail;
				}
				$string.=$1;
				$line=$2;
			}
			unless ($line=~/\"(.*)/)
			{
				$failmsg="Missing quote before end of line";
				goto fail;
			}
			$line=$1;
			push(@token, $string);
			next;
		}
		$failmsg="unrecognised symbol";
	      fail:
		my $place=length($original)-length($line);
		warn("Can't tokenize line: $failmsg\n".
		     $original."\n".(" "x$place)."^\n");
		return undef;
	}
	return @token;
}

sub makeconnection
{
    pipe(READFROMCHILD, WRITETOPARENT);
    pipe(READFROMPARENT, WRITETOCHILD);
    my $pid=fork();
    die("fork: $!\n") unless defined($pid);
    if ($pid)
    {
	close(READFROMPARENT);
	close(WRITETOPARENT);
	my $oldfh=select(READFROMCHILD); $|=1;
	select(WRITETOCHILD); $|=1;
	select($oldfh);
	return $pid;
    }
    open(STDIN, "<&READFROMPARENT");
    open(STDOUT, ">&WRITETOPARENT");
    close(READFROMPARENT);
    close(WRITETOPARENT);
    close(READFROMCHILD);
    close(WRITETOCHILD);
    exec("ssh", $machine, "-a", "-X", "-C", "perl", "-") || die("exec ssh failed\n");
}

sub recvdataitem
{
    my $packedlen;
    my ($bytes, $error)=dosysread($instream, $packedlen, $packedintlen);
    die("$0: Read error in recvdataitem\n") if $error;
    die("$0: Unexpected EOF\n") if $bytes!=$packedintlen;
    my $len=unpack("i", $packedlen);
    my $data;
    ($bytes, $error)=dosysread($instream, $data, $len);
    die("$0: Read error in recvdataitem\n") if $error;
    die("$0: Unexpected EOF\n") if $bytes!=$len;
    return $data;
}

sub senddataitem
{
    my $data=shift;
    my $len=length($data);
    my $packedlen=pack("i", $len);
    my ($bytes, $error)=dosyswrite($outstream, $packedlen, $packedintlen);
    die("$0: Write error in senddataitem\n") if $error;
    ($bytes, $error)=dosyswrite($outstream, $data, $len);
    die("$0: Write error in senddataitem\n") if $error;
}

sub sendserverprogram
{
	my ($programstream, $server)=@_;
	my $data;
	my ($bytes, $error)=dosysread($programstream, $data, 4096);
	while ($bytes && !$error)
	{
		($bytes, $error)=dosyswrite($server, $data, $bytes);
		last if ($error);
		($bytes, $error)=dosysread($programstream, $data, 4096);
	}
	unless ($error)
	{
		$data="__END__\n";
		($bytes, $error)=dosyswrite($server, $data, length($data));

	}

	die("$0: Error while starting server process\n") if $error;
}

sub dosysread
{
    my ($fh, $data, $len)=@_;
    my $bytesread=0;

    $data="";
    while ($len)
    {
	my $thisdata;
	my $bytes=sysread($fh, $thisdata, $len);
	unless (defined($bytes))
	{
	    my $error="$!";
	    warn("$0: read: $error\n");
	    return ($bytesread, $error);
	}
	last if $bytes==0;
	$data.=$thisdata;
	$len-=$bytes;
	$bytesread+=$bytes;
    }
    $_[1]=$data;
    return ($bytesread, undef);
}

sub dosyswrite
{
    my ($fh, $data, $len)=@_;
    my $byteswritten=0;

    while ($len)
    {
	my $bytes=syswrite($fh, $data, $len);
	unless (defined($bytes))
	{
	    my $error="$!";
	    warn("$0: write: $error\n");
	    return ($byteswritten, $error);
	}
	substr($data, 0, $bytes, "");
	$len-=$bytes;
	$byteswritten+=$bytes;
    }
    return $byteswritten;
}

sub cmd_exit
{
	$exitrequested=1;
}

sub cmd_help
{
    print $helpstr;
}

sub cmd_ls
{
    my @files;
    if (exists($filelist{$rcwd}))
    {
	print "Contents of $rcwd (cached)\n";
	@files=@{$filelist{$rcwd}};
    }
    else
    {
	senddataitem("ls");
	my $status=recvdataitem();
	if ($status ne "OK")
	{
	    warn(recvdataitem()."\n");
	    return;
	}
	my $files=recvdataitem();
	@files=split("\0", $files);
	$filelist{$rcwd}=\@files;
	print "Contents of $rcwd\n";
    }
    map { print "  $_\n" } sort (@files);
}

sub cmd_lls
{
    opendir(DIR, ".") || die;
    my @files=readdir(DIR);
    closedir(DIR);
    map { print "  $_\n" } sort (@files);
}

sub cmd_dir
{
    my @filenames;
    my $usecache=0;
    if (exists($filelist{$rcwd}))
    {
	@filenames=@{$filelist{$rcwd}};
	my $file;
        $usecache=1;
	for $file (@filenames)
	{
		if (!exists($filestat{"$rcwd/$file"}))
		{
			$usecache=0;
			last;
		}
	}
	print "Contents of $rcwd (cached)\n" if $usecache;
    }

    unless ($usecache)
    {
        @filenames=();
	senddataitem("dir");
	my $status=recvdataitem();
	if ($status ne "OK")
	{
	    warn(recvdataitem()."\n");
	    return;
	}
	my $files=recvdataitem();
	my @files=split("\0", $files);
	while (@files)
	{
		my $file=shift(@files);
		push (@filenames, $file);
		my $status=shift(@files);
		if ($status eq "ERROR")
		{
			my $error=shift(@files);
			$filestat{"$rcwd/$file"}=[$error];
			next;
		}
		my @stat=splice(@files, 0, 13);
		$filestat{"$rcwd/$file"}=[undef, @stat];
	}
	$filelist{$rcwd}=\@filenames;
	print "Contents of $rcwd\n";
    }
    my $file;
    for $file (sort(@filenames))
    {
	    my ($error, $mode, $nlink, $user, $group, $size, $mtime)=
		@{$filestat{"$rcwd/$file"}}[0, 3,4, 5,6, 8,10];
	    if ($error)
	    {
		    print STDERR "$file: $error\n";
		    next;
	    }
	    printf("%s %4i %8s %8s %9i %s %s\n",
		   mode_to_type($mode).mode_to_perms($mode), $nlink,
		   $user,$group, $size, localdatetime($mtime), $file);
    }
}

sub cmd_ldir
{
    opendir(DIR, ".") || die;
    my @files=readdir(DIR);
    closedir(DIR);
    my $file;
    for $file (sort (@files))
    {
	    my $stat=lstat($file);
	    unless(defined($stat))
	    {
		    warn("$_: $!\n");
		    next;
	    }
	    printf("%s %4i %8s %8s %9i %s %s\n",
		   mode_to_type($stat->mode).mode_to_perms($stat->mode),
		   $stat->nlink,
		   lookup_uid($stat->uid),
		   lookup_gid($stat->uid),
		   $stat->size,
		   localdatetime($stat->mtime),
		   $file);
    }
}

sub localdatetime
{
	my $time=shift;
	my ($sec,$min,$hour,$mday,$mon,$year) = localtime($time);
	return sprintf("%04i-%02i-%02i %02i:%02i:%02i", 
		       $year+1900, $mon+1, $mday, $hour, $min, $sec);
}

sub mode_to_type
{
	my $mode=shift;
	$mode &= S_IFMT;
	my $type="?";
	$type='s' if $mode == S_IFSOCK;
	$type='l' if $mode == S_IFLNK;
	$type='-' if $mode == S_IFREG;
	$type='b' if $mode == S_IFBLK;
	$type='d' if $mode == S_IFDIR;
	$type='c' if $mode == S_IFCHR;
	$type='p' if $mode == S_IFIFO;
	return $type;
}

sub mode_to_perms
{
	my $mode=shift;
	$mode &= ~S_IFMT;
	my $u=mode_cvt(($mode >> 6) & 7, $mode & 04000, "S", "s");
	my $g=mode_cvt(($mode >> 3) & 7, $mode & 02000, "S", "s");
	my $o=mode_cvt(($mode >> 0) & 7, $mode & 01000, "T", "t");
	return $u.$g.$o;
}

sub mode_cvt
{
	my $mode=shift;
	my $flag=shift;
	my @setid=@_;
	my $r=($mode & 4)? "r":"-";
	my $w=($mode & 2)? "w":"-";
	my $x=($mode & 1)? "x":"-";
	$x=$setid[$mode & 1] if $flag;
	return $r.$w.$x;
}

my %uid;
sub lookup_uid
{
	my $uid=shift;
	$uid{$uid}=getpwuid($uid) unless exists($uid{$uid});
	return $uid{$uid}? $uid{$uid}:"uid:".$uid;
}

my %gid;
sub lookup_gid
{
	my $gid=shift;
	$gid{$gid}=getgrgid($gid) unless exists($gid{$gid});
	return $gid{$gid}? $gid{$gid}:"gid:".$gid;
}

sub cmd_cd
{
    my $dir=shift;
    unless (defined($dir) && $dir ne "")
    {
	print "Remote directory: $rcwd\n";
	return;
    }
    senddataitem("cd");
    senddataitem($dir);
    my $status=recvdataitem();
    if ($status ne "OK")
    {
	warn(recvdataitem()."\n");
	return;
    }
    $rcwd=recvdataitem();
    print "Remote directory: $rcwd\n";
}

sub cmd_lcd
{
    my $dir=shift;
    unless (defined($dir) && $dir ne "")
    {
	print "Local directory: $lcwd\n";
	return;
    }
    unless (chdir($dir))
    {
	warn("$0: lcd: $!\n");
	return;
    }
    $lcwd=`pwd`;
    chomp($lcwd);
    print "Local directory: $lcwd\n";
}

sub cmd_get
{
    my $file=shift;
    unless (defined($file) && $file ne "")
    {
	warn("$0: cat what?\n");
	return;
    }
    if ($file=~m!/!s)
    {
	warn("$0: Filename must not contain /");
	return;
    }
    senddataitem("fileexists");
    senddataitem($file);
    my $status=recvdataitem();
    if ($status ne "OK")
    {
	warn(recvdataitem()."\n");
	return;
    }
    push(@work, ["get", $lcwd, $rcwd, $file]);
    my $src="$rcwd/$file";
    my $dst="$lcwd/$file";
    $src=~s,//,/,;
    $dst=~s,//,/,;
    print "Added to work list: $src -> $dst\n";
}

sub cmd_put
{
    my $file=shift;
    unless (defined($file) && $file ne "")
    {
	warn("$0: Put what?\n");
	return;
    }
    if ($file=~m!/!s)
    {
	warn("$0: Filename must not contain /");
	return;
    }
    unless (-e $file)
    {
	warn("$0: Object does not exist\n");
	return;
    }
    unless (-f $file)
    {
	warn("$0: Object is not a file\n");
	return;
    }
    push(@work, ["put", $lcwd, $rcwd, $file]);
    my $src="$lcwd/$file";
    my $dst="$rcwd/$file";
    $src=~s,//,/,;
    $dst=~s,//,/,;
    print "Added to work list: $src -> $dst\n";
}

sub cmd_go
{
    for (@work)
    {
	my ($action, $local, $remote, $file)=@$_;
	my $err;
	if ($action eq "get") {
	    work_doget($local, $remote, $file, $err);
	} elsif ($action eq "put") {
	    work_doput($local, $remote, $file, $err);
	} else {
	    die("Bad action: $action\n");
	}
	$_[3]=$err;
	$err="success" unless defined($err);
	print "\U$action\E $file: $err\n"
	    if $interactive;
    }
    @work=();
}

sub cmd_abort
{
    print "Abandoning work queue\n";
    @work=();
}

sub cmd_undo
{
    print "Removing last entry from work queue\n";
    my $last=pop(@work);
    if (defined($last))
    {
	    my ($action, $local, $remote, $file)=@$last;
	    print "\U$action\E $file\n";
    }
    else
    {
	    warn("Work queue was already empty\n");
    }
}

sub cmd_show
{
    print "Contents of work queue\n";
    for (@work)
    {
	    my ($action, $local, $remote, $file)=@$_;
	    print "\U$action\E $file\n";
    }
}

sub cmd_cat
{
    my $file=shift;
    unless (defined($file) && $file ne "")
    {
	warn("$0: cat what?\n");
	return;
    }
    if ($file=~m!/!s)
    {
	warn("$0: Filename must not contain /");
	return;
    }
    senddataitem("get");
    senddataitem($file);
    my $status=recvdataitem();
    my ($bytes, $error);
    while ($status eq "DATA")
    {
	my $data=recvdataitem();
	$data=~s/\f/\\f/sg;
	$data=~s/\a/\\a/sg;
	$data=~s/\e/\\e/sg;
	$data=~s/\r/\\r/sg;
	$data=~tr/ -~\n\t/?/c;
	print $data;
	$status=recvdataitem();
    }
    close(FILE);
    warn(recvdataitem()."\n")
	if $status ne "OK";
}

sub cmd_lcat
{
    my $file=shift;
    unless (defined($file) && $file ne "")
    {
	warn("$0: cat what?\n");
	return;
    }
    if ($file=~m!/!s)
    {
	warn("$0: Filename must not contain /");
	return;
    }
    unless (open(FILE, "<$file"))
    {
	warn("$0: cat: $!\n");
	return;
    }
    my $stat=lstat(*FILE);
    unless (defined($stat))
    {
	warn("$0: cat: $!\n");
	return;
    }
    unless (($stat->mode & S_IFMT) == S_IFREG)
    {
	warn("$0: cat: Not a regular file\n");
	return;
    }
    my $data;
    my ($bytes, $error)=dosysread(*FILE, $data, 4096);
    while ($bytes && !$error)
    {
	$data=~tr/ -~\n/?/c;
	print $data;
	($bytes, $error)=dosysread(*FILE, $data, 4096);
    }
    close(FILE);
}

sub work_doget
{
    my ($local, $remote, $file)=@_;
    unless (chdir($local))
    {
	$_[3]="$!";
	return;
    }
    senddataitem("cd");
    senddataitem($remote);
    my $status=recvdataitem();
    if ($status ne "OK")
    {
	$_[3]=recvdataitem();
	return;
    }
    recvdataitem();
    unless (open(FILE, ">.$file.new"))
    {
	$_[3]="$!";
	return;
    }
    senddataitem("get");
    senddataitem($file);
    $status=recvdataitem();
    my ($bytes, $error);
    while ($status eq "DATA")
    {
	my $data=recvdataitem();
	($bytes, $error)=dosyswrite(*FILE, $data, length($data))
	    if length($data) && !$error;
	$status=recvdataitem();
    }
    close(FILE);
    if ($status ne "OK")
    {
	unlink(".$file.new");
	$_[3]=recvdataitem();
	return;
    }
    unless (rename(".$file.new", "$file"))
    {
	$_[3]=$!;
	return;
    }
}

sub work_doput
{
    my ($local, $remote, $file)=@_;
    unless (chdir($local))
    {
	$_[3]="$!";
	return;
    }
    senddataitem("cd");
    senddataitem($remote);
    my $status=recvdataitem();
    if ($status ne "OK")
    {
	$_[3]=recvdataitem();
	return;
    }
    recvdataitem();
    unless (open(FILE, "<$file"))
    {
	$_[3]="$!";
	return;
    }
    my $stat=lstat(*FILE);
    unless (defined($stat))
    {
	$_[3]="$!";
	return;
    }
    unless (($stat->mode & S_IFMT) == S_IFREG)
    {
	$_[3]="Not a regular file";
	return;
    }
    senddataitem("put");
    senddataitem($file);
    if (recvdataitem() ne "OK")
    {
	$_[3]=recvdataitem();
	return;
    }
    my $data;
    my ($bytes, $error)=dosysread(*FILE, $data, 4096);
    while ($bytes && !$error)
    {
	senddataitem("DATA");
	senddataitem($data);
	($bytes, $error)=dosysread(*FILE, $data, 4096);
    }
    close(FILE);
    if ($error)
    {
	senddataitem("ERROR");
	senddataitem("$!");
    }
    else
    {
	senddataitem("OK");
    }
    if (recvdataitem() ne "OK")
    {
	my $remoteerror=recvdataitem();
	$_[3]=($error? $error : $remoteerror);
	return;
    }
}