Initial revision

src/filelock.c

+/* Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include "config.h"
+#include <pwd.h>
+#include <errno.h>
+#include <sys/file.h>
+#ifdef USG
+#include <fcntl.h>
+#endif /* USG */
+
+#undef NULL
+#include "lisp.h"
+#include "paths.h"
+#include "buffer.h"
+
+extern int errno;
+
+#ifdef CLASH_DETECTION
+  
+/* If system does not have symbolic links, it does not have lstat.
+   In that case, use ordinary stat instead.  */
+
+#ifndef S_IFLNK
+#define lstat stat
+#endif
+
+static Lisp_Object
+lock_file_owner_name (lfname)
+     char *lfname;
+{
+  struct stat s;
+  struct passwd *the_pw;
+  extern struct passwd *getpwuid ();
+
+  if (lstat (lfname, &s) == 0)
+    the_pw = getpwuid (s.st_uid);
+  return (the_pw == 0 ? Qnil : build_string (the_pw->pw_name));
+}
+
+
+/* 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 lock_buffer for a buffer already modified,
+   as either the file is already locked, or the user has already
+   decided to go ahead without locking.
+
+   When lock_buffer 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, lock_buffer calls
+   ask-user-about-lock (a Lisp function) with two arguments,
+   the file name and the name of 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.  */
+
+/* The lock file name is the file name with "/" replaced by "!"
+   and put in the Emacs lock directory.  */
+/* (ie., /ka/king/junk.tex -> /!/!ka!king!junk.tex). */
+
+void
+lock_file (fn)
+     register Lisp_Object fn;
+{
+  register Lisp_Object attack;
+  register char *lfname;
+
+  /* Create the name of the lock-file for file fn */
+  lfname = (char *) alloca (XSTRING (fn)->size + strlen (PATH_LOCK) + 1);
+  fill_in_lock_file_name (lfname, fn);
+
+  /* See if this file is visited and has changed on disk since it was visited.  */
+  {
+    register Lisp_Object subject_buf = Fget_file_buffer (fn);
+    if (!NULL (subject_buf)
+	&& NULL (Fverify_visited_file_modtime (subject_buf))
+	&& !NULL (Ffile_exists_p (fn)))
+      call1 (intern ("ask-user-about-supersession-threat"), fn);
+  }
+
+  /* Try to lock the lock. */
+  if (lock_if_free (lfname) <= 0)
+    /* Return now if we have locked it, or if lock dir does not exist */
+    return;
+
+  /* Else consider breaking the lock */
+  attack = call2 (intern ("ask-user-about-lock"), fn,
+		  lock_file_owner_name (lfname));
+  if (!NULL (attack))
+    /* User says take the lock */
+    {
+      lock_superlock (lfname);
+      lock_file_1 (lfname, O_WRONLY) ;
+      unlink (PATH_SUPERLOCK);
+      return;
+    }
+  /* User says ignore the lock */
+}
+
+fill_in_lock_file_name (lockfile, fn)
+     register char *lockfile;
+     register Lisp_Object fn;
+{
+  register char *p;
+
+  strcpy (lockfile, PATH_LOCK);
+
+  p = lockfile + strlen (lockfile);
+
+  strcpy (p, XSTRING (fn)->data);
+
+  for (; *p; p++)
+    {
+      if (*p == '/')
+	*p = '!';
+    }
+}
+
+/* Lock the lock file named LFNAME.
+   If MODE is O_WRONLY, we do so even if it is already locked.
+   If MODE is O_WRONLY | O_EXCL | O_CREAT, we do so only if it is free.
+   Return 1 if successful, 0 if not.  */
+
+int
+lock_file_1 (lfname, mode)
+     int mode; char *lfname; 
+{
+  register int fd;
+  char buf[20];
+
+  if ((fd = open (lfname, mode, 0666)) >= 0)
+    {
+#ifdef USG
+      chmod (lfname, 0666);
+#else
+      fchmod (fd, 0666);
+#endif
+      sprintf (buf, "%d ", getpid ());
+      write (fd, buf, strlen (buf));
+      close (fd);
+      return 1;
+    }
+  else
+    return 0;
+}
+
+/* Lock the lock named LFNAME if possible.
+   Return 0 in that case.
+   Return positive if lock is really locked by someone else.
+   Return -1 if cannot lock for any other reason.  */
+
+int
+lock_if_free (lfname)
+     register char *lfname; 
+{
+  register int clasher;
+
+  while (lock_file_1 (lfname, O_WRONLY | O_EXCL | O_CREAT) == 0)
+    {
+      if (errno != EEXIST)
+	return -1;
+      clasher = current_lock_owner (lfname);
+      if (clasher != 0)
+	if (clasher != getpid ())
+	  return (clasher);
+	else return (0);
+      /* Try again to lock it */
+    }
+  return 0;
+}
+
+/* Return the pid of the process that claims to own the lock file LFNAME,
+   or 0 if nobody does or the lock is obsolete,
+   or -1 if something is wrong with the locking mechanism.  */
+
+int
+current_lock_owner (lfname)
+     char *lfname;
+{
+  int owner = current_lock_owner_1 (lfname);
+  if (owner == 0 && errno == ENOENT)
+    return (0);
+  /* Is it locked by a process that exists?  */
+  if (owner != 0 && (kill (owner, 0) >= 0 || errno == EPERM))
+    return (owner);
+  if (unlink (lfname) < 0)
+    return (-1);
+  return (0);
+}
+
+int
+current_lock_owner_1 (lfname)
+     char *lfname;
+{
+  register int fd;
+  char buf[20];
+  int tem;
+
+  fd = open (lfname, O_RDONLY, 0666);
+  if (fd < 0)
+    return 0;
+  tem = read (fd, buf, sizeof buf);
+  close (fd);
+  return (tem <= 0 ? 0 : atoi (buf));
+}
+
+
+void
+unlock_file (fn)
+     register Lisp_Object fn;
+{
+  register char *lfname;
+
+  lfname = (char *) alloca (XSTRING (fn)->size + strlen (PATH_LOCK) + 1);
+  fill_in_lock_file_name (lfname, fn);
+
+  lock_superlock (lfname);
+
+  if (current_lock_owner_1 (lfname) == getpid ())
+    unlink (lfname);
+
+  unlink (PATH_SUPERLOCK);
+}
+
+lock_superlock (lfname)
+     char *lfname;
+{
+  register int i, fd;
+
+  for (i = -20; i < 0 && (fd = open (PATH_SUPERLOCK,
+				     O_WRONLY | O_EXCL | O_CREAT, 0666)) < 0;
+       i++)
+    {
+      if (errno != EEXIST)
+	return;
+      sleep (1);
+    }
+  if (fd >= 0)
+    {
+#ifdef USG
+      chmod (PATH_SUPERLOCK, 0666);
+#else
+      fchmod (fd, 0666);
+#endif
+      write (fd, lfname, strlen (lfname));
+      close (fd);
+    }
+}
+
+void
+unlock_all_files ()
+{
+  register Lisp_Object tail;
+  register struct buffer *b;
+
+  for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons;
+       tail = XCONS (tail)->cdr)
+    {
+      b = XBUFFER (XCONS (XCONS (tail)->car)->cdr);
+      if (XTYPE (b->filename) == Lisp_String &&
+	  b->save_modified < BUF_MODIFF (b))
+	unlock_file (b->filename);
+    }
+}
+
+
+DEFUN ("lock-buffer", Flock_buffer, Slock_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.")
+  (fn)
+     Lisp_Object fn;
+{
+  if (NULL (fn))
+    fn = current_buffer->filename;
+  else
+    CHECK_STRING (fn, 0);
+  if (current_buffer->save_modified < MODIFF
+      && !NULL (fn))
+    lock_file (fn);
+  return Qnil;    
+}
+
+DEFUN ("unlock-buffer", Funlock_buffer, Sunlock_buffer,
+  0, 0, 0,
+ "Unlock the file visited in the current buffer,\n\
+if it should normally be locked.")
+  ()
+{
+  if (current_buffer->save_modified < MODIFF &&
+      XTYPE (current_buffer->filename) == Lisp_String)
+    unlock_file (current_buffer->filename);
+  return Qnil;
+}
+
+
+/* Unlock the file visited in buffer BUFFER.  */
+
+unlock_buffer (buffer)
+     struct buffer *buffer;
+{
+  if (buffer->save_modified < BUF_MODIFF (buffer) &&
+      XTYPE (buffer->filename) == Lisp_String)
+    unlock_file (buffer->filename);
+}
+
+DEFUN ("file-locked-p", Ffile_locked_p, Sfile_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.")
+  (fn)
+  Lisp_Object fn;
+{
+  register char *lfname;
+  int owner;
+
+  fn = Fexpand_file_name (fn, Qnil);
+
+  /* Create the name of the lock-file for file filename */
+  lfname = (char *) alloca (XSTRING (fn)->size + strlen (PATH_LOCK) + 1);
+  fill_in_lock_file_name (lfname, fn);
+
+  owner = current_lock_owner (lfname);
+  if (owner <= 0)
+    return (Qnil);
+  else if (owner == getpid ())
+    return (Qt);
+  
+  return (lock_file_owner_name (lfname));
+}
+
+syms_of_filelock ()
+{
+  defsubr (&Sunlock_buffer);
+  defsubr (&Slock_buffer);
+  defsubr (&Sfile_locked_p);
+}
+
+#endif /* CLASH_DETECTION */

src/syntax.c

+/* GNU Emacs routines to deal with syntax tables; also word and list parsing.
+   Copyright (C) 1985, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+
+#include "config.h"
+#include <ctype.h>
+#include "lisp.h"
+#include "commands.h"
+#include "buffer.h"
+#include "syntax.h"
+
+Lisp_Object Qsyntax_table_p;
+
+int words_include_escapes;
+
+DEFUN ("syntax-table-p", Fsyntax_table_p, Ssyntax_table_p, 1, 1, 0,
+  "Return t if ARG is a syntax table.\n\
+Any vector of 256 elements will do.")
+  (obj)
+     Lisp_Object obj;
+{
+  if (XTYPE (obj) == Lisp_Vector && XVECTOR (obj)->size == 0400)
+    return Qt;
+  return Qnil;
+}
+
+Lisp_Object
+check_syntax_table (obj)
+     Lisp_Object obj;
+{
+  register Lisp_Object tem;
+  while (tem = Fsyntax_table_p (obj),
+	 NULL (tem))
+    obj = wrong_type_argument (Qsyntax_table_p, obj, 0);
+  return obj;
+}   
+
+
+DEFUN ("syntax-table", Fsyntax_table, Ssyntax_table, 0, 0, 0,
+  "Return the current syntax table.\n\
+This is the one specified by the current buffer.")
+  ()
+{
+  return current_buffer->syntax_table;
+}
+
+DEFUN ("standard-syntax-table", Fstandard_syntax_table,
+   Sstandard_syntax_table, 0, 0, 0,
+  "Return the standard syntax table.\n\
+This is the one used for new buffers.")
+  ()
+{
+  return Vstandard_syntax_table;
+}
+
+DEFUN ("copy-syntax-table", Fcopy_syntax_table, Scopy_syntax_table, 0, 1, 0,
+  "Construct a new syntax table and return it.\n\
+It is a copy of the TABLE, which defaults to the standard syntax table.")
+  (table)
+     Lisp_Object table;
+{
+  Lisp_Object size, val;
+  XFASTINT (size) = 0400;
+  XFASTINT (val) = 0;
+  val = Fmake_vector (size, val);
+  if (!NULL (table))
+    table = check_syntax_table (table);
+  else if (NULL (Vstandard_syntax_table))
+    /* Can only be null during initialization */
+    return val;
+  else table = Vstandard_syntax_table;
+
+  bcopy (XVECTOR (table)->contents,
+	 XVECTOR (val)->contents, 0400 * sizeof (Lisp_Object));
+  return val;
+}
+
+DEFUN ("set-syntax-table", Fset_syntax_table, Sset_syntax_table, 1, 1, 0,
+  "Select a new syntax table for the current buffer.\n\
+One argument, a syntax table.")
+  (table)
+     Lisp_Object table;
+{
+  table = check_syntax_table (table);
+  current_buffer->syntax_table = table;
+  /* Indicate that this buffer now has a specified syntax table.  */
+  current_buffer->local_var_flags |= buffer_local_flags.syntax_table;
+  return table;
+}
+
+/* Convert a letter which signifies a syntax code
+ into the code it signifies.
+ This is used by modify-syntax-entry, and other things. */
+
+unsigned char syntax_spec_code[0400] =
+  { 0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    (char) Swhitespace, 0377, (char) Sstring, 0377,
+        (char) Smath, 0377, 0377, (char) Squote,
+    (char) Sopen, (char) Sclose, 0377, 0377,
+	0377, (char) Swhitespace, (char) Spunct, (char) Scharquote,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377,
+	(char) Scomment, 0377, (char) Sendcomment, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,   /* @, A, ... */
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, (char) Sword,
+    0377, 0377, 0377, 0377, (char) Sescape, 0377, 0377, (char) Ssymbol,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,   /* `, a, ... */
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, (char) Sword,
+    0377, 0377, 0377, 0377, 0377, 0377, 0377, 0377
+  };
+
+/* Indexed by syntax code, give the letter that describes it. */
+
+char syntax_code_spec[13] =
+  {
+    ' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>'
+  };
+
+DEFUN ("char-syntax", Fchar_syntax, Schar_syntax, 1, 1, 0,
+  "Return the syntax code of CHAR, described by a character.\n\
+For example, if CHAR is a word constituent, the character `?w' is returned.\n\
+The characters that correspond to various syntax codes\n\
+are listed in the documentation of `modify-syntax-entry'.")
+  (ch)
+     Lisp_Object ch;
+{
+  CHECK_NUMBER (ch, 0);
+  return make_number (syntax_code_spec[(int) SYNTAX (0xFF & XINT (ch))]);
+}
+
+/* This comment supplies the doc string for modify-syntax-entry,
+   for make-docfile to see.  We cannot put this in the real DEFUN
+   due to limits in the Unix cpp.
+
+DEFUN ("modify-syntax-entry", foo, bar, 0, 0, 0,
+  "Set syntax for character CHAR according to string S.\n\
+The syntax is changed only for table TABLE, which defaults to\n\
+ the current buffer's syntax table.\n\
+The first character of S should be one of the following:\n\
+  Space    whitespace syntax.    w   word constituent.\n\
+  _        symbol constituent.   .   punctuation.\n\
+  (        open-parenthesis.     )   close-parenthesis.\n\
+  \"        string quote.         \\   character-quote.\n\
+  $        paired delimiter.     '   expression quote or prefix operator.\n\
+  <	   comment starter.	 >   comment ender.\n\
+Only single-character comment start and end sequences are represented thus.\n\
+Two-character sequences are represented as described below.\n\
+The second character of S is the matching parenthesis,\n\
+ used only if the first character is `(' or `)'.\n\
+Any additional characters are flags.\n\
+Defined flags are the characters 1, 2, 3, 4, and p.\n\
+ 1 means C is the start of a two-char comment start sequence.\n\
+ 2 means C is the second character of such a sequence.\n\
+ 3 means C is the start of a two-char comment end sequence.\n\
+ 4 means C is the second character of such a sequence.\n\
+ p means C is a prefix character for `backward-prefix-chars';
+   such characters are treated as whitespace when they occur
+   between expressions.")
+
+*/
+
+DEFUN ("modify-syntax-entry", Fmodify_syntax_entry, Smodify_syntax_entry, 2, 3, 
+  /* I really don't know why this is interactive
+     help-form should at least be made useful whilst reading the second arg
+   */
+  "cSet syntax for character: \nsSet syntax for %s to: ",
+  0 /* See immediately above */)
+  (c, newentry, syntax_table)
+     Lisp_Object c, newentry, syntax_table;
+{
+  register unsigned char *p, match;
+  register enum syntaxcode code;
+  Lisp_Object val;
+
+  CHECK_NUMBER (c, 0);
+  CHECK_STRING (newentry, 1);
+  if (NULL (syntax_table))
+    syntax_table = current_buffer->syntax_table;
+  else
+    syntax_table = check_syntax_table (syntax_table);
+
+  p = XSTRING (newentry)->data;
+  code = (enum syntaxcode) syntax_spec_code[*p++];
+  if (((int) code & 0377) == 0377)
+    error ("invalid syntax description letter: %c", c);
+
+  match = *p;
+  if (match) p++;
+  if (match == ' ') match = 0;
+
+  XFASTINT (val) = (match << 8) + (int) code;
+  while (*p)
+    switch (*p++)
+      {
+      case '1':
+	XFASTINT (val) |= 1 << 16;
+	break;
+
+      case '2':
+	XFASTINT (val) |= 1 << 17;
+	break;
+
+      case '3':
+	XFASTINT (val) |= 1 << 18;
+	break;
+
+      case '4':
+	XFASTINT (val) |= 1 << 19;
+	break;
+
+      case 'p':
+	XFASTINT (val) |= 1 << 20;
+	break;
+      }
+	
+  XVECTOR (syntax_table)->contents[0xFF & XINT (c)] = val;
+
+  return Qnil;
+}
+
+/* Dump syntax table to buffer in human-readable format */
+
+describe_syntax (value)
+    Lisp_Object value;
+{
+  register enum syntaxcode code;
+  char desc, match, start1, start2, end1, end2, prefix;
+  char str[2];
+
+  Findent_to (make_number (16), make_number (1));
+
+  if (XTYPE (value) != Lisp_Int)
+    {
+      insert_string ("invalid");
+      return;
+    }
+
+  code = (enum syntaxcode) (XINT (value) & 0377);
+  match = (XINT (value) >> 8) & 0377;
+  start1 = (XINT (value) >> 16) & 1;
+  start2 = (XINT (value) >> 17) & 1;
+  end1 = (XINT (value) >> 18) & 1;
+  end2 = (XINT (value) >> 19) & 1;
+  prefix = (XINT (value) >> 20) & 1;
+
+  if ((int) code < 0 || (int) code >= (int) Smax)
+    {
+      insert_string ("invalid");
+      return;
+    }
+  desc = syntax_code_spec[(int) code];
+
+  str[0] = desc, str[1] = 0;
+  insert (str, 1);
+