#!/usr/bin/perl
# $Id: vircs.pl,v 1.22 2002/04/08 14:23:50 phil Exp $
#
# vircs -- edit a file under RCS control, with sanity checks and review
# Copyright 2001, Phil Pennock.  All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

# TODO:
#  Decide what to do about editor backup files
#  Should we really be messing with options if it's less?

use warnings;
use strict;

my %paths = (
    rcs		=> '/usr/bin/rcs',
    ci		=> '/usr/bin/ci',
    co		=> '/usr/bin/co',
    diff	=> '/usr/bin/diff',
    'cmp'	=> '/usr/bin/cmp',
    vi		=> '/usr/bin/vi',
    mg		=> '/usr/bin/mg',
    more	=> '/usr/bin/more',
    );

use Cwd;
use Errno;
use Fcntl ':flock';
use File::Basename;
use File::Copy;
use File::Temp qw(tempfile unlink0);
use File::stat ();
use IO::File;
use IPC::Run 'run';
use Term::ReadKey;

sub handle_edit ($);
sub checkfor_hooks ($$$); # prog-hash-ref dir datafile
sub hook_permsok ($$);
sub confirm_integrity ($$);
sub display_changes ($$);
sub ensure_rcs_dir ($);
sub ensure_fileperms ($$$); # filename, statbuf, verbosity
sub check_dirsetupok ($);
sub check_dirok ($);
sub expand_exitstatus ($);
sub system_try ($$@);
sub backup ($);
sub getkeypress (;$);

my %locks;
sub lock_get ($);
sub lock_get_once ($);
sub lock_release ($);

# Damage limitation if trojaned hook is there.
delete $ENV{'SSH_AUTH_SOCK'};

$| = 1;
die "Need to edit a file" unless @ARGV;

my $editor = $paths{'vi'};
$editor = $paths{'mg'} if -x $paths{'mg'}; # OpenBSD standard editor
if (exists $ENV{'VISUAL'}) {
	$editor = $ENV{'VISUAL'};
} elsif (exists $ENV{'EDITOR'}) {
	$editor = $ENV{'EDITOR'};
}
my $pager = $paths{'more'};
$pager = $ENV{'PAGER'} if exists $ENV{'PAGER'};
# I can't be bothered to canonicalise.
# If the user has screwed env, that's their problem
die "Editor '${editor}' not executable\n"
	unless -x $editor or $editor !~ m:/:;
die "Pager '${pager}' not executable\n"
	unless -x $pager or $pager !~ m:/:;

if ($editor =~ /\s/) {
	$editor = [split(/\s+/, $editor)];
}
if ($pager =~ /\s/) {
	$pager = [split(/\s+/, $pager)];
}

# If these exist in RCS, use them; RCS viles end ,v so no clash
my %prog = (
    editor	=> $editor,
    ci		=> $paths{'ci'},
    co		=> $paths{'co'},
    compare	=> undef,
    integrity	=> undef,
    postcommit	=> undef,
    );

undef $editor; # not used any more; crude I know

my $first = 1;
my $maincwd = cwd;
my @backupfiles;
foreach my $fn (@ARGV) {
	sleep 1 unless $first;
	$first = 0;
	my %saved = %prog;
	check_dirsetupok $maincwd;
	chdir $maincwd;
	eval { handle_edit $fn };
	warn $@ if $@;
	%prog = %saved;
}

foreach (sort keys %locks) {
	if (-e $_) {
		warn "Lock droppings at exit: $_\n";
	} else {
		warn "POSSIBLE CORRUPTION: $_ no longer exists\n" .
			"\twe didn't free it, but should have, probable issue".
			" with concurrency\n";
	}
}
foreach (@backupfiles) {
	if (-e $_) {
		warn "Lingering backup file: $_\n";
	}
}

exit 0;

# ======================================================================

sub handle_edit ($)
{
	my $dir = dirname $_[0]; # if no in $_[0] then is .
	my $datafile = basename $_[0];
	my ($response, $editcount, $starttime);
	my ($nocommit, $forcedreedit) = (0, 0);

	die "Can't cd to '${dir}': $!\n" unless chdir $dir;
	die "No such file '${datafile}'\n" unless -e $datafile;

	my $madercsdir = ensure_rcs_dir $dir;

	check_dirsetupok($dir . '/RCS');

	checkfor_hooks(\%prog, $dir, $datafile);
	# Shortcuts
	my ($ci, $co) = ($prog{'ci'}, $prog{'co'});


	my $lck = "./LCK.$datafile";

	return unless lock_get $lck;

# Deliberately leave BKP.* files "just in case"
	$SIG{'INT'} = sub { lock_release $lck; };

	my $pre_stat = File::stat::stat($datafile);
	if (not -f _) {
		lock_release $lck;
		die "Can't edit, not a file: '${datafile}'\n";
	}

	my $backupfn = backup $datafile; # should unlock if failing
	push @backupfiles, $backupfn;

	if ($madercsdir or not -e "RCS/$datafile,v") {
		print "RCS($datafile) doesn't exist yet, so checking in\n";
		system_try undef, $paths{'rcs'}, '-i', $datafile;
		system_try undef, $ci, '-u', $datafile;
# Trust RCS to not mess up file-perms beyond removing write; now get new
		$pre_stat = File::stat::stat($datafile);
	}
	if (not system_try $lck, $co, '-l', $datafile) {
		die "Failed to check out '${datafile}'\n";
	}

	$starttime = time; $editcount = 1;

	system_try $lck, $prog{'editor'}, $datafile;

REEDITPOINT: { # {{{
	while ($forcedreedit or not confirm_integrity $datafile, $backupfn) {

		if (++$editcount >= 10) {
			my $elapsed = time - $starttime;
			print "$editcount edits in $elapsed seconds;";
			print "Continue? (y/N) ";
			if (getkeypress('Continue? (y/N) ') =~ /^[YyJj]/) {
				print "Okay, you asked for it.\n";
				$starttime = time;
				$editcount = 0;
			} else {
				lock_release $lck;
				warn "Aborting, leaving backup in $backupfn\n";
				sleep 2;
				die "Editor '${editor}' looping\n";
			}
		}

		my $intreact;
		if ($forcedreedit) {
			$intreact = 'Y';
		} else {
			$intreact = getkeypress 'Try again? (Yes/force/no) ';
		}
		$forcedreedit = 0;

		if ($intreact =~ /^[YyJj\n]/) {
			system_try undef, $prog{'editor'}, $datafile;
		} elsif ($intreact =~ /^[Ff]/) {
			warn "Overriding Integrity Check!\n";
			sleep 1;
			last;
		} else {
			print "Restoring file\n";
			system_try undef, $co, qw(-u -f -q), $datafile;
			lock_release $lck;
			return;
		}
	}

	my $changed = display_changes $datafile, $backupfn;

	if (not $changed) {
		print "Not changed, not committing; checking out old version\n";
		system_try undef, $co, qw(-u -f -q), $datafile;
		ensure_fileperms($datafile, $pre_stat, 1);
		lock_release $lck;
		return;
	}

	my $kp = getkeypress('Commit these changes (or edit)? (y/e/N) ');
	if ($kp =~ /^[YyJj]/) {
		system_try undef, $ci, '-u', $datafile;
		ensure_fileperms($datafile, $pre_stat, 1);
	} elsif ($kp =~ /^[Ee]/) {
# Yeah, spot the grafted-on hack.  Like it's the only one.
		$forcedreedit = 1;
		redo REEDITPOINT;
	} else {
		$nocommit = 1;
		print "Restoring file\n";
		if (not system_try undef, $co, qw(-u -f -q), $datafile) {
			warn "Failed to co '${datafile}'\n" .
				"\tRestoring from '${backupfn}' ...\n";
			# In theory, if co failed is still writable
			copy $backupfn, $datafile;
			ensure_fileperms($datafile, $pre_stat, 1);
		}
	}

	     } # }}} REEDITPOINT

	unlink $backupfn;

# This is potentially bad; do we run post-commit whilst we still have a lock?
# I think so, otherwise there's a risk of bad data
	if (defined $prog{'postcommit'} and not $nocommit) {
		system_try undef, $prog{'postcommit'}, $datafile;
	}

	lock_release $lck;
}

# ----------------------------------------------------------------------

sub checkfor_hooks ($$$) # prog-hash-ref dir datafile
{
	my ($prog, $dir, $df) = @_;

	foreach (keys %{$prog}) {
		if (hook_permsok("$dir/RCS/${_}_$df", $df)) {
			if (-z _) {
				print STDERR "Deleting override(special): $_\n";
				$prog->{$_} = undef;
			} elsif (-x _) {
				print STDERR "Overriding(special): $_\n";
				$prog->{$_} = "$dir/RCS/${_}_$df";
			} else {
				print STDERR "Ignoring special override: $_\n";
				sleep 1;
			}
		}
		if (hook_permsok("$dir/RCS/$_", $df)) {
			if (-z _) {
				print STDERR "Deleting override: $_\n";
				$prog->{$_} = undef;
			} elsif (-x _) {
				print STDERR "Overriding: $_\n";
				$prog->{$_} = "$dir/RCS/$_";
			} else {
				print STDERR "Ignoring override: $_\n";
				sleep 1;
			}
		}
	}
}

# arg used for debugging and to ensure no constant inlining, since we're
# relying upon the _ FH changing.
sub hook_permsok ($$)
{
	my $fn = shift;
	my $df = shift;
	my $st = File::stat::stat($fn);

	return 0 unless defined $st;

	if ($st->uid ne $< and $st->uid ne 0) {
		print STDERR "DANGER: skipping badly owned hook `$df'\n";
		sleep 3;
		return 0;
	}
	if ($st->mode & 0022) {
		print STDERR "DANGER: excessively writable hook `$df'\n";
		sleep 3;
		return 0;
	}
	return 1;
}

# ----------------------------------------------------------------------

sub ensure_rcs_dir ($)
{
	my $dir = shift;
	return 0 if -d "$dir/RCS";
	print STDERR "$0: Creating non-existent '${dir}/RCS'\n";
	sleep 1;
	if (not mkdir "$dir/RCS", 0700) {
		die "Failed mkdir(${dir}/RCS): $!\n";
	}
	return 1;
}

# ----------------------------------------------------------------------

sub lock_get_once ($)
{
	my $lf = shift;
	my $lockh = new IO::File $lf, O_RDWR|O_CREAT|O_EXCL, 0644
		or do {
			die "Lack permission to create lockfile '${lf}'\n"
				if $!{EPERM} or $!{EACCES};
			return 0;
		};
	if (not flock $lockh, LOCK_EX) {
		$lockh->close; # don't unlink, since something else is around
		warn "Lock error on '${lf}': created excl, flock failed: $!\n";
		sleep 1;
		return 0;
	}
	$lockh->print("$$\n");
	$lockh->flush;
	eval { $lockh->sync };
	$locks{$lf} = $lockh;
	return 1;
}

sub lock_get ($)
{
	my $lf = shift;
	die "Internal error: already have a lock for '${lf}'\n"
		if exists $locks{$lf};

	my $abort;
	if (not lock_get_once $lf) {
		$abort = 1;
		print STDERR "Lockfile exists ($lf), cycling ...";
		foreach (qw(3 2 1)) {
			print STDERR " $_";
			sleep 2;
			if (lock_get_once $lf) {
				$abort = 0;
				print STDERR " freed!\n";
				last;
			}
		}
		if ($abort) {
			print STDERR "\n Lock lingering, aborting!\n";
			return 0;
		}
	}
	return 1;
}

sub lock_release ($)
{
	my $lfn = shift;
	if (not exists $locks{$lfn}) {
		warn "lock_release($lfn): not locked by me\n";
		return;
	}
	my $lockh = $locks{$lfn};
	$lockh->seek(0, 0);
	my $fpid = $lockh->getline;
	$fpid = -1 unless defined $fpid;
	chomp $fpid;
	die "Error: Locked file now has a pid which isn't ours.  $fpid != $$\n"
		unless $fpid == $$;
	unlink0($lockh, $lfn) or die "Unlink '${lfn}' failed: $!\n";
	flock $lockh, LOCK_UN or warn "Unlock '${lfn}': $!\n";
	delete $locks{$lfn};
}

# ----------------------------------------------------------------------

sub expand_exitstatus ($)
{
	my $ev = shift;
	return '<ok>' if $ev == 0;
	my ($ex, $sig, $core) = ($? >> 8, $? & 127, $? & 128);
	my $msg = 'died';
	$msg .= ", exitting $ex"        if $ex;
	$msg .= ", signal $sig"         if $sig;
	$msg .= ' (core dumped)'        if $core;
	return $msg;
}

sub system_try ($$@)
{
	my $lockname = shift;
	my $path = shift;
	if (ref $path) {
		if ('ARRAY' ne ref $path) {
			lock_release $lockname if defined $lockname;
			die "Internal error: system_try passed bad path\n";
		}
		unshift @_, @{$path}[1 .. $#{$path}];
		$path = $path->[0];
	}
	my $firstparam = $path;
	$firstparam =~ s{^.*/}{};
#warn "system_try {$path} ($firstparam @_)\n";
	system {$path} ($firstparam, @_);
	if ($? != 0) {
		my $msg = "$0: $firstparam: ".expand_exitstatus($?)."\n";
		if (defined $lockname) {
			lock_release $lockname;
			die $msg;
		} else { warn $msg; return 0; }
	} else { return 1; }
}

sub backup ($)
{
	my $sourcefn = shift;

	my ($fh, $targetfn) = tempfile("BKP.$sourcefn.XXXXXXX", DIR => '.');
	if (not defined $fh) {
		my $err = "$0: tempfile(): $!\n";
		lock_release $sourcefn;
		die $err;
	}
	copy $sourcefn, $fh;
	$fh->close;
	return $targetfn;
}

# ----------------------------------------------------------------------

sub confirm_integrity ($$)
{
	my ($newdatafile, $backupfile) = @_;

	if (defined $prog{'integrity'}) {
		system {$prog{'integrity'}}
			($prog{'integrity'}, $backupfile, $newdatafile);
		return $? == 0 ? 1 : 0;
	} else {
# If no integrity-checking program in RCS then all changes are safe
		return 1;
	}
}

sub display_changes ($$)
{
	my ($newdatafile, $backupfile) = @_;
	my @in;
	my @pager = ($pager);
	push @pager, '-XE' if $pager =~ m|^(?:.+/)?less$|;

	# Feeding into the run is too much hassle for such a small note
	print STDERR "Changes made:\n";

# If exists RCS/compare then use that
	if (defined $prog{'compare'}) {
		@in = ($prog{'compare'}, $backupfile, $newdatafile);
	} else {
		@in = ($paths{'diff'}, qw(-u -s), $backupfile, $newdatafile);
	}

	run \@in, '|', \@pager;

	return system {$paths{'cmp'}} (qw(cmp -s), $backupfile, $newdatafile);
}

# ----------------------------------------------------------------------

sub getkeypress (;$)
{
	my $print_nl = 0;
	if (scalar @_) {
		print $_[0];
		$print_nl = 1 unless $_[0] =~ /\n$/;
	}
	ReadMode 'cbreak';
	my $key = ReadKey 0;
	ReadMode 'restore';
	print $key;
	print "\n" if $print_nl;
	STDOUT->flush;
	return $key;
}

# ----------------------------------------------------------------------

sub ensure_fileperms ($$$)
{
	my ($fn, $pre_stat, $verbose) = @_;

	my $newstat = File::stat::stat($fn);
	die "File '${fn}' is no longer a regular file!\n" unless -f _;

	my $operms = $pre_stat->mode & 07777;
	my $nperms = $newstat->mode & 07777;
	if ($nperms != $operms) {
		printf "Permission mismatch, correcting: %05o -> %05o\n",
			$nperms, $operms
				if $verbose;
		chmod $operms, $fn;
	}
}

# ----------------------------------------------------------------------

sub check_dirsetupok ($)
{
# I don't know what should be done for the general case, given various
# directory trees with various group-writable set-ups, for various staff
# So we just stop root effing up
	return unless $> == 0;
	return if exists $ENV{'VIRCS_UNSAFE'};

	my $dirfull = $_[0];
	my ($d, $addslash);
# in theory, if is ./ then the directory has already been checked,
# so we just check the last bit
	if ($dirfull =~ m{^\./}) {
		$dirfull =~ s{^\./}{};
		$d = '.';
		$addslash = 0;
	} else {
		$d = '/';
		$addslash = -1;
	}

	my @dirsegments = split '/', $dirfull;
	while (1) {
		die "Bad directory setup: '${d}'\n" unless check_dirok $d;
		last if scalar @dirsegments == 0;
		++$addslash;
		$d .= (($addslash ? '/' : '') . shift @dirsegments);
	}
}

sub check_dirok ($)
{
	my $stat = File::stat::stat($_[0]);
	return 0 unless defined $stat;
	return 0 unless $stat->uid == 0;
	return 0 unless ($stat->mode & 022) == 0;
	return 1;
}