#!/bin/sh
exec ${PERL-perl} -wSx "$0" ${1+"$@"}
#!perl

# gnuedit --- gnuclient wrapper for remote or superuser editing

# Copyright (C) 2000, 2005 Noah S. Friedman

# Author: Noah Friedman <friedman@splode.com>
# Created: 2000-01-14

# $Id: gnuedit,v 1.8 2005/05/06 17:21:11 friedman Exp $

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, you can either send email to this
# program's maintainer or write to: The Free Software Foundation,
# Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

# Commentary:

# This program has been tested with the XEmacs 21 variant of the gnuserv
# package and the unbundled gnuserv 3.11 distribution for Emacs.

# Code:

use 5.003;

use Getopt::Long;
use Fcntl;
use POSIX qw(:errno_h);
use Symbol;
use strict;

my $verbose = (defined $ENV{GNUEDIT_VERBOSE}
               ? $ENV{GNUEDIT_VERBOSE}
               : -t fileno (*STDIN{IO}));
my $progname = $0;
$progname =~ s|.*/||;

sub errmsg (;@)
{
  print STDERR join (": ", $progname, @_), "\n";
  return undef;
}

sub verbose (;@)
{
  print $progname, ": ", join (" ",  @_), "\n" if ($verbose);
}

# Mandatory args: file, statinfo
# Optional args: actions
#
# actions is a bitmask: 1 = chmod
#                       2 = set atime/mtime
#                       4 = chown
sub set_file_stats ($$;$)
{
  my $file = shift;
  my $statinfo = shift;
  my $actions = shift || 1;

  # Set file permissions
  (chmod ($statinfo->[2], $file)
   || return errmsg (sprintf ("chmod(%o)", $statinfo->[2]), $file, $!))
    if ($actions & 1);

  # Set atime/mtime
  utime ($statinfo->[8], $statinfo->[9], $file) if ($actions & 2);
  # Set owner/group
  chown ($statinfo->[4], $statinfo->[5], $file) if ($actions & 4);

  return 1;
}

# Mandatory args: from, to
# Optional args: preserve, returnstatp, clobberp
sub copy_file ($$;$$)
{
  my ($from, $to, $preserve, $returnstatp, $clobberp) = @_;
  my $fh_from = gensym;
  my $fh_to   = gensym;

  verbose ("copying", $from, "->", $to);

  $clobberp = 1 unless defined $clobberp;
  my $oflag = $clobberp ? O_TRUNC : O_EXCL;

  sysopen ($fh_from, $from, O_RDONLY) || return errmsg ("open", $from, $!);
  if (!sysopen ($fh_to, $to, O_WRONLY | O_CREAT | $oflag, 0600))
    {
      close ($fh_from);
      errmsg ("open", $to, $!);
      return undef;
    };

  my $data;
  while (my $len = sysread ($fh_from, $data, 2**20)) # 1mb buffer
    {
      if (syswrite ($fh_to, $data, $len) != $len)
        {
          errmsg ("write", $to, $!);
          close ($fh_from);
          close ($fh_to);
          return undef;
        }
    }

  my @fromstat = stat ($fh_from);
  my @tostat   = stat ($fh_to) if ($returnstatp);
  close ($fh_from);
  close ($fh_to);

  return [ \@fromstat, \@tostat ] if ($returnstatp);

  set_file_stats ($to, \@fromstat, ($preserve ? 1|2|4 : 1));
  return 1;
}

sub copy_to_tmpfile ($$;$$$)
{
  my ($from, $to, $perm, $uid, $uidperm) = @_;

  my $filestats = copy_file ($from, $to, undef, 1);
  return undef unless (defined $filestats);

  chown ($uid, $filestats->[1]->[5], $to) || chmod ($uidperm & umask, $to);
  return 1;
}


# Mandatory args: file
# Optional args: vc
sub make_backup_file_name ($;$)
{
  my $file = shift;
  my $vc = lc (shift) || '';

  return $file . "~" if ($vc eq 'never' || $vc eq 'simple');

  my $dir = ".";
  my $base = $file;
  if (index ($file, "/") >= $[)
    {
      $base =~ s|.*/||o;
      $dir = $file;
      $dir =~ s|/[^/]*$||o;
    }

  my $dfh = gensym;
  opendir ($dfh, $dir) || return errmsg ("opendir", $dir, "$!");
  my $m = eval 'sub { m/^' . quotemeta ($base) . '\.~(\d+)~$/o && $1 }';
  my $h = [sort { -($a <=> $b) } grep { $_ = &$m } readdir $dfh]->[0];
  closedir ($dfh);

  return join ("", $file, ".~", $h + 1, "~") if (defined $h);
  join ("", $file, ($vc eq 'numbered' || $vc eq 't' ? ".~1~" : "~"));
}

# Mandatory arg: from
# Optional arg: to
sub backup_file ($;$)
{
  my ($from, $to) = @_;
  my $fromstat = xstat ($from);

  $to = make_backup_file_name ($from, $ENV{VERSION_CONTROL})
    unless defined $to;

  # Backup by copying if file has multiple hard links
  return copy_file ($from, $to, 1) if ($fromstat->[3] > 1);

  # Backup by rename; new version will be in new file.
  verbose ("renaming", $from, "->", $to);
  rename ($from, $to) || errmsg ("rename", join (" ", $from, "->", $to), $!);
}


sub dereference_links ($)
{
  my $file = shift;
  my @p = split (m|/|, $file);
  my $link_count = 0;
  for (my $j = 0; $j <= $#p; $j++)
    {
      my $k = join ("/", @p[0 .. $j]);
      my $orig_component = $k;
      while (my $l = readlink ($k))
        {
          $k = $l;
          # Simple way of detecting symlink loops (it unfortunately causes
          # the system to give up when there are simply too many levels,
          # even if resolution would eventually occur).  This parameter is
          # adjustable, of course.  Most unix kernels allow a depth of 8.
          # (Linux 2.2.12 seems to allow a depth of only 4!)
          return errmsg ($file, "Too many levels of symbolic links")
            if ($link_count++ == 64);
        }
      next if ($k eq $orig_component);
      if (substr ($k, 0, 1) eq "/")
        {
          # Absolute link.  Trash $p[0]-$p[$j+1] and replace with readlinked
          # path components.  Set $j to -1 so that next iteration of loop
          # will check array @p from start.
          splice (@p, 0, $j + 1, split (m|/|, $k));
          $j = -1;
        }
      else
        {
          # Insert partial (relative) path component into array in place of
          # current element $p[$j]
          splice (@p, $j, 1, split (m|/|, $k));
          $j--;
        }
    }

  return expand_file_name (join ("/", @p));
}

# Mandatory args: file
# Optional args: ignore_if_nonexist
sub xunlink ($;$)
{
  my $file = shift;
  my $ignore_if_nonexist = shift;

  return undef if (defined $ignore_if_nonexist
                   && $ignore_if_nonexist
                   && ! -e $file);

  verbose ("unlinking", $file);
  unlink ($file) || return errmsg ("unlink", $file, $!);
}

# Mandatory args: file
# Optional args: noerrp
sub xstat ($;$)
{
  my $file = shift;
  my $noerrp = shift || 0;

  my @statinfo = stat $file;
  return \@statinfo if @statinfo;
  return undef if ($noerrp);
  errmsg ("stat", (ref $file ? fileno ($file) : $file), $!);
}

sub spawn (@)
{
  if (fork == 0)
    {
      $SIG{__WARN__} = sub { 0; };
      exec (@_) || errmsg ("exec", $_[0], $!);
      exit (1);
    }
  wait;
  return $? == 0;
}

# Mandatory args: basename
# Optional args: default-directory
#
# Convert basename to absolute, and canonicalize it.  Second arg
# default-directory is directory to start with if basename is relative
# (does not start with slash); if default-directory is undefined, the
# current working directory is used.  File name components that are `.' are
# removed, and so are file name components followed by `..', along with the
# `..' itself; note that these simplifications are done without checking
# that the file name actually exists in the file system.
sub expand_file_name
{
  local $_ = shift;
  $_ = join ('/', (shift || $ENV{PWD} || getcwd ()), $_) unless m|^/|o;

  # Some of these substitutions must be done in loops to handle overlapping
  # `/' characters in adjacent patterns.
  s||/|         while m|/\./|o;             # collapse /./ -> /
  s|//+|/|go;                               # collapse // -> /
  s||/|         while m=/[^/]+/\.\.(/|$)=o; # collapse /foo/bar/../ => /foo/
  s|/\.?$||go;
  # Eliminate leading `..'.
  # It may be harmful to do it if the filesystem interprets `/..' as
  # something not equivalent to `/'.
  #s||/|         while m|^/\.\./|o;
  return $_;
}

# Return the directory name where file resides.
sub file_directory ($)
{
  # modify a copy of the argument.  Editing $_[0] directly would affect the
  # original value.
  my $file = shift;
  return "." unless (index ($file, "/") >= $[);
  $file =~ s|/[^/]*$||o;
  return $file;
}

# This function assumes process is running as root at can change uids
sub files_writable_by_uid ($@)
{
  my $uid = shift;

  if (fork == 0)
    {
      # Set real and effective uid to $uid
      $< = $> = $uid;
      my $i = 0;
      foreach (@_) { $i++ if (-w) };
      exit ($i);
    }
  wait;
  return $? >= 255 ? $? - 255 : $?;
}

sub gnuedit_make_evalform ($$;$)
{
  my ($filename, $realfilename, $remoteprefix) = @_;

  (my $basename     = $filename)     =~ s|.*/||o;
  (my $realbasename = $realfilename) =~ s|.*/||o;
  my $dirname = file_directory (expand_file_name ($filename));

  my $fn = "gnuedit-frob";
  my $fmt = "(defun %s ()
               (cond ((equal buffer-file-name \"%s%s\")
                      (setq default-directory \"%s%s/\")
                      (rename-buffer \"%s (%s)\" t)))
               (remove-hook \'find-file-hooks \'%s)
               (fmakunbound \'%s))
             (add-hook \'find-file-hooks \'%s)";
  $fmt =~ s/\n\s+/ /go;

  sprintf ($fmt, $fn,
           $remoteprefix || "", $realfilename,
           $remoteprefix || "", $dirname,
           $basename, $realbasename,
           $fn,
           $fn,
           $fn);
}


sub gethostname ()
{
  my $host = $ENV{HOSTNAME};

  return $host if (defined $host);
  $host = `hostname`;
  $host = `uname -n` if ($host eq "");
  chop $host;
  return $host;
}

sub hosts_match ($$)
{
  my ($h1, $h2) = @_;

  my ($h1name, $h1alias, $h1addrtype, $h1l, @h1addrs) = gethostbyname ($h1);
  my ($h2name, $h2alias, $h2addrtype, $h2l, @h2addrs) = gethostbyname ($h2);
  my @h1names = map { scalar gethostbyaddr ($_, $h1addrtype) } @h1addrs;
  my @h2names = map { scalar gethostbyaddr ($_, $h2addrtype) } @h2addrs;

  foreach $h1 (@h1names)
    {
      next unless (defined $h1 && $h1 ne "");
      foreach $h2 (@h2names)
        {
          next unless (defined $h2 && $h2 ne "");
          return 1 if ($h1 eq $h2);
        }
    }
  return 0;
}


sub gnuedit ($$$$$$$)
{
  my ($uid, $username, $host, $port, $thishost, $remote_type, $files) = @_;

  my $gnuclient = $ENV{GNUCLIENT_PROGRAM} || "gnuclient";
  my @gnuclient_options;
  my $remoteprefix;

  if (!($uid == $< && $uid == $>) || defined $thishost)
    {
      @gnuclient_options = ("-h", $host, "-p", $port);
      if (defined $thishost)
        {
          $remoteprefix = "/$username\@$thishost:";
          push @gnuclient_options, "-r", $remoteprefix;
        }
    }

  if ($uid == $< && $uid == $>)
    {
      exec ($gnuclient, @gnuclient_options, @$files)
        || errmsg ("exec", $gnuclient, $!);
      exit (1);
    }

  my $exit_status = 0;
  my $tmpdir = $ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp";
  my $tmpfile = "$tmpdir/gnuedit$$";

  # If we are running as another user; edit file-by-file, checking whether
  # we can edit directly or need to edit a temporary file.
  for my $file (@$files)
    {
      my $realfile = (-l $file ? dereference_links ($file) : $file);
      # If file is a symlink we want to make changes and backups to the
      # real file, not the symlink.
      verbose ("following symbolic link:", $file, "->", $realfile)
        if ($realfile ne $file);

      my $filestat = xstat ($realfile, 1);

      # If file does not exist, use direct editing so user will be notified
      # that the file is new (as well as being told if the parent directory
      # is not writable); the file name might have been a typo.
      if (!defined $filestat
          || ($filestat->[4] == $uid
              && files_writable_by_uid ($uid, file_directory ($realfile))))
        {
          # Pass realfile name to emacs if file would not be readable due
          # to too many levels of symbolic links.
          my $usefile = (!stat ($file) && $! == ELOOP) ? $realfile : $file;
          $exit_status++
            unless (spawn ($gnuclient, @gnuclient_options, $usefile));
          next;
        }

      xunlink ($tmpfile, 1);
      if (!copy_to_tmpfile ($realfile, $tmpfile, 0600, $uid, 0666))
        {
          $exit_status++;
          next;
        }
      my $tmpfilestat = xstat ($tmpfile);

      if (!spawn ($gnuclient, @gnuclient_options, "-eval",
                  gnuedit_make_evalform ($file, $tmpfile, $remoteprefix),
                  $tmpfile))
        {
          errmsg ($gnuclient, "exited abnormally; aborting changes")
            if ($? != 0);
          xunlink ($tmpfile);
          $exit_status++;
          next;
        }

      my $newstat = xstat ($tmpfile);
      if (!defined $newstat)
        {
          xunlink ($tmpfile) unless ($!+0 == ENOENT);
          $exit_status++;
          next;
        }

      if ($newstat->[7] == $tmpfilestat->[7]      # size
          && $newstat->[9] == $tmpfilestat->[9])  # mtime
        {
          verbose ("no modifications made to", $tmpfile);
          xunlink ($tmpfile);
          next;
        }

      my $backfile = make_backup_file_name ($realfile, $ENV{VERSION_CONTROL});
      backup_file ($realfile, $backfile)
        && copy_file ($tmpfile, $realfile)
        && set_file_stats ($realfile, $filestat, 1|4)
        && xunlink ($tmpfile);
    }

  exit ($exit_status);
}

sub main
{
  my $gnuserv_port_base = 21490;
  my $username;
  my $gnuport;
  my $gnuhost = $ENV{GNU_HOST} || "localhost";
  my $myhostname;
  my $thishost;
  my $remote_type = "ftp";

  Getopt::Long::config (qw(bundling autoabbrev));
  my $succ = GetOptions
    ("h|host=s",        \$gnuhost,
     "m|my-hostname=s", \$myhostname,
     "r|remote-type=s", \$remote_type,
     "p|port=i",        \$gnuport,
     "u|username=s",    \$username,
     "q|quiet",         sub { $verbose = 0 },
     "v|verbose",       \$verbose);
  exit (1) unless $succ;

  $username = $ENV{SUDO_USER} || $ENV{LOGNAME} || $ENV{USER} || getpwuid ($<)
    unless (defined $username);
  my $uid = getpwnam ($username);
  $gnuport = $ENV{GNU_PORT} || $gnuserv_port_base + $uid
    unless (defined $gnuport);

  if ($gnuhost !~ /^localhost(?:|\..*)$/o)
    {
      my $hostname = $myhostname || gethostname ();
      $thishost = $hostname unless (hosts_match ($gnuhost, $hostname));
    }

  gnuedit ($uid, $username, $gnuhost, $gnuport, $thishost, $remote_type, \@ARGV);
}

main ();

# local variables:
# mode: perl
# eval: (auto-fill-mode 1)
# end:

# gnuedit ends here