--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/filelock.c	Mon Aug 13 11:28:15 2007 +0200
@@ -0,0 +1,476 @@
+/* Copyright (C) 1985, 86, 87, 93, 94, 96 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Synced with FSF 20.2 */
+
+#include <config.h>
+#include "lisp.h"
+
+#include "buffer.h"
+#include <paths.h>
+
+#include "sysfile.h"
+#include "sysdir.h"
+#include "syspwd.h"
+#include "syssignal.h" /* for kill */
+
+Lisp_Object Qask_user_about_supersession_threat;
+Lisp_Object Qask_user_about_lock;
+
+#ifdef CLASH_DETECTION
+  
+/* The strategy: to lock a file FN, create a symlink .#FN in FN's
+   directory, with link data `user@host.pid'.  This avoids a single
+   mount (== failure) point for lock files.
+
+   When the host in the lock data is the current host, we can check if
+   the pid is valid with kill.
+   
+   Otherwise, we could look at a separate file that maps hostnames to
+   reboot times to see if the remote pid can possibly be valid, since we
+   don't want Emacs to have to communicate via pipes or sockets or
+   whatever to other processes, either locally or remotely; rms says
+   that's too unreliable.  Hence the separate file, which could
+   theoretically be updated by daemons running separately -- but this
+   whole idea is unimplemented; in practice, at least in our
+   environment, it seems such stale locks arise fairly infrequently, and
+   Emacs' standard methods of dealing with clashes suffice.
+
+   We use symlinks instead of normal files because (1) they can be
+   stored more efficiently on the filesystem, since the kernel knows
+   they will be small, and (2) all the info about the lock can be read
+   in a single system call (readlink).  Although we could use regular
+   files to be useful on old systems lacking symlinks, nowadays
+   virtually all such systems are probably single-user anyway, so it
+   didn't seem worth the complication.
+
+   Similarly, we don't worry about a possible 14-character limit on
+   file names, because those are all the same systems that don't have
+   symlinks.
+   
+   This is compatible with the locking scheme used by Interleaf (which
+   has contributed this implementation for Emacs), and was designed by
+   Ethan Jacobson, Kimbo Mundy, and others.
+   
+   --karl@cs.umb.edu/karl@hq.ileaf.com.  */
+
+
+/* Here is the structure that stores information about a lock.  */
+
+typedef struct
+{
+  char *user;
+  char *host;
+  unsigned long pid;
+} lock_info_type;
+
+/* When we read the info back, we might need this much more,
+   enough for decimal representation plus null.  */
+#define LOCK_PID_MAX (4 * sizeof (unsigned long))
+
+/* Free the two dynamically-allocated pieces in PTR.  */
+#define FREE_LOCK_INFO(i) do { xfree ((i).user); xfree ((i).host); } while (0)
+
+/* Write the name of the lock file for FN into LFNAME.  Length will be
+   that of FN plus two more for the leading `.#' plus one for the null.  */
+#define MAKE_LOCK_NAME(lock, file) \
+  (lock = (char *) alloca (XSTRING_LENGTH(file) + 2 + 1), \
+   fill_in_lock_file_name (lock, (file)))
+
+static void
+fill_in_lock_file_name (lockfile, fn)
+     register char *lockfile;
+     register Lisp_Object fn;
+{
+  register char *p;
+
+  strcpy (lockfile, XSTRING_DATA(fn));
+
+  /* Shift the nondirectory part of the file name (including the null)
+     right two characters.  Here is one of the places where we'd have to
+     do something to support 14-character-max file names.  */
+  for (p = lockfile + strlen (lockfile); p != lockfile && *p != '/'; p--)
+    p[2] = *p;
+
+  /* Insert the `.#'.  */
+  p[1] = '.';
+  p[2] = '#';
+}
+
+/* Lock the lock file named LFNAME.
+   If FORCE is nonzero, we do so even if it is already locked.
+   Return 1 if successful, 0 if not.  */
+
+static int
+lock_file_1 (char *lfname,int force)
+{
+  register int err;
+  char *user_name;
+  char *host_name;
+  char *lock_info_str;
+
+  if (STRINGP (Fuser_login_name (Qnil)))
+    user_name = (char *) XSTRING_DATA (Fuser_login_name (Qnil));
+  else
+    user_name = "";
+  if (STRINGP (Fsystem_name ()))
+    host_name = (char *) XSTRING_DATA (Fsystem_name ());
+  else
+    host_name = "";
+  lock_info_str = (char *)alloca (strlen (user_name) + strlen (host_name)
+			  + LOCK_PID_MAX + 5);
+
+  sprintf (lock_info_str, "%s@%s.%lu", user_name, host_name,
+           (unsigned long) getpid ());
+
+  err = symlink (lock_info_str, lfname);
+  if (errno == EEXIST && force)
+    {
+      unlink (lfname);
+      err = symlink (lock_info_str, lfname);
+    }
+
+  return err == 0;
+}
+
+/* Return 0 if nobody owns the lock file LFNAME or the lock is obsolete,
+   1 if another process owns it (and set OWNER (if non-null) to info),
+   2 if the current process owns it,
+   or -1 if something is wrong with the locking mechanism.  */
+
+static int
+current_lock_owner (lock_info_type *owner, char *lfname)
+{
+  int o, p, len, ret;
+  int local_owner = 0;
+  char *at, *dot;
+  char *lfinfo = 0;
+  int bufsize = 50;
+  /* Read arbitrarily-long contents of symlink.  Similar code in
+     file-symlink-p in fileio.c.  */
+  do
+    {
+      bufsize *= 2;
+      lfinfo = (char *) xrealloc (lfinfo, bufsize);
+      len = readlink (lfname, lfinfo, bufsize);
+    }
+  while (len >= bufsize);
+  
+  /* If nonexistent lock file, all is well; otherwise, got strange error. */
+  if (len == -1)
+    {
+      xfree (lfinfo);
+      return errno == ENOENT ? 0 : -1;
+    }
+
+  /* Link info exists, so `len' is its length.  Null terminate.  */
+  lfinfo[len] = 0;
+  
+  /* Even if the caller doesn't want the owner info, we still have to
+     read it to determine return value, so allocate it.  */
+  if (!owner)
+    {
+      owner = (lock_info_type *) alloca (sizeof (lock_info_type));
+      local_owner = 1;
+    }
+  
+  /* Parse USER@HOST.PID.  If can't parse, return -1.  */
+  /* The USER is everything before the first @.  */
+  at = strchr (lfinfo, '@');
+  dot = strrchr (lfinfo, '.');
+  if (!at || !dot) {
+    xfree (lfinfo);
+    return -1;
+  }
+  len = at - lfinfo;
+  owner->user = (char *) xmalloc (len + 1);
+  strncpy (owner->user, lfinfo, len);
+  owner->user[len] = 0;
+  
+  /* The PID is everything after the last `.'.  */
+  owner->pid = atoi (dot + 1);
+
+  /* The host is everything in between.  */
+  len = dot - at - 1;
+  owner->host = (char *) xmalloc (len + 1);
+  strncpy (owner->host, at + 1, len);
+  owner->host[len] = 0;
+
+  /* We're done looking at the link info.  */
+  xfree (lfinfo);
+  
+  /* On current host?  */
+  if (STRINGP (Fsystem_name ()) 
+      && strcmp (owner->host, XSTRING_DATA(Fsystem_name ())) == 0)
+    {
+      if (owner->pid == getpid ())
+        ret = 2; /* We own it.  */
+      else if (owner->pid > 0
+               && (kill (owner->pid, 0) >= 0 || errno == EPERM))
+        ret = 1; /* An existing process on this machine owns it.  */
+      /* The owner process is dead or has a strange pid (<=0), so try to
+         zap the lockfile.  */
+      else if (unlink (lfname) < 0)
+        ret = -1;
+      else
+	ret = 0;
+    }
+  else
+    { /* If we wanted to support the check for stale locks on remote machines,
+         here's where we'd do it.  */
+      ret = 1;
+    }
+  
+  /* Avoid garbage.  */
+  if (local_owner || ret <= 0)
+    {
+      FREE_LOCK_INFO (*owner);
+    }
+  return ret;
+}
+
+/* Lock the lock named LFNAME if possible.
+   Return 0 in that case.
+   Return positive if some other process owns the lock, and info about
+     that process in CLASHER.
+   Return -1 if cannot lock for any other reason.  */
+
+static int
+lock_if_free (lock_info_type *clasher, char *lfname)
+{
+  if (lock_file_1 (lfname, 0) == 0)
+    {
+      int locker;
+
+      if (errno != EEXIST)
+	return -1;
+      
+      locker = current_lock_owner (clasher, lfname);
+      if (locker == 2)
+        {
+          FREE_LOCK_INFO (*clasher);
+          return 0;   /* We ourselves locked it.  */
+        }
+      else if (locker == 1)
+        return 1;  /* Someone else has it.  */
+
+      return -1; /* Something's wrong.  */
+    }
+  return 0;
+}
+
+/* lock_file locks file FN,
+   meaning it serves notice on the world that you intend to edit that file.
+   This should be done only when about to modify a file-visiting
+   buffer previously unmodified.
+   Do not (normally) call this for a buffer already modified,
+   as either the file is already locked, or the user has already
+   decided to go ahead without locking.
+
+   When this returns, either the lock is locked for us,
+   or the user has said to go ahead without locking.
+
+   If the file is locked by someone else, this calls
+   ask-user-about-lock (a Lisp function) with two arguments,
+   the file name and info about the user who did the locking.
+   This function can signal an error, or return t meaning
+   take away the lock, or return nil meaning ignore the lock.  */
+
+void
+lock_file (Lisp_Object fn)
+{
+  /* This function can GC. */
+  /* dmoore - and can destroy current_buffer and all sorts of other
+     mean nasty things with pointy teeth.  If you call this make sure
+     you protect things right. */
+  /* Somebody updated the code in this function and removed the previous 
+     comment.  -slb */
+
+  register Lisp_Object attack, orig_fn;
+  register char *lfname, *locker;
+  lock_info_type lock_info;
+  struct gcpro gcpro1,gcpro2;
+  Lisp_Object subject_buf;
+
+  GCPRO2 (fn, subject_buf);
+  orig_fn = fn;
+  fn = Fexpand_file_name (fn, Qnil);
+
+  /* Create the name of the lock-file for file fn */
+  MAKE_LOCK_NAME (lfname, fn);
+
+  /* See if this file is visited and has changed on disk since it was
+     visited.  */
+  {
+    subject_buf = get_truename_buffer (orig_fn);
+    if (!NILP (subject_buf)
+	&& NILP (Fverify_visited_file_modtime (subject_buf))
+	&& !NILP (Ffile_exists_p (fn)))
+      call1_in_buffer (XBUFFER(subject_buf),
+			Qask_user_about_supersession_threat, fn);
+  }
+
+  /* Try to lock the lock. */
+  if (lock_if_free (&lock_info, lfname) <= 0)
+    /* Return now if we have locked it, or if lock creation failed */
+    goto done;
+
+  /* Else consider breaking the lock */
+  locker = (char *) alloca (strlen (lock_info.user) + strlen (lock_info.host)
+			    + LOCK_PID_MAX + 9);
+  sprintf (locker, "%s@%s (pid %lu)", lock_info.user, lock_info.host,
+           lock_info.pid);
+  FREE_LOCK_INFO (lock_info);
+  
+  attack = call2_in_buffer (BUFFERP (subject_buf) ? XBUFFER (subject_buf) :
+			    current_buffer, Qask_user_about_lock , fn,
+			    build_string (locker));
+  if (!NILP (attack))
+    /* User says take the lock */
+    {
+      lock_file_1 (lfname, 1);
+      goto done;
+    }
+  /* User says ignore the lock */
+ done:
+  UNGCPRO;
+}
+
+void
+unlock_file (Lisp_Object fn)
+{
+  register char *lfname;
+
+  fn = Fexpand_file_name (fn, Qnil);
+
+  MAKE_LOCK_NAME (lfname, fn);
+
+  if (current_lock_owner (0, lfname) == 2)
+    unlink (lfname);
+}
+
+void
+unlock_all_files ()
+{
+  register Lisp_Object tail;
+  register struct buffer *b;
+
+  for (tail = Vbuffer_alist; GC_CONSP (tail); tail = XCDR (tail))
+    {
+      b = XBUFFER (XCDR (XCAR (tail)));
+      if (STRINGP (b->file_truename) && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b))
+	unlock_file (b->file_truename);
+    }
+}
+
+DEFUN ("lock-buffer", Flock_buffer,   0, 1, 0, /*
+  Lock FILE, if current buffer is modified.\n\
+FILE defaults to current buffer's visited file,\n\
+or else nothing is done if current buffer isn't visiting a file.
+*/
+  (file))
+{
+  if (NILP (file))
+    file = current_buffer->file_truename;
+  CHECK_STRING (file);
+  if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
+      && !NILP (file))
+    lock_file (file);
+  return Qnil;
+}
+
+DEFUN ("unlock-buffer", Funlock_buffer, 0, 0, 0, /*
+Unlock the file visited in the current buffer,
+if it should normally be locked.
+*/
+       ())
+{
+  /* This function can GC */
+  /* dmoore - and can destroy current_buffer and all sorts of other
+     mean nasty things with pointy teeth.  If you call this make sure
+     you protect things right. */
+
+  if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
+      && STRINGP (current_buffer->file_truename))
+    unlock_file (current_buffer->file_truename);
+  return Qnil;
+}
+
+/* Unlock the file visited in buffer BUFFER.  */
+
+
+void
+unlock_buffer (struct buffer *buffer)
+{
+  /* This function can GC */
+  /* dmoore - and can destroy current_buffer and all sorts of other
+     mean nasty things with pointy teeth.  If you call this make sure
+     you protect things right. */
+  if (BUF_SAVE_MODIFF (buffer) < BUF_MODIFF (buffer)
+      && STRINGP (buffer->file_truename))
+    unlock_file (buffer->file_truename);
+}
+
+DEFUN ("file-locked-p", Ffile_locked_p, 0, 1, 0, /*
+  Return nil if the FILENAME is not locked,\n\
+t if it is locked by you, else a string of the name of the locker.
+*/
+  (filename)) 
+{
+  Lisp_Object ret;
+  register char *lfname;
+  int owner;
+  lock_info_type locker;
+
+  filename = Fexpand_file_name (filename, Qnil);
+
+  MAKE_LOCK_NAME (lfname, filename);
+
+  owner = current_lock_owner (&locker, lfname);
+  if (owner <= 0)
+    ret = Qnil;
+  else if (owner == 2)
+    ret = Qt;
+  else
+    ret = build_string (locker.user);
+
+  if (owner > 0)
+    FREE_LOCK_INFO (locker);
+
+  return ret;
+}
+
+
+/* Initialization functions.  */
+
+void
+syms_of_filelock (void)
+{
+  /* This function can GC */
+  DEFSUBR (Funlock_buffer);
+  DEFSUBR (Flock_buffer);
+  DEFSUBR (Ffile_locked_p);
+
+  defsymbol (&Qask_user_about_supersession_threat,
+             "ask-user-about-supersession-threat");
+  defsymbol (&Qask_user_about_lock, "ask-user-about-lock");
+}
+
+
+#endif /* CLASH_DETECTION */