Reformatted.
[chise/xemacs-chise.git] / src / filelock.c
1 /* Copyright (C) 1985, 86, 87, 93, 94, 96 Free Software Foundation, Inc.
2
3 This file is part of GNU Emacs.
4
5 GNU Emacs is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2, or (at your option)
8 any later version.
9
10 GNU Emacs is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with GNU Emacs; see the file COPYING.  If not, write to
17 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 Boston, MA 02111-1307, USA.  */
19
20 /* Synced with FSF 20.2 */
21
22 #include <config.h>
23 #include "lisp.h"
24
25 #include "buffer.h"
26 #include <paths.h>
27
28 #include "sysfile.h"
29 #include "sysdir.h"
30 #include "syspwd.h"
31 #include "syssignal.h" /* for kill */
32
33 Lisp_Object Qask_user_about_supersession_threat;
34 Lisp_Object Qask_user_about_lock;
35 int inhibit_clash_detection;
36
37 #ifdef CLASH_DETECTION
38
39 /* The strategy: to lock a file FN, create a symlink .#FN in FN's
40    directory, with link data `user@host.pid'.  This avoids a single
41    mount (== failure) point for lock files.
42
43    When the host in the lock data is the current host, we can check if
44    the pid is valid with kill.
45
46    Otherwise, we could look at a separate file that maps hostnames to
47    reboot times to see if the remote pid can possibly be valid, since we
48    don't want Emacs to have to communicate via pipes or sockets or
49    whatever to other processes, either locally or remotely; rms says
50    that's too unreliable.  Hence the separate file, which could
51    theoretically be updated by daemons running separately -- but this
52    whole idea is unimplemented; in practice, at least in our
53    environment, it seems such stale locks arise fairly infrequently, and
54    Emacs' standard methods of dealing with clashes suffice.
55
56    We use symlinks instead of normal files because (1) they can be
57    stored more efficiently on the filesystem, since the kernel knows
58    they will be small, and (2) all the info about the lock can be read
59    in a single system call (readlink).  Although we could use regular
60    files to be useful on old systems lacking symlinks, nowadays
61    virtually all such systems are probably single-user anyway, so it
62    didn't seem worth the complication.
63
64    Similarly, we don't worry about a possible 14-character limit on
65    file names, because those are all the same systems that don't have
66    symlinks.
67
68    This is compatible with the locking scheme used by Interleaf (which
69    has contributed this implementation for Emacs), and was designed by
70    Ethan Jacobson, Kimbo Mundy, and others.
71
72    --karl@cs.umb.edu/karl@hq.ileaf.com.  */
73
74 /* Note that muleization is provided by using mule-encapsulated
75    versions of the system calls we use like symlink(), unlink(), etc... */
76
77 \f
78 /* Here is the structure that stores information about a lock.  */
79
80 typedef struct
81 {
82   char *user;
83   char *host;
84   unsigned long pid;
85 } lock_info_type;
86
87 /* When we read the info back, we might need this much more,
88    enough for decimal representation plus null.  */
89 #define LOCK_PID_MAX (4 * sizeof (unsigned long))
90
91 /* Free the two dynamically-allocated pieces in PTR.  */
92 #define FREE_LOCK_INFO(i) do { xfree ((i).user); xfree ((i).host); } while (0)
93
94 /* Write the name of the lock file for FN into LFNAME.  Length will be
95    that of FN plus two more for the leading `.#' plus one for the null.  */
96 #define MAKE_LOCK_NAME(lock, file) \
97   (lock = (char *) alloca (XSTRING_LENGTH (file) + 2 + 1), \
98    fill_in_lock_file_name ((Bufbyte *) (lock), (file)))
99
100 static void
101 fill_in_lock_file_name (Bufbyte *lockfile, Lisp_Object fn)
102 {
103   Bufbyte *file_name = XSTRING_DATA (fn);
104   Bufbyte *p;
105   size_t dirlen;
106
107   for (p = file_name + XSTRING_LENGTH (fn) - 1;
108        p > file_name && !IS_ANY_SEP (p[-1]);
109        p--)
110     ;
111   dirlen = p - file_name;
112
113   memcpy (lockfile, file_name, dirlen);
114   p = lockfile + dirlen;
115   *(p++) = '.';
116   *(p++) = '#';
117   memcpy (p, file_name + dirlen, XSTRING_LENGTH (fn) - dirlen + 1);
118 }
119
120 /* Lock the lock file named LFNAME.
121    If FORCE is nonzero, we do so even if it is already locked.
122    Return 1 if successful, 0 if not.  */
123
124 static int
125 lock_file_1 (char *lfname, int force)
126 {
127   /* Does not GC. */
128   int err;
129   char *lock_info_str;
130   char *host_name;
131   char *user_name = user_login_name (NULL);
132
133   if (user_name == NULL)
134     user_name = "";
135
136   if (STRINGP (Vsystem_name))
137     host_name = (char *) XSTRING_DATA (Vsystem_name);
138   else
139     host_name = "";
140
141   lock_info_str = (char *)alloca (strlen (user_name) + strlen (host_name)
142                           + LOCK_PID_MAX + 5);
143
144   sprintf (lock_info_str, "%s@%s.%lu", user_name, host_name,
145            (unsigned long) getpid ());
146
147   err = symlink (lock_info_str, lfname);
148   if (err != 0 && errno == EEXIST && force)
149     {
150       unlink (lfname);
151       err = symlink (lock_info_str, lfname);
152     }
153
154   return err == 0;
155 }
156 \f
157 /* Return 0 if nobody owns the lock file LFNAME or the lock is obsolete,
158    1 if another process owns it (and set OWNER (if non-null) to info),
159    2 if the current process owns it,
160    or -1 if something is wrong with the locking mechanism.  */
161
162 static int
163 current_lock_owner (lock_info_type *owner, char *lfname)
164 {
165   /* Does not GC. */
166   int len, ret;
167   int local_owner = 0;
168   char *at, *dot;
169   char *lfinfo = 0;
170   int bufsize = 50;
171   /* Read arbitrarily-long contents of symlink.  Similar code in
172      file-symlink-p in fileio.c.  */
173   do
174     {
175       bufsize *= 2;
176       lfinfo = (char *) xrealloc (lfinfo, bufsize);
177       len = readlink (lfname, lfinfo, bufsize);
178     }
179   while (len >= bufsize);
180
181   /* If nonexistent lock file, all is well; otherwise, got strange error. */
182   if (len == -1)
183     {
184       xfree (lfinfo);
185       return errno == ENOENT ? 0 : -1;
186     }
187
188   /* Link info exists, so `len' is its length.  Null terminate.  */
189   lfinfo[len] = 0;
190
191   /* Even if the caller doesn't want the owner info, we still have to
192      read it to determine return value, so allocate it.  */
193   if (!owner)
194     {
195       owner = (lock_info_type *) alloca (sizeof (lock_info_type));
196       local_owner = 1;
197     }
198
199   /* Parse USER@HOST.PID.  If can't parse, return -1.  */
200   /* The USER is everything before the first @.  */
201   at = strchr (lfinfo, '@');
202   dot = strrchr (lfinfo, '.');
203   if (!at || !dot) {
204     xfree (lfinfo);
205     return -1;
206   }
207   len = at - lfinfo;
208   owner->user = (char *) xmalloc (len + 1);
209   strncpy (owner->user, lfinfo, len);
210   owner->user[len] = 0;
211
212   /* The PID is everything after the last `.'.  */
213   owner->pid = atoi (dot + 1);
214
215   /* The host is everything in between.  */
216   len = dot - at - 1;
217   owner->host = (char *) xmalloc (len + 1);
218   strncpy (owner->host, at + 1, len);
219   owner->host[len] = 0;
220
221   /* We're done looking at the link info.  */
222   xfree (lfinfo);
223
224   /* On current host?  */
225   if (STRINGP (Fsystem_name ())
226       && strcmp (owner->host, (char *) XSTRING_DATA (Fsystem_name ())) == 0)
227     {
228       if (owner->pid == (unsigned long) getpid ())
229         ret = 2; /* We own it.  */
230       else if (owner->pid > 0
231                && (kill (owner->pid, 0) >= 0 || errno == EPERM))
232         ret = 1; /* An existing process on this machine owns it.  */
233       /* The owner process is dead or has a strange pid (<=0), so try to
234          zap the lockfile.  */
235       else if (unlink (lfname) < 0)
236         ret = -1;
237       else
238         ret = 0;
239     }
240   else
241     { /* If we wanted to support the check for stale locks on remote machines,
242          here's where we'd do it.  */
243       ret = 1;
244     }
245
246   /* Avoid garbage.  */
247   if (local_owner || ret <= 0)
248     {
249       FREE_LOCK_INFO (*owner);
250     }
251   return ret;
252 }
253 \f
254 /* Lock the lock named LFNAME if possible.
255    Return 0 in that case.
256    Return positive if some other process owns the lock, and info about
257      that process in CLASHER.
258    Return -1 if cannot lock for any other reason.  */
259
260 static int
261 lock_if_free (lock_info_type *clasher, char *lfname)
262 {
263   /* Does not GC. */
264   if (lock_file_1 (lfname, 0) == 0)
265     {
266       int locker;
267
268       if (errno != EEXIST)
269         return -1;
270
271       locker = current_lock_owner (clasher, lfname);
272       if (locker == 2)
273         {
274           FREE_LOCK_INFO (*clasher);
275           return 0;   /* We ourselves locked it.  */
276         }
277       else if (locker == 1)
278         return 1;  /* Someone else has it.  */
279
280       return -1; /* Something's wrong.  */
281     }
282   return 0;
283 }
284
285 /* lock_file locks file FN,
286    meaning it serves notice on the world that you intend to edit that file.
287    This should be done only when about to modify a file-visiting
288    buffer previously unmodified.
289    Do not (normally) call this for a buffer already modified,
290    as either the file is already locked, or the user has already
291    decided to go ahead without locking.
292
293    When this returns, either the lock is locked for us,
294    or the user has said to go ahead without locking.
295
296    If the file is locked by someone else, this calls
297    ask-user-about-lock (a Lisp function) with two arguments,
298    the file name and info about the user who did the locking.
299    This function can signal an error, or return t meaning
300    take away the lock, or return nil meaning ignore the lock.  */
301
302 void
303 lock_file (Lisp_Object fn)
304 {
305   /* This function can GC.  GC checked 7-11-00 ben */
306   /* dmoore - and can destroy current_buffer and all sorts of other
307      mean nasty things with pointy teeth.  If you call this make sure
308      you protect things right. */
309   /* Somebody updated the code in this function and removed the previous
310      comment.  -slb */
311
312   register Lisp_Object attack, orig_fn;
313   register char *lfname, *locker;
314   lock_info_type lock_info;
315   struct gcpro gcpro1, gcpro2, gcpro3;
316   Lisp_Object old_current_buffer;
317   Lisp_Object subject_buf;
318
319   if (inhibit_clash_detection)
320     return;
321
322   XSETBUFFER (old_current_buffer, current_buffer);
323   subject_buf = Qnil;
324   GCPRO3 (fn, subject_buf, old_current_buffer);
325   orig_fn = fn;
326   fn = Fexpand_file_name (fn, Qnil);
327
328   /* Create the name of the lock-file for file fn */
329   MAKE_LOCK_NAME (lfname, fn);
330
331   /* See if this file is visited and has changed on disk since it was
332      visited.  */
333   {
334     subject_buf = get_truename_buffer (orig_fn);
335     if (!NILP (subject_buf)
336         && NILP (Fverify_visited_file_modtime (subject_buf))
337         && !NILP (Ffile_exists_p (fn)))
338       call1_in_buffer (XBUFFER (subject_buf),
339                        Qask_user_about_supersession_threat, fn);
340   }
341
342   /* Try to lock the lock. */
343   if (current_buffer != XBUFFER (old_current_buffer)
344       || lock_if_free (&lock_info, lfname) <= 0)
345     /* Return now if we have locked it, or if lock creation failed
346      or current buffer is killed. */
347     goto done;
348
349   /* Else consider breaking the lock */
350   locker = (char *) alloca (strlen (lock_info.user) + strlen (lock_info.host)
351                             + LOCK_PID_MAX + 9);
352   sprintf (locker, "%s@%s (pid %lu)", lock_info.user, lock_info.host,
353            lock_info.pid);
354   FREE_LOCK_INFO (lock_info);
355
356   attack = call2_in_buffer (BUFFERP (subject_buf) ? XBUFFER (subject_buf) :
357                             current_buffer, Qask_user_about_lock , fn,
358                             build_string (locker));
359   if (!NILP (attack) && current_buffer == XBUFFER (old_current_buffer))
360     /* User says take the lock */
361     {
362       lock_file_1 (lfname, 1);
363       goto done;
364     }
365   /* User says ignore the lock */
366  done:
367   UNGCPRO;
368 }
369
370 void
371 unlock_file (Lisp_Object fn)
372 {
373   /* This can GC */
374   register char *lfname;
375   struct gcpro gcpro1;
376
377   GCPRO1 (fn);
378
379   fn = Fexpand_file_name (fn, Qnil);
380
381   MAKE_LOCK_NAME (lfname, fn);
382
383   if (current_lock_owner (0, lfname) == 2)
384     unlink (lfname);
385
386   UNGCPRO;
387 }
388
389 void
390 unlock_all_files (void)
391 {
392   register Lisp_Object tail;
393
394   for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
395     {
396       struct buffer *b = XBUFFER (XCDR (XCAR (tail)));
397       if (STRINGP (b->file_truename) && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b))
398         unlock_file (b->file_truename);
399     }
400 }
401 \f
402 DEFUN ("lock-buffer", Flock_buffer,   0, 1, 0, /*
403 Lock FILE, if current buffer is modified.
404 FILE defaults to current buffer's visited file,
405 or else nothing is done if current buffer isn't visiting a file.
406 */
407        (file))
408 {
409   if (NILP (file))
410     file = current_buffer->file_truename;
411   CHECK_STRING (file);
412   if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
413       && !NILP (file))
414     lock_file (file);
415   return Qnil;
416 }
417
418 DEFUN ("unlock-buffer", Funlock_buffer, 0, 0, 0, /*
419 Unlock the file visited in the current buffer,
420 if it should normally be locked.
421 */
422        ())
423 {
424   /* This function can GC */
425   /* dmoore - and can destroy current_buffer and all sorts of other
426      mean nasty things with pointy teeth.  If you call this make sure
427      you protect things right. */
428
429   if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
430       && STRINGP (current_buffer->file_truename))
431     unlock_file (current_buffer->file_truename);
432   return Qnil;
433 }
434
435 /* Unlock the file visited in buffer BUFFER.  */
436
437
438 void
439 unlock_buffer (struct buffer *buffer)
440 {
441   /* This function can GC */
442   /* dmoore - and can destroy current_buffer and all sorts of other
443      mean nasty things with pointy teeth.  If you call this make sure
444      you protect things right. */
445   if (BUF_SAVE_MODIFF (buffer) < BUF_MODIFF (buffer)
446       && STRINGP (buffer->file_truename))
447     unlock_file (buffer->file_truename);
448 }
449
450 DEFUN ("file-locked-p", Ffile_locked_p, 0, 1, 0, /*
451 Return nil if the FILENAME is not locked,
452 t if it is locked by you, else a string of the name of the locker.
453 */
454        (filename))
455 {
456   Lisp_Object ret;
457   register char *lfname;
458   int owner;
459   lock_info_type locker;
460   struct gcpro gcpro1;
461
462   GCPRO1 (filename);
463
464   filename = Fexpand_file_name (filename, Qnil);
465
466   MAKE_LOCK_NAME (lfname, filename);
467
468   owner = current_lock_owner (&locker, lfname);
469   if (owner <= 0)
470     ret = Qnil;
471   else if (owner == 2)
472     ret = Qt;
473   else
474     ret = build_string (locker.user);
475
476   if (owner > 0)
477     FREE_LOCK_INFO (locker);
478
479   UNGCPRO;
480
481   return ret;
482 }
483
484 \f
485 /* Initialization functions.  */
486
487 void
488 syms_of_filelock (void)
489 {
490   /* This function can GC */
491   DEFSUBR (Funlock_buffer);
492   DEFSUBR (Flock_buffer);
493   DEFSUBR (Ffile_locked_p);
494
495   defsymbol (&Qask_user_about_supersession_threat,
496              "ask-user-about-supersession-threat");
497   defsymbol (&Qask_user_about_lock, "ask-user-about-lock");
498 }
499
500 void
501 vars_of_filelock (void)
502 {
503   DEFVAR_BOOL ("inhibit-clash-detection", &inhibit_clash_detection /*
504 Non-nil inhibits creation of lock file to detect clash.
505 */);
506   inhibit_clash_detection = 0;
507 }
508
509 #endif /* CLASH_DETECTION */