#!/usr/bin/perl -w
#
# rcsedit -- edit a file using RCS control
#
# Copyright 1996, 1997, 2001, 2006 LavaNet, Inc.
# This program is distributed under the terms of the GNU
# General Public License, Version 2 (June 1991).
#
# http://www.lava.net/rcsedit/
# Comments, bugs, suggestions to: rcsedit@lava.net
#
# rcsedit uses rcs to check out a file, invoke an editor, and check the
# file back in when done.  It assumes the file is already under RCS control
# and is editable by the user.
#
# history
#
# 1.00     96.07.16
#          initial release.  
# 1.1.0    97.10.03
#          Now handles case where file has never been checked in
# 1.2      2001.01.28
#          Preserve the owner and group on the working file, something
#          RCS doesn't do by itself (jlc).
# 1.3      Preserve original username of person invoking rcsedit (useful
#          if rcsedit is being run via sudo, etc).  Records this username
#          in RCS log.  General style cleanup. (bkf)

use strict;

require 5.005_03;
use Cwd             qw(getcwd);
use English         qw(-no_match_vars);
use File::Basename  qw(basename dirname);
use Getopt::Long    qw(GetOptions);


# We'd use Fcntl qw(:mode) here, but they're not available in 5.005_03.
# This means this is slightly unportable.
use constant S_ISUID => 04000;
use constant S_ISGID => 02000;
use constant S_IWUSR =>  0200;
use constant S_IWGRP =>  0020;
use constant S_IWOTH =>  0002;


# preliminary setup
#
$OUTPUT_AUTOFLUSH  =  1;      # unbuffer output


# paths - set appropriately
#
# These are left as relative paths so that the PATH variable is used,
# but set to (OS-dependent) absolute paths for better security.
#
use vars qw($LS $RCS_CO $RCS_CI $RCS_LOG $RCS_DIFF $DEFAULT_EDITOR);
$LS                = 'ls';
$RCS_CO            = 'co';
$RCS_CI            = 'ci';
$RCS_LOG           = 'rlog';
$RCS_DIFF          = 'rcsdiff';
$DEFAULT_EDITOR    = 'vi';
# TODO at least test for existence/executability of these files


# other definitions
#
# TODO allow setting of all options used for ci and co (such as -d and -M)
use vars qw($VERSION $RCS_DIR $RCS_TZ $LS_OPTS $PICO_KLUDGE);
$VERSION           = 1.3;
$RCS_DIR           = 'RCS';   # default
$RCS_TZ            = '-zLT';  # local time
$LS_OPTS           = '-la';   # long listing, include entries beginning w/ '.'
$PICO_KLUDGE       = 1;       # set to 1 to disable word wrap if pico is editor

use vars qw($prog);
$prog              = basename $PROGRAM_NAME;

# TODO this doesn't seem to work as advertised for jlc, but I don't have
# access to an environment suitable to debug this.  I'm afraid he'll have
# to figure it out. [bkf]
#
# TODO the original intent was to put a notation that rcsedit was called
# via sudo, but unfortunately this can't be stored in the author field we
# found out.  the mystery, though, is that SUDO_USER says root on some
# systems and the username on others despite the setting of set_logname in
# the sudoers file.  so the following still needs work.
#
# maybe just let rcs figure it out from the LOGNAME variable alone?
# rcs uses LOGNAME if set (unless it thinks it's unsecure for some
# reason, in which case it does other stuff). - jlc
#
if ($ENV{SUDO_USER})
{
    $ENV{LOGNAME} = $ENV{SUDO_USER};
}

# usage info
#
use vars qw($USAGE);
$USAGE             = <<"END_USAGE";
Usage: $prog [-help] [-version] [-debug] [file1 file2...]

\u$prog will use RCS to check out a file, invoke an editor, then check the
file back in when done.  Multiple files may be specified.  If no files are
specified, $prog will prompt for one.  RCS co is performed with "-l" option.
RCS ci is performed with "-u" option.

Options:
    
  -help      Usage information.
    
  -version   The version of this software, what else?

  -debug     Enable debugging output.
    
Options may also be specified with single character abbreviations.
[-h] [-v] [-d]
END_USAGE


# process options
#
use vars qw($help $version $debug);
if (!GetOptions
    (
        'help'    => \$help,
        'version' => \$version,
        'debug'   => \$debug,
    ))
{
    print $USAGE;
    exit;
}

if ($help)
{
    print $USAGE;
    exit;
}

if ($version)
{
    print "$prog: version $VERSION\n";
    exit;
}


# set editor
#
# This prefers the better-named EDITOR over VISUAL.  For comparison,
# several old Unix programs that call an editor work differently:
# crontab -e   VISUAL
# less         VISUAL
# chsh         EDITOR
# edquota      EDITOR
#
use vars qw($editor);
$editor = $ENV{'EDITOR'} || $ENV{'VISUAL'} || $DEFAULT_EDITOR;

if ($editor eq 'pico' && $PICO_KLUDGE)
{
    $editor = 'pico -w';
}

if ($debug)
{
    print "DEBUG \$editor: $editor\n";
}


#
# main
#

if (! @ARGV)
{
    push @ARGV, prompt("file to edit: ");
}

FILE:
foreach my $file_arg (@ARGV)
{
    my $file      = basename $file_arg;
    my $file_path = dirname  $file_arg;
    my $retval;

    if (! -e $file_arg)
    {
        print "$file_arg doesn't exist!  Skipping...\n";
        next FILE;
    }

    if ($debug)
    {
        print "DEBUG \$file_arg:  $file_arg\n";
        print "DEBUG \$file_path: $file_path\n";
        print "DEBUG \$file:      $file\n";
    }

    my $cwd = getcwd;
    if ($debug)
    {
        print "DEBUG \$cwd:       $cwd\n";
        print "DEBUG chdir (\"$file_path\")\n";
    }
    chdir ($file_path);

    $retval = do_system($RCS_DIFF, $RCS_TZ, $file);

    if ($retval == 1)  # There were differences
    {
        die "\nThere are differences that haven't been checked in.  Fix them and retry.\n\n";
    }

    if ($retval == 2)  # Some kind of error (like RCS file not found)
    {
        my $response = prompt("\nI believe this file has never been checked in (but can't be sure)\nWould you like to check it in (y/N)? ");

        if (substr(lc($response), 0, 1) eq "y")
        {
            $retval = do_system($RCS_CI, qw(-u -d -M), $RCS_TZ, $file);
            if ($retval != 0)
            {
                die "Can't find RCS file!\n";
            }

            # Set the attributes on the RCS file to match those on the
            # the working file (something RCS does not do).
            #
            my $RCS_file = `$RCS_LOG -R $file`;

            if (($CHILD_ERROR >> 8) != 0)
            {
                die "Can't find RCS file!\n";
            }

            chomp $RCS_file;

            my ($perm, $uid, $gid) = (stat $file)[2,4,5];

            chown $uid, $gid, $RCS_file;
            chmod $perm, $RCS_file;
        }
        else
        {
            die "Aborting...\n";
        }
    } # rcs error


    do_rcs($RCS_CO, $RCS_TZ, qw(-l -M), $file)
        or die "\nCheckout of file $file failed, cannot continue.  Fix problem and retry.\n\n";

    # Run the editor, but preserve file attributes before the editor is run.
    # This is because both vi and pico under BSD/OS (and perhaps others) will
    # remove any setuid or setgid after the file is saved.
    {
        my ($perm, $uid, $gid) = (stat $file)[2,4,5];
        my $retval;

        $retval = do_system($editor, $file);
        if ($retval != 0)
        {
            die "editor returned non-zero exit code: $retval\n";
        }

        chown $uid, $gid, $file;
        chmod $perm, $file;
    }


    do_rcs($RCS_CI, $RCS_TZ, qw(-u -d -M), $file)
        or die "Couldn't check-in new revision.\n";

    if ($debug)
    {
        print "DEBUG chdir (\"$cwd\")\n";
    }
    chdir $cwd;  # restore working directory
} # FILE

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

sub prompt
{
    my ($prompt_text) = @_;

    print "$prompt_text";

    my $response = <STDIN>;

    chomp $response;

    return $response;
}

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

sub issetuid
{
    my ($perm) = @_;

    return ($perm & S_ISUID);
}

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

sub issetgid
{
    my ($perm) = @_;

    return ($perm & S_ISGID);
}

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

sub do_rcs
{
    my (@args) = @_;
    my $file;
    my ($new_perm, $new_rcs_perm, $preserved_uid, $preserved_gid, $RCS_file);
    my $retval;

    # The file is the last argument in the @args array.
    $file = pop @args;
    if ($debug)
    {
        print "DEBUG do_rcs: file = $file\n";
    }

    # Get the name of the RCS file.
    #
    $RCS_file = `$RCS_LOG -R $file`;

    if (($CHILD_ERROR >> 8) != 0)
    {
        return 0;
    }

    chomp $RCS_file;

    # Save the owner, group, and permissions from the working file so that we
    # can attempt to restore them later.
    #
    my ($perm, $uid, $gid)             = (stat $file    )[2,4,5];
    my ($rcs_perm, $rcs_uid, $rcs_gid) = (stat $RCS_file)[2,4,5];

    # Check that the permissions on the RCS match the permissions on the
    # working file (sans write bits), and that the user and group match.  If
    # not, have the user correct the situation manually.
    #
    # The reason for this is that when checking-out a file, RCS retains the
    # permissions based solely on the RCS file.  Since we want to preserve
    # the permissions on the working file, we need to make sure the two match.
    #
    if ($rcs_perm != ($perm & ~(S_IWUSR | S_IWGRP | S_IWOTH)))
    {
        print "\
There is some mismatch in permissions, owner, or group between the
RCS file and the working file.  Fix that first, wipe up, and come
on back.\n\n";
        do_system($LS, $LS_OPTS, $file, $RCS_file);
        print "\n";

        return 0;
    }

    # Do the actual RCS command.
    #
    if ($debug)
    {
        print "DEBUG do_rcs(): before RCS command:\n";
        do_system($LS, $LS_OPTS, $file, $RCS_file);
    }

    $retval = do_system(@args, $file);
    if ($retval != 0)
    {
        if ($debug)
        {
            print "DEBUG do_rcs(): error executing RCS command\n";
        }
        return 0;
    }

    if ($debug)
    {
        print "DEBUG do_rcs(): after RCS command:\n";
        do_system($LS, $LS_OPTS, $file, $RCS_file);
    }

    # Restore original user and group of working file and RCS file.
    #
    # NOTE: On some systems (mostly POSIX), doing a chown clears the setuid and
    # setgid bits even if root, so we need to save the original permissions
    # before doing this.
    #
    $perm          = (stat $file    )[2];
    $rcs_perm      = (stat $RCS_file)[2];
    $preserved_uid = chown $uid,   -1, $file;
    $preserved_gid = chown   -1, $gid, $file;

    chown $uid, -1, $RCS_file;  # make RCS file match working file
    chown -1, $gid, $RCS_file;

    if ($debug)
    {
        print "DEBUG do_rcs(): after changing owner:\n";
        do_system($LS, $LS_OPTS, $file, $RCS_file);
    }

    # Hack on setuid and setgid bits, if necessary:
    # * If setuid is set, and owner cannot be preserved, clear setuid bit.
    # * If setgid is set, and group cannot be preserved, clear setgid bit.
    # * If setuid and setgid is set, and either owner or group
    #   cannot be preserved, clear both the setuid and setgid bits.
    #
    # This duplicates BSD/OS's security behavior when doing cp -p.
    #
    $new_perm     = $perm;
    $new_rcs_perm = $rcs_perm;

    if (issetuid($perm))
    {
        if (issetgid($perm))
        {
            if (!$preserved_uid || !$preserved_gid)
            {
                $new_perm     &= ~S_ISUID;
                $new_perm     &= ~S_ISGID;
                $new_rcs_perm &= ~S_ISUID;
                $new_rcs_perm &= ~S_ISGID;
            }
        }
        elsif (!$preserved_uid)
        {
            $new_perm     &= ~S_ISUID;
            $new_rcs_perm &= ~S_ISUID;
        }
    }
    elsif (issetgid($perm) && !$preserved_gid)
    {
        $new_perm     &= ~S_ISGID;
        $new_rcs_perm &= ~S_ISGID;
    }

    chmod $new_perm, $file;
    chmod $new_rcs_perm, $RCS_file;

    if ($debug)
    {
        print "DEBUG do_rcs(): after changing permissions:\n";
        do_system($LS, $LS_OPTS, $file, $RCS_file);
    }

    # Print out results of above.
    #
    if (!$preserved_uid)
    {
        print "\nWarning, couldn't preserve user!  (orig uid = $uid)\n\n";
    }
    if (!$preserved_gid)
    {
        print "\nWarning, couldn't preserve group!  (orig gid = $gid)\n\n";
    }
    if (issetuid($perm ^ $new_perm))
    {
        print "\nWarning, not preserving setuid!\n\n";
    }
    if (issetgid($perm ^ $new_perm))
    {
        print "\nWarning, not preserving setgid!\n\n";
    }

    return 1;
}

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

sub do_system
{
    if ($debug)
    {
        print "DEBUG system @_\n";
    }
    system @_;
    if ($CHILD_ERROR == -1)
    {
        die "failed to execute: $ERRNO\n";
    }
    elsif (($CHILD_ERROR >> 8) == 255)
    {
        # On 5.005_03, system never returns -1 if the child couldn't
        # execute the program -- it returns 255 instead (and doesn't
        # set the errno the child got).  Catch that here (which means
        # a program that actually returns 255 will be caught here as well
        # unfortunately).
        die "failed to execute\n";
    }
    elsif ($CHILD_ERROR & 127)
    {
        die sprintf("child died with signal %d, %s coredump\n",
            ($CHILD_ERROR & 127),
            ($CHILD_ERROR & 128) ? 'with' : 'without');
    }
    # Return the value the child exited with.
    return $CHILD_ERROR >> 8;
}