git.chise.org Git - chise/xemacs-chise.git.1/blob - src/filelock.c

   1 /* Copyright (C) 1985, 1986, 1987, 1992, 1993, 1994
   2    Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: FSF 19.30. */
  22
  23 #include <config.h>
  24 #include "lisp.h"
  25
  26 #include "buffer.h"
  27 #include <paths.h>
  28
  29 #include "sysfile.h"
  30 #include "sysdir.h"
  31 #include "syspwd.h"
  32 #include "syssignal.h" /* for kill */
  33
  34 #ifndef CLASH_DETECTION
  35 #error  CLASH_DETECTION is not defined??
  36 #endif
  37
  38 /* FSFmacs uses char *lock_dir and char *superlock_file instead of
  39    the Lisp variables we use. */
  40
  41 /* The name of the directory in which we keep lock files, with a '/'
  42    appended.  */
  43 Lisp_Object Vlock_directory;
  44
  45 #if 0 /* FSFmacs */
  46 /* Look in startup.el */
  47 /* The name of the file in the lock directory which is used to
  48    arbitrate access to the entire directory.  */
  49 #define SUPERLOCK_NAME "!!!SuperLock!!!"
  50 #endif
  51
  52 /* The name of the superlock file.  This is SUPERLOCK_NAME appended to
  53    Vlock_directory.  */
  54 Lisp_Object Vsuperlock_file, Vconfigure_superlock_file;
  55
  56 Lisp_Object Qask_user_about_supersession_threat;
  57 Lisp_Object Qask_user_about_lock;
  58
  59 static void lock_superlock (CONST char *lfname);
  60 static int lock_file_1 (CONST char *lfname, int mode);
  61 static int lock_if_free (CONST char *lfname);
  62 static int current_lock_owner (CONST char *);
  63 static int current_lock_owner_1 (CONST char *);
  64
  65 /* Set LOCK to the name of the lock file for the filename FILE.
  66    char *LOCK; Lisp_Object FILE;
  67
  68    MAKE_LOCK_NAME assumes you have already verified that Vlock_directory
  69    is a string. */
  70
  71 #ifndef HAVE_LONG_FILE_NAMES
  72
  73 #define MAKE_LOCK_NAME(lock, file)                                      \
  74   (lock = (char *) alloca (14 + XSTRING_LENGTH (Vlock_directory) + 1),  \
  75    fill_in_lock_short_file_name (lock, (file)))
  76
  77 static void
  78 fill_in_lock_short_file_name (REGISTER char *lockfile, REGISTER Lisp_Object fn)
  79 {
  80   REGISTER union
  81     {
  82       unsigned int  word [2];
  83       unsigned char byte [8];
  84     } crc;
  85   REGISTER unsigned char *p, new;
  86
  87   CHECK_STRING (Vlock_directory);
  88
  89   /* 7-bytes cyclic code for burst correction on byte-by-byte basis.
  90      the used polynomial is D^7 + D^6 + D^3 +1. pot@cnuce.cnr.it */
  91
  92   crc.word[0] = crc.word[1] = 0;
  93
  94   for (p = XSTRING_DATA (fn); new = *p++; )
  95     {
  96       new += crc.byte[6];
  97       crc.byte[6] = crc.byte[5] + new;
  98       crc.byte[5] = crc.byte[4];
  99       crc.byte[4] = crc.byte[3];
 100       crc.byte[3] = crc.byte[2] + new;
 101       crc.byte[2] = crc.byte[1];
 102       crc.byte[1] = crc.byte[0];
 103       crc.byte[0] = new;
 104     }
 105
 106   {
 107     int need_slash = 0;
 108
 109     /* in case lock-directory doesn't end in / */
 110     if (XSTRING_BYTE (Vlock_directory,
 111                      XSTRING_LENGTH (Vlock_directory) - 1) != '/')
 112       need_slash = 1;
 113
 114     sprintf (lockfile, "%s%s%.2x%.2x%.2x%.2x%.2x%.2x%.2x",
 115              (char *) XSTRING_DATA (Vlock_directory),
 116              need_slash ? "/" : "",
 117              crc.byte[0], crc.byte[1], crc.byte[2], crc.byte[3],
 118              crc.byte[4], crc.byte[5], crc.byte[6]);
 119   }
 120 }
 121
 122 #else /* defined HAVE_LONG_FILE_NAMES */
 123
 124 /* +2 for terminating null and possible extra slash */
 125 #define MAKE_LOCK_NAME(lock, file)                                      \
 126   (lock = (char *) alloca (XSTRING_LENGTH (file) +                      \
 127                            XSTRING_LENGTH (Vlock_directory) + 2),       \
 128    fill_in_lock_file_name (lock, (file)))
 129
 130 static void
 131 fill_in_lock_file_name (REGISTER char *lockfile, REGISTER Lisp_Object fn)
 132      /* fn must be a Lisp_String! */
 133 {
 134   REGISTER char *p;
 135
 136   CHECK_STRING (Vlock_directory);
 137
 138   strcpy (lockfile, (char *) XSTRING_DATA (Vlock_directory));
 139
 140   p = lockfile + strlen (lockfile);
 141
 142   if (p == lockfile /* lock-directory is empty?? */
 143       || *(p - 1) != '/')  /* in case lock-directory doesn't end in / */
 144     {
 145       *p = '/';
 146       p++;
 147     }
 148
 149   strcpy (p, (char *) XSTRING_DATA (fn));
 150
 151   for (; *p; p++)
 152     {
 153       if (*p == '/')
 154         *p = '!';
 155     }
 156 }
 157 #endif /* !defined HAVE_LONG_FILE_NAMES */
 158
 159 static Lisp_Object
 160 lock_file_owner_name (CONST char *lfname)
 161 {
 162   struct stat s;
 163   struct passwd *the_pw = 0;
 164
 165   if (lstat (lfname, &s) == 0)
 166     the_pw = getpwuid (s.st_uid);
 167   return (the_pw == 0 ? Qnil : build_string (the_pw->pw_name));
 168 }
 169
 170
 171 /* lock_file locks file fn,
 172    meaning it serves notice on the world that you intend to edit that file.
 173    This should be done only when about to modify a file-visiting
 174    buffer previously unmodified.
 175    Do not (normally) call lock_buffer for a buffer already modified,
 176    as either the file is already locked, or the user has already
 177    decided to go ahead without locking.
 178
 179    When lock_buffer returns, either the lock is locked for us,
 180    or the user has said to go ahead without locking.
 181
 182    If the file is locked by someone else, lock_buffer calls
 183    ask-user-about-lock (a Lisp function) with two arguments,
 184    the file name and the name of the user who did the locking.
 185    This function can signal an error, or return t meaning
 186    take away the lock, or return nil meaning ignore the lock.  */
 187
 188 /* The lock file name is the file name with "/" replaced by "!"
 189    and put in the Emacs lock directory.  */
 190 /* (ie., /ka/king/junk.tex -> /!/!ka!king!junk.tex). */
 191
 192 /* If HAVE_LONG_FILE_NAMES is not defined, the lock file name is the hex
 193    representation of a 14-bytes CRC generated from the file name
 194    and put in the Emacs lock directory (not very nice, but it works).
 195    (ie., /ka/king/junk.tex -> /!/12a82c62f1c6da). */
 196
 197 void
 198 lock_file (Lisp_Object fn)
 199 {
 200   /* This function can GC. */
 201   /* dmoore - and can destroy current_buffer and all sorts of other
 202      mean nasty things with pointy teeth.  If you call this make sure
 203      you protect things right. */
 204
 205   REGISTER Lisp_Object attack, orig_fn;
 206   REGISTER char *lfname;
 207   struct gcpro gcpro1, gcpro2;
 208   Lisp_Object subject_buf = Qnil;
 209
 210   if (NILP (Vlock_directory) || NILP (Vsuperlock_file))
 211     return;
 212   CHECK_STRING (fn);
 213   CHECK_STRING (Vlock_directory);
 214
 215   GCPRO2 (fn, subject_buf);
 216   orig_fn = fn;
 217   fn = Fexpand_file_name (fn, Qnil);
 218
 219   /* Create the name of the lock-file for file fn */
 220   MAKE_LOCK_NAME (lfname, fn);
 221
 222   /* See if this file is visited and has changed on disk since it was
 223      visited.  */
 224   subject_buf = Fget_file_buffer (fn);
 225   if (!NILP (subject_buf)
 226       && NILP (Fverify_visited_file_modtime (subject_buf))
 227       && !NILP (Ffile_exists_p (fn)))
 228     call1_in_buffer (XBUFFER (subject_buf),
 229                      Qask_user_about_supersession_threat, fn);
 230
 231   /* Try to lock the lock. */
 232   if (lock_if_free (lfname) <= 0)
 233     /* Return now if we have locked it, or if lock dir does not exist */
 234     goto done;
 235
 236   /* Else consider breaking the lock */
 237   attack = call2_in_buffer (BUFFERP (subject_buf) ? XBUFFER (subject_buf) :
 238                             current_buffer, Qask_user_about_lock, fn,
 239                             lock_file_owner_name (lfname));
 240   if (!NILP (attack))
 241     /* User says take the lock */
 242     {
 243       CHECK_STRING (Vsuperlock_file);
 244       lock_superlock (lfname);
 245       lock_file_1 (lfname, O_WRONLY);
 246       unlink ((char *) XSTRING_DATA (Vsuperlock_file));
 247       goto done;
 248     }
 249   /* User says ignore the lock */
 250  done:
 251   UNGCPRO;
 252 }
 253
 254
 255 /* Lock the lock file named LFNAME.
 256    If MODE is O_WRONLY, we do so even if it is already locked.
 257    If MODE is O_WRONLY | O_EXCL | O_CREAT, we do so only if it is free.
 258    Return 1 if successful, 0 if not.  */
 259
 260 static int
 261 lock_file_1 (CONST char *lfname, int mode)
 262 {
 263   REGISTER int fd;
 264   char buf[20];
 265
 266   if ((fd = open (lfname, mode, 0666)) >= 0)
 267     {
 268 #if defined(WINDOWSNT)
 269       chmod(lfname, _S_IREAD|_S_IWRITE);
 270 #elif defined(USG)
 271       chmod (lfname, 0666);
 272 #else
 273       fchmod (fd, 0666);
 274 #endif
 275       sprintf (buf, "%ld ", (long) getpid ());
 276       write (fd, buf, strlen (buf));
 277       close (fd);
 278       return 1;
 279     }
 280   else
 281     return 0;
 282 }
 283
 284 /* Lock the lock named LFNAME if possible.
 285    Return 0 in that case.
 286    Return positive if lock is really locked by someone else.
 287    Return -1 if cannot lock for any other reason.  */
 288
 289 static int
 290 lock_if_free (CONST char *lfname)
 291 {
 292   REGISTER int clasher;
 293
 294   while (lock_file_1 (lfname, O_WRONLY | O_EXCL | O_CREAT) == 0)
 295     {
 296       if (errno != EEXIST)
 297         return -1;
 298       clasher = current_lock_owner (lfname);
 299       if (clasher != 0)
 300         if (clasher != getpid ())
 301           return (clasher);
 302         else return (0);
 303       /* Try again to lock it */
 304     }
 305   return 0;
 306 }
 307
 308 /* Return the pid of the process that claims to own the lock file LFNAME,
 309    or 0 if nobody does or the lock is obsolete,
 310    or -1 if something is wrong with the locking mechanism.  */
 311
 312 static int
 313 current_lock_owner (CONST char *lfname)
 314 {
 315   int owner = current_lock_owner_1 (lfname);
 316   if (owner == 0 && errno == ENOENT)
 317     return (0);
 318   /* Is it locked by a process that exists?  */
 319   if (owner != 0 && (kill (owner, 0) >= 0 || errno == EPERM))
 320     return (owner);
 321   if (unlink (lfname) < 0)
 322     return (-1);
 323   return (0);
 324 }
 325
 326 static int
 327 current_lock_owner_1 (CONST char *lfname)
 328 {
 329   REGISTER int fd;
 330   char buf[20];
 331   int tem;
 332
 333   fd = open (lfname, O_RDONLY, 0666);
 334   if (fd < 0)
 335     return 0;
 336   tem = read (fd, buf, sizeof buf);
 337   close (fd);
 338   return (tem <= 0 ? 0 : atoi (buf));
 339 }
 340
 341 \f
 342 void
 343 unlock_file (Lisp_Object fn)
 344 {
 345   /* This function can GC. */
 346   /* dmoore - and can destroy current_buffer and all sorts of other
 347      mean nasty things with pointy teeth.  If you call this make sure
 348      you protect things right. */
 349
 350   REGISTER char *lfname;
 351   if (NILP (Vlock_directory) || NILP (Vsuperlock_file)) return;
 352   CHECK_STRING (fn);
 353   CHECK_STRING (Vlock_directory);
 354   CHECK_STRING (Vsuperlock_file);
 355
 356   fn = Fexpand_file_name (fn, Qnil);
 357
 358   MAKE_LOCK_NAME (lfname, fn);
 359
 360   lock_superlock (lfname);
 361
 362   if (current_lock_owner_1 (lfname) == getpid ())
 363     unlink (lfname);
 364
 365   unlink ((char *) XSTRING_DATA (Vsuperlock_file));
 366 }
 367
 368 static void
 369 lock_superlock (CONST char *lfname)
 370 {
 371   REGISTER int i, fd;
 372   DIR *lockdir;
 373
 374   for (i = -20; i < 0 &&
 375        (fd = open ((char *) XSTRING_DATA (Vsuperlock_file),
 376                    O_WRONLY | O_EXCL | O_CREAT, 0666)) < 0;
 377        i++)
 378     {
 379       if (errno != EEXIST)
 380         return;
 381
 382       /* This seems to be necessary to prevent Emacs from hanging when the
 383          competing process has already deleted the superlock, but it's still
 384          in the NFS cache.  So we force NFS to synchronize the cache.  */
 385       lockdir = opendir ((char *) XSTRING_DATA (Vlock_directory));
 386       if (lockdir)
 387         closedir (lockdir);
 388
 389       emacs_sleep (1);
 390     }
 391   if (fd >= 0)
 392     {
 393 #if defined(WINDOWSNT)
 394       chmod(lfname, _S_IREAD|_S_IWRITE);
 395 #elif defined(USG)
 396       chmod ((char *) XSTRING_DATA (Vsuperlock_file), 0666);
 397 #else
 398       fchmod (fd, 0666);
 399 #endif
 400       write (fd, lfname, strlen (lfname));
 401       close (fd);
 402     }
 403 }
 404
 405 void
 406 unlock_all_files (void)
 407 {
 408   /* This function can GC. */
 409
 410   Lisp_Object tail;
 411   REGISTER struct buffer *b;
 412   struct gcpro gcpro1;
 413
 414   GCPRO1 (tail);
 415   for (tail = Vbuffer_alist; GC_CONSP (tail);
 416        tail = XCDR (tail))
 417     {
 418       b = XBUFFER (XCDR (XCAR (tail)));
 419       if (STRINGP (b->file_truename) &&
 420           BUF_SAVE_MODIFF (b) < BUF_MODIFF (b))
 421         unlock_file (b->file_truename);
 422     }
 423   UNGCPRO;
 424 }
 425
 426 \f
 427 DEFUN ("lock-buffer", Flock_buffer, 0, 1, 0, /*
 428 Lock FILE, if current buffer is modified.
 429 FILE defaults to current buffer's visited file,
 430 or else nothing is done if current buffer isn't visiting a file.
 431 */
 432        (fn))
 433 {
 434   /* This function can GC */
 435   /* dmoore - and can destroy current_buffer and all sorts of other
 436      mean nasty things with pointy teeth.  If you call this make sure
 437      you protect things right. */
 438
 439   if (NILP (fn))
 440     fn = current_buffer->file_truename;
 441   CHECK_STRING (fn);
 442   if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
 443       && !NILP (fn))
 444     lock_file (fn);
 445   return Qnil;
 446 }
 447
 448 DEFUN ("unlock-buffer", Funlock_buffer, 0, 0, 0, /*
 449 Unlock the file visited in the current buffer,
 450 if it should normally be locked.
 451 */
 452        ())
 453 {
 454   /* This function can GC */
 455   /* dmoore - and can destroy current_buffer and all sorts of other
 456      mean nasty things with pointy teeth.  If you call this make sure
 457      you protect things right. */
 458
 459   if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
 460       && STRINGP (current_buffer->file_truename))
 461     unlock_file (current_buffer->file_truename);
 462   return Qnil;
 463 }
 464
 465 \f
 466 /* Unlock the file visited in buffer BUFFER.  */
 467
 468 void
 469 unlock_buffer (struct buffer *buffer)
 470 {
 471   /* This function can GC */
 472   /* dmoore - and can destroy current_buffer and all sorts of other
 473      mean nasty things with pointy teeth.  If you call this make sure
 474      you protect things right. */
 475   if (BUF_SAVE_MODIFF (buffer) < BUF_MODIFF (buffer)
 476       && STRINGP (buffer->file_truename))
 477     unlock_file (buffer->file_truename);
 478 }
 479
 480 DEFUN ("file-locked-p", Ffile_locked_p, 0, 1, 0, /*
 481 Return nil if the FILENAME is not locked,
 482 t if it is locked by you, else a string of the name of the locker.
 483 */
 484        (fn))
 485 {
 486   /* This function can GC */
 487   REGISTER char *lfname;
 488   int owner;
 489
 490   if (NILP (Vlock_directory) || NILP (Vsuperlock_file))
 491     return Qnil;
 492   CHECK_STRING (Vlock_directory);
 493
 494   fn = Fexpand_file_name (fn, Qnil);
 495
 496   MAKE_LOCK_NAME (lfname, fn);
 497
 498   owner = current_lock_owner (lfname);
 499   if (owner <= 0)
 500     return Qnil;
 501   else if (owner == getpid ())
 502     return Qt;
 503
 504   return lock_file_owner_name (lfname);
 505 }
 506
 507 void
 508 syms_of_filelock (void)
 509 {
 510   /* This function can GC */
 511   DEFSUBR (Funlock_buffer);
 512   DEFSUBR (Flock_buffer);
 513   DEFSUBR (Ffile_locked_p);
 514
 515   defsymbol (&Qask_user_about_supersession_threat,
 516              "ask-user-about-supersession-threat");
 517   defsymbol (&Qask_user_about_lock, "ask-user-about-lock");
 518 }
 519
 520 void
 521 vars_of_filelock (void)
 522 {
 523   DEFVAR_LISP ("lock-directory", &Vlock_directory /*
 524 Don't change this
 525 */ );
 526   Vlock_directory = Qnil;
 527   DEFVAR_LISP ("superlock-file", &Vsuperlock_file /*
 528 Don't change this
 529 */ );
 530   Vsuperlock_file = Qnil;
 531 }
 532
 533 void
 534 complex_vars_of_filelock (void)
 535 {
 536   DEFVAR_LISP ("configure-superlock-file", &Vconfigure_superlock_file /*
 537 For internal use by the build procedure only.
 538 configure's idea of what SUPERLOCK-FILE will be.
 539 */ );
 540 #ifdef PATH_SUPERLOCK
 541   Vconfigure_superlock_file = build_string (PATH_SUPERLOCK);
 542 #else
 543   Vconfigure_superlock_file = Qnil;
 544 #endif
 545   /* All the rest done dynamically by startup.el */
 546 }