1 /* Copyright (C) 1985, 1986, 1987, 1992, 1993, 1994
2 Free Software Foundation, Inc.
4 This file is part of XEmacs.
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
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
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. */
21 /* Synched up with: FSF 19.30. */
32 #include "syssignal.h" /* for kill */
34 #ifndef CLASH_DETECTION
35 #error CLASH_DETECTION is not defined??
38 /* FSFmacs uses char *lock_dir and char *superlock_file instead of
39 the Lisp variables we use. */
41 /* The name of the directory in which we keep lock files, with a '/'
43 Lisp_Object Vlock_directory;
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!!!"
52 /* The name of the superlock file. This is SUPERLOCK_NAME appended to
54 Lisp_Object Vsuperlock_file, Vconfigure_superlock_file;
56 Lisp_Object Qask_user_about_supersession_threat;
57 Lisp_Object Qask_user_about_lock;
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 *);
65 /* Set LOCK to the name of the lock file for the filename FILE.
66 char *LOCK; Lisp_Object FILE;
68 MAKE_LOCK_NAME assumes you have already verified that Vlock_directory
71 #ifndef HAVE_LONG_FILE_NAMES
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)))
78 fill_in_lock_short_file_name (REGISTER char *lockfile, REGISTER Lisp_Object fn)
82 unsigned int word [2];
83 unsigned char byte [8];
85 REGISTER unsigned char *p, new;
87 CHECK_STRING (Vlock_directory);
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 */
92 crc.word[0] = crc.word[1] = 0;
94 for (p = XSTRING_DATA (fn); new = *p++; )
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];
109 /* in case lock-directory doesn't end in / */
110 if (XSTRING_BYTE (Vlock_directory,
111 XSTRING_LENGTH (Vlock_directory) - 1) != '/')
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]);
122 #else /* defined HAVE_LONG_FILE_NAMES */
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)))
131 fill_in_lock_file_name (REGISTER char *lockfile, REGISTER Lisp_Object fn)
132 /* fn must be a Lisp_String! */
136 CHECK_STRING (Vlock_directory);
138 strcpy (lockfile, (char *) XSTRING_DATA (Vlock_directory));
140 p = lockfile + strlen (lockfile);
142 if (p == lockfile /* lock-directory is empty?? */
143 || *(p - 1) != '/') /* in case lock-directory doesn't end in / */
149 strcpy (p, (char *) XSTRING_DATA (fn));
157 #endif /* !defined HAVE_LONG_FILE_NAMES */
160 lock_file_owner_name (CONST char *lfname)
163 struct passwd *the_pw = 0;
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));
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.
179 When lock_buffer returns, either the lock is locked for us,
180 or the user has said to go ahead without locking.
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. */
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). */
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). */
198 lock_file (Lisp_Object fn)
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. */
205 REGISTER Lisp_Object attack, orig_fn;
206 REGISTER char *lfname;
207 struct gcpro gcpro1, gcpro2;
208 Lisp_Object subject_buf = Qnil;
210 if (NILP (Vlock_directory) || NILP (Vsuperlock_file))
213 CHECK_STRING (Vlock_directory);
215 GCPRO2 (fn, subject_buf);
217 fn = Fexpand_file_name (fn, Qnil);
219 /* Create the name of the lock-file for file fn */
220 MAKE_LOCK_NAME (lfname, fn);
222 /* See if this file is visited and has changed on disk since it was
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);
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 */
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));
241 /* User says take the lock */
243 CHECK_STRING (Vsuperlock_file);
244 lock_superlock (lfname);
245 lock_file_1 (lfname, O_WRONLY);
246 unlink ((char *) XSTRING_DATA (Vsuperlock_file));
249 /* User says ignore the lock */
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. */
261 lock_file_1 (CONST char *lfname, int mode)
266 if ((fd = open (lfname, mode, 0666)) >= 0)
268 #if defined(WINDOWSNT)
269 chmod(lfname, _S_IREAD|_S_IWRITE);
271 chmod (lfname, 0666);
275 sprintf (buf, "%ld ", (long) getpid ());
276 write (fd, buf, strlen (buf));
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. */
290 lock_if_free (CONST char *lfname)
292 REGISTER int clasher;
294 while (lock_file_1 (lfname, O_WRONLY | O_EXCL | O_CREAT) == 0)
298 clasher = current_lock_owner (lfname);
300 if (clasher != getpid ())
303 /* Try again to lock it */
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. */
313 current_lock_owner (CONST char *lfname)
315 int owner = current_lock_owner_1 (lfname);
316 if (owner == 0 && errno == ENOENT)
318 /* Is it locked by a process that exists? */
319 if (owner != 0 && (kill (owner, 0) >= 0 || errno == EPERM))
321 if (unlink (lfname) < 0)
327 current_lock_owner_1 (CONST char *lfname)
333 fd = open (lfname, O_RDONLY, 0666);
336 tem = read (fd, buf, sizeof buf);
338 return (tem <= 0 ? 0 : atoi (buf));
343 unlock_file (Lisp_Object fn)
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. */
350 REGISTER char *lfname;
351 if (NILP (Vlock_directory) || NILP (Vsuperlock_file)) return;
353 CHECK_STRING (Vlock_directory);
354 CHECK_STRING (Vsuperlock_file);
356 fn = Fexpand_file_name (fn, Qnil);
358 MAKE_LOCK_NAME (lfname, fn);
360 lock_superlock (lfname);
362 if (current_lock_owner_1 (lfname) == getpid ())
365 unlink ((char *) XSTRING_DATA (Vsuperlock_file));
369 lock_superlock (CONST char *lfname)
374 for (i = -20; i < 0 &&
375 (fd = open ((char *) XSTRING_DATA (Vsuperlock_file),
376 O_WRONLY | O_EXCL | O_CREAT, 0666)) < 0;
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));
393 #if defined(WINDOWSNT)
394 chmod(lfname, _S_IREAD|_S_IWRITE);
396 chmod ((char *) XSTRING_DATA (Vsuperlock_file), 0666);
400 write (fd, lfname, strlen (lfname));
406 unlock_all_files (void)
408 /* This function can GC. */
411 REGISTER struct buffer *b;
415 for (tail = Vbuffer_alist; GC_CONSP (tail);
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);
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.
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. */
440 fn = current_buffer->file_truename;
442 if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
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.
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. */
459 if (BUF_SAVE_MODIFF (current_buffer) < BUF_MODIFF (current_buffer)
460 && STRINGP (current_buffer->file_truename))
461 unlock_file (current_buffer->file_truename);
466 /* Unlock the file visited in buffer BUFFER. */
469 unlock_buffer (struct buffer *buffer)
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);
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.
486 /* This function can GC */
487 REGISTER char *lfname;
490 if (NILP (Vlock_directory) || NILP (Vsuperlock_file))
492 CHECK_STRING (Vlock_directory);
494 fn = Fexpand_file_name (fn, Qnil);
496 MAKE_LOCK_NAME (lfname, fn);
498 owner = current_lock_owner (lfname);
501 else if (owner == getpid ())
504 return lock_file_owner_name (lfname);
508 syms_of_filelock (void)
510 /* This function can GC */
511 DEFSUBR (Funlock_buffer);
512 DEFSUBR (Flock_buffer);
513 DEFSUBR (Ffile_locked_p);
515 defsymbol (&Qask_user_about_supersession_threat,
516 "ask-user-about-supersession-threat");
517 defsymbol (&Qask_user_about_lock, "ask-user-about-lock");
521 vars_of_filelock (void)
523 DEFVAR_LISP ("lock-directory", &Vlock_directory /*
526 Vlock_directory = Qnil;
527 DEFVAR_LISP ("superlock-file", &Vsuperlock_file /*
530 Vsuperlock_file = Qnil;
534 complex_vars_of_filelock (void)
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.
540 #ifdef PATH_SUPERLOCK
541 Vconfigure_superlock_file = build_string (PATH_SUPERLOCK);
543 Vconfigure_superlock_file = Qnil;
545 /* All the rest done dynamically by startup.el */