#! /usr/bin/perl
#
# Copyright (C) 2002,2003,2010 Cliff Miller <cbm@nightcoder.com>
#  
# This file is free software; as a special exception the author gives
# unlimited permission to copy and/or distribute it, with or without 
# modifications, as long as this notice is preserved.
# 
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
############################################################
#
# xed - edit a file under rcs control
# 
# perl version full rewrite, cbm 3/6/02
#
#

use Errno;
use Fcntl;

sub xed_warn {
	local(@msg) = @_;
	print STDERR "$prog: @msg\n";
}

sub xed_fail {
	&xed_warn(@_);
	exit 1;
}

sub basename {
	($str) = @_;

	$str =~ s/\/*$//;
	$str =~ s/.*\///;
	return $str;
}

sub dirname {
	($str) = @_;

	$str =~ s/\/*$//;
	if($str !~ m#/#) { $str = "."; }
	else {
		$str =~ s/\/[^\/]+$//;
		if($str eq "") { $str = "/"; }
	}
	return $str;
}

sub envor {
	# emulate ksh ": ${VAR:=value}"

	($ev,$df) = @_;

	if(exists($ENV{$ev})) {
		return $ENV{$ev};
	} else {
		return $df;
	}
}

$ENV{"PATH"} = "/bin:/usr/ucb:/usr/bsd:/usr/bin";	# needed for XED_TEXT

$prog = &basename($0);
umask 2;

if($#ARGV!=0) {
	&xed_fail("usage: $prog file-to-be-edited");
}

$file = $ARGV[0];
$origfile = $file;

while(-l $file) {
	$targ = readlink($file);
	$tdir = &dirname($targ);
	chdir $tdir || &xed_fail("can't cd $tdir");
	$file = &basename($targ);
	if(++$x > 50) {
		&xed_fail("symbolic link traversal loop for $targ");
	}
}

$lockfile = &envor("XED_LOCKFILE", "$file.lock");
$xedcmd = &envor("XED_COMMAND", "xedl");
$locktext = &envor("XED_TEXT",
	`whoami`."@".`hostname|cut -d. -f1`." on ".`tty`." running '$xedcmd $origfile' (pid $$)");
$locktext =~ s/\n//g;


#
# now comes the fme/flock execution phase
#

if(!sysopen(LF, $lockfile, O_RDWR|O_CREAT|O_EXCL, 0664)) {
	if($!{EEXIST}) {
		&xed_fail("$lockfile already locked");
	}
	else {
		&xed_fail("open $lockfile failed: $!");
	}
}
print LF "$locktext\n";
close LF;

if($xedcmd ne "xedl") {
	$ret = system($xedcmd);
}
else {
	eval { $ret = &xedl; }
	# not sure if there should be something after this...
}

unlink $lockfile;
exit $ret;

sub check_for_rcsfile
{
	foreach $f ( "$file,v", &dirname("$file")."/RCS/".&basename("$file,v") ) {
		next if(! -r $f);
		$rcsfile = $f;
		last;
	}
}

#############################################################
#
# xedl
#
# assumed to be executed as an eval, i.e., signal or exit
# will cause a termination, but return to caller
#
#############################################################


sub xedl
{
	@SIG{(HUP,INT,TERM)} = \&exit_handler x 3;

	$rcsdir = &envor("RCSDIR", "/usr/bin");

	if(! -x "$rcsdir/rcsdiff") {
		&xed_warn("could not find rcs commands");
		$rcsfound=0;
	}
	else {
		$rcsfound=1;
	}

	$rcsdiff = &envor("RCSDIFF", "$rcsdir/rcsdiff");
	$rcs     = &envor("RCS"    , "$rcsdir/rcs");
	$ci      = &envor("CI"     , "$rcsdir/ci");
	$co      = &envor("CO"     , "$rcsdir/co");

	$crchk   = &envor("CRCHK"  , "");

	$editor  = &envor("EDITOR" , "vi");

	# assume we already know $file and $lockfile

	$ecode = 1;

	if(exists($ENV{'INTERACTIVE'})) {
		$interactive = $ENV{'INTERACTIVE'} eq '1';
	} else {
		$interactive = (-t);
	}

	if(exists($ENV{'CILOG'})) {
		@ciopts = ('-m' . $ENV{'CILOG'});
	} else {
		@ciopts = ();
	}

#
# determine if file is under rcs control.
#

	if($rcsfound) {
		&check_for_rcsfile;
		if(!$rcsfile) {
			&interact("y", "File $file not under RCS control; check in? [y] ");
			if($reply =~ /^y/) {
				&do_or_die($ci, @ciopts, '-i', '-u', $file);
				&check_for_rcsfile;
			}
		}
	}


#
# check file out if under rcs control.
#

	if($rcsfile) {
		# file is under rcs control.
		# assume we'll be checking the file out,
		# but test for special conditions.

		$reply = "o";

		# (1) is it already checked out?

		if(! -r $file) {
			# no, just check it out

			&xed_warn("Checking out $file from RCS version");
		}

		# otherwise, it's been checked out.
		# do an rcsdiff and, if the exit code is nonzero,
		# just go ahead and abort.  let the user fix it offline.

		elsif(system($rcsdiff, $file)) {
			&xed_warn("Existing $file differs from RCS version");
			&interact("a", "Check in [i] or out [o], or abort [a]: [a] ");
		}

		# if rcsdiff succeeded, there were no differences.  check out.

		if($reply =~ /^i/) {
			&do_or_die($rcs, '-l', $file);
			&do_or_die($ci, @ciopts, '-l', $file);
		}
		elsif($reply =~ /^o/) {
			&do_or_die($co, '-f', '-l', '-M', $file);
		}
		else {
			&xed_warn("Terminating without RCS activity");
			&exit_handler;
		}
		$checked_out = 1;
	}

#
# edit cycle.
#

	while(1) {
		$SIG{'INT'} = 'IGNORE';
		system($editor, $file);
		$SIG{'INT'} = \&exit_handler;
		last if(!$rcsfile);
		system($rcsdiff, $file);
		&interact("c", "Re-enter editor [e], commit [c] or abort[a]: [c] ");
		if($reply =~ /^a/) { &exit_handler; }
		elsif($reply !~ /^e/) { last; }
	}

#
# crchk.
#

	if(-x $crchk) {
		$crcline = `grep CRC= $file | sed 1q`;
		if($crcline =~ /CRC=\d+/) {
			@cmd = ($crchk);
			push(@cmd, "-w") if($crcline =~ /-w/);
			&xed_warn("recomputing checksum");
			unlink("$file.crc");
			system(@cmd, '-c', 'crc', $file, $file);
		}
	}

#
# done.
#
	if($rcsfile) {
		$checked_out = 0;
		system($ci, @ciopts, '-u', $file);
	}
	$ecode = 0;
	&cleanup;
	return 0;
}

sub interact
{
	($dflt,$prompt) = @_;

	if($interactive) {
		print $prompt;
		open TTY,"/dev/tty";
		eval {
#			local @SIG{(HUP,INT,TERM)} = {sub {die 'interrupt'}} x 3;
			local $SIG{HUP} = sub {die 'interrupt'};
			local $SIG{INT} = sub {die 'interrupt'};
			local $SIG{TERM} = sub {die 'interrupt'};
			$reply = <TTY>;
		};
		close TTY;
		$reply =~ s/^\s+//;
		if($reply eq "") {
			$reply = $dflt;
		}
	}
	else {
		$reply = $dflt;
		&xed_warn("$prompt");
		&xed_warn("defaulting to $dflt");
	}
}

sub do_or_die
{
	@cmd = @_;

	$ret = system(@cmd);
	if($ret) {
		&xed_warn("@cmd failed; terminating.");
		if(!$in_handler) { &exit_handler; }
	}
	return $ret;
}

sub cleanup
{
	# exit xedl.
	# this is the code to execute signal traps,
	# and also to exit xedl with error status.

	if($checked_out) {
		&xed_warn("reverting to old $file");
		&do_or_die($co, '-f', '-u', $file);
	}
	sysopen(LF, $lockfile, O_RDWR|O_TRUNC);
	close LF;
}

sub exit_handler
{
	$in_handler = 1;
	&cleanup;
	die if($ecode);
}
