bug#49261: 28.0.50; File Locking Breaks Presumptuous Toolchains

[Lars Ingebrigtsen <larsi@gnus.org>]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> If not, I'll get to it early next week.

Is Wednesday still "early"?

Anyway, I've now implemented this.  The biggest part of this is
refactoring out the `auto-save-file-name-transforms' handling so that it
can be used by the lock handling code, too.

I'd like to have more eyes on this before I commit.  It seems to work
fine after some light testing, but I'm not completely confident about
the ENCODE_FILE/ALLOCA bits in the C code.

So if somebody could give that a look-over while I'm writing up the
documentation, that'd be great.  :-)

diff --git a/lisp/files.el b/lisp/files.el
index 859c193db9..ba588842a2 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -412,6 +412,21 @@ auto-save-file-name-transforms
   :initialize 'custom-initialize-delay
   :version "21.1")
 
+(defcustom lock-file-name-transforms nil
+  "Transforms to apply to buffer file name before making a lock file name.
+This has the same syntax as
+`auto-save-file-name-transforms' (which see), but instead of
+applying to auto-save file names, it's applied to lock file names.
+
+By default, a lock file is put into the same directory as the
+file it's locking, and it has the same name, but with \".#\" prepended."
+  :group 'files
+  :type '(repeat (list (regexp :tag "Regexp")
+                       (string :tag "Replacement")
+		       (boolean :tag "Uniquify")))
+  :initialize 'custom-initialize-delay
+  :version "28.1")
+
 (defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.")
 
 (defcustom auto-save-visited-interval 5
@@ -6668,63 +6683,11 @@ make-auto-save-file-name
 					     'make-auto-save-file-name)))
 	(if handler
 	    (funcall handler 'make-auto-save-file-name)
-	  (let ((list auto-save-file-name-transforms)
-		(filename buffer-file-name)
-		result uniq)
-	    ;; Apply user-specified translations
-	    ;; to the file name.
-	    (while (and list (not result))
-	      (if (string-match (car (car list)) filename)
-		  (setq result (replace-match (cadr (car list)) t nil
-					      filename)
-			uniq (car (cddr (car list)))))
-	      (setq list (cdr list)))
-	    (if result
-                (setq filename
-                      (cond
-                       ((memq uniq (secure-hash-algorithms))
-                        (concat
-                         (file-name-directory result)
-                         (secure-hash uniq filename)))
-                       (uniq
-                        (concat
-			 (file-name-directory result)
-			 (subst-char-in-string
-			  ?/ ?!
-			  (replace-regexp-in-string
-                           "!" "!!" filename))))
-		       (t result))))
-	    (setq result
-		  (if (and (eq system-type 'ms-dos)
-			   (not (msdos-long-file-names)))
-		      ;; We truncate the file name to DOS 8+3 limits
-		      ;; before doing anything else, because the regexp
-		      ;; passed to string-match below cannot handle
-		      ;; extensions longer than 3 characters, multiple
-		      ;; dots, and other atrocities.
-		      (let ((fn (dos-8+3-filename
-				 (file-name-nondirectory buffer-file-name))))
-			(string-match
-			 "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'"
-			 fn)
-			(concat (file-name-directory buffer-file-name)
-				"#" (match-string 1 fn)
-				"." (match-string 3 fn) "#"))
-		    (concat (file-name-directory filename)
-			    "#"
-			    (file-name-nondirectory filename)
-			    "#")))
-	    ;; Make sure auto-save file names don't contain characters
-	    ;; invalid for the underlying filesystem.
-	    (if (and (memq system-type '(ms-dos windows-nt cygwin))
-		     ;; Don't modify remote filenames
-                     (not (file-remote-p result)))
-		(convert-standard-filename result)
-	      result))))
-
+          (auto-save--transform-file-name buffer-file-name
+                                          auto-save-file-name-transforms
+                                          "#" "#")))
     ;; Deal with buffers that don't have any associated files.  (Mail
     ;; mode tends to create a good number of these.)
-
     (let ((buffer-name (buffer-name))
 	  (limit 0)
 	  file-name)
@@ -6772,6 +6735,71 @@ make-auto-save-file-name
 	(file-error nil))
       file-name)))
 
+(defun auto-save--transform-file-name (filename transforms
+                                                prefix suffix)
+  "Transform FILENAME according to TRANSFORMS.
+See `auto-save-file-name-transforms' for the format of
+TRANSFORMS.  PREFIX is prepended to the non-directory portion of
+the resulting file name, and SUFFIX is appended."
+  (let (result uniq)
+    ;; Apply user-specified translations
+    ;; to the file name.
+    (while (and transforms (not result))
+      (if (string-match (car (car transforms)) filename)
+	  (setq result (replace-match (cadr (car transforms)) t nil
+				      filename)
+		uniq (car (cddr (car transforms)))))
+      (setq transforms (cdr transforms)))
+    (when result
+      (setq filename
+            (cond
+             ((memq uniq (secure-hash-algorithms))
+              (concat
+               (file-name-directory result)
+               (secure-hash uniq filename)))
+             (uniq
+              (concat
+	       (file-name-directory result)
+	       (subst-char-in-string
+		?/ ?!
+		(replace-regexp-in-string
+                 "!" "!!" filename))))
+	     (t result))))
+    (setq result
+	  (if (and (eq system-type 'ms-dos)
+		   (not (msdos-long-file-names)))
+	      ;; We truncate the file name to DOS 8+3 limits
+	      ;; before doing anything else, because the regexp
+	      ;; passed to string-match below cannot handle
+	      ;; extensions longer than 3 characters, multiple
+	      ;; dots, and other atrocities.
+	      (let ((fn (dos-8+3-filename
+			 (file-name-nondirectory buffer-file-name))))
+		(string-match
+		 "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'"
+		 fn)
+		(concat (file-name-directory buffer-file-name)
+			prefix (match-string 1 fn)
+			"." (match-string 3 fn) suffix))
+	    (concat (file-name-directory filename)
+		    prefix
+		    (file-name-nondirectory filename)
+		    suffix)))
+    ;; Make sure auto-save file names don't contain characters
+    ;; invalid for the underlying filesystem.
+    (if (and (memq system-type '(ms-dos windows-nt cygwin))
+	     ;; Don't modify remote filenames
+             (not (file-remote-p result)))
+	(convert-standard-filename result)
+      result)))
+
+(defun make-lock-file-name (filename)
+  "Make a lock file name for FILENAME.
+By default, this just prepends \".*\" to the non-directory part
+of FILENAME, but the transforms in `lock-file-name-transforms'
+are done first."
+  (auto-save--transform-file-name filename lock-file-name-transforms ".#" ""))
+
 (defun auto-save-file-name-p (filename)
   "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'.
 FILENAME should lack slashes.
diff --git a/src/filelock.c b/src/filelock.c
index 446a262a1c..3c6e6b4942 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -294,25 +294,6 @@ get_boot_time_1 (const char *filename, bool newest)
   char user[MAX_LFINFO + 1 + sizeof " (pid )" - sizeof "."];
 } lock_info_type;
 
-/* Write the name of the lock file for FNAME into LOCKNAME.  Length
-   will be that of FNAME plus two more for the leading ".#", plus one
-   for the null.  */
-#define MAKE_LOCK_NAME(lockname, fname) \
-  (lockname = SAFE_ALLOCA (SBYTES (fname) + 2 + 1), \
-   fill_in_lock_file_name (lockname, fname))
-
-static void
-fill_in_lock_file_name (char *lockfile, Lisp_Object fn)
-{
-  char *last_slash = memrchr (SSDATA (fn), '/', SBYTES (fn));
-  char *base = last_slash + 1;
-  ptrdiff_t dirlen = base - SSDATA (fn);
-  memcpy (lockfile, SSDATA (fn), dirlen);
-  lockfile[dirlen] = '.';
-  lockfile[dirlen + 1] = '#';
-  strcpy (lockfile + dirlen + 2, base);
-}
-
 /* For some reason Linux kernels return EPERM on file systems that do
    not support hard or symbolic links.  This symbol documents the quirk.
    There is no way to tell whether a symlink call fails due to
@@ -639,6 +620,12 @@ lock_if_free (lock_info_type *clasher, char *lfname)
   return err;
 }
 
+static Lisp_Object
+make_lock_file_name (Lisp_Object fn)
+{
+  return ENCODE_FILE (call1 (intern ("make-lock-file-name"), fn));
+}
+
 /* 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
@@ -660,10 +647,9 @@ lock_if_free (lock_info_type *clasher, char *lfname)
 void
 lock_file (Lisp_Object fn)
 {
-  Lisp_Object orig_fn, encoded_fn;
+  Lisp_Object orig_fn;
   char *lfname = NULL;
   lock_info_type lock_info;
-  USE_SAFE_ALLOCA;
 
   /* Don't do locking while dumping Emacs.
      Uncompressing wtmp files uses call-process, which does not work
@@ -672,29 +658,25 @@ lock_file (Lisp_Object fn)
     return;
 
   orig_fn = fn;
-  fn = Fexpand_file_name (fn, Qnil);
+  fn = make_lock_file_name (Fexpand_file_name (fn, Qnil));
 #ifdef WINDOWSNT
   /* Ensure we have only '/' separators, to avoid problems with
      looking (inside fill_in_lock_file_name) for backslashes in file
      names encoded by some DBCS codepage.  */
   dostounix_filename (SSDATA (fn));
 #endif
-  encoded_fn = ENCODE_FILE (fn);
-  if (create_lockfiles)
-    /* Create the name of the lock-file for file fn */
-    MAKE_LOCK_NAME (lfname, encoded_fn);
-
+  lfname = SSDATA (fn);
   /* See if this file is visited and has changed on disk since it was
      visited.  */
   Lisp_Object subject_buf = get_truename_buffer (orig_fn);
   if (!NILP (subject_buf)
       && NILP (Fverify_visited_file_modtime (subject_buf))
       && !NILP (Ffile_exists_p (fn))
-      && !(lfname && current_lock_owner (NULL, lfname) == -2))
+      && !(create_lockfiles && current_lock_owner (NULL, lfname) == -2))
     call1 (intern ("userlock--ask-user-about-supersession-threat"), fn);
 
   /* Don't do locking if the user has opted out.  */
-  if (lfname)
+  if (create_lockfiles)
     {
       /* Try to lock the lock.  FIXME: This ignores errors when
 	 lock_if_free returns a positive errno value.  */
@@ -715,7 +697,6 @@ lock_file (Lisp_Object fn)
 	  if (!NILP (attack))
 	    lock_file_1 (lfname, 1);
 	}
-      SAFE_FREE ();
     }
 }
 
@@ -723,12 +704,9 @@ lock_file (Lisp_Object fn)
 unlock_file_body (Lisp_Object fn)
 {
   char *lfname;
-  USE_SAFE_ALLOCA;
-
-  Lisp_Object filename = Fexpand_file_name (fn, Qnil);
-  fn = ENCODE_FILE (filename);
 
-  MAKE_LOCK_NAME (lfname, fn);
+  Lisp_Object filename = make_lock_file_name (Fexpand_file_name (fn, Qnil));
+  lfname = SSDATA (filename);
 
   int err = current_lock_owner (0, lfname);
   if (err == -2 && unlink (lfname) != 0 && errno != ENOENT)
@@ -736,7 +714,6 @@ unlock_file_body (Lisp_Object fn)
   if (0 < err)
     report_file_errno ("Unlocking file", filename, err);
 
-  SAFE_FREE ();
   return Qnil;
 }
 
@@ -842,11 +819,10 @@ DEFUN ("file-locked-p", Ffile_locked_p, Sfile_locked_p, 1, 1, 0,
   char *lfname;
   int owner;
   lock_info_type locker;
-  USE_SAFE_ALLOCA;
 
   filename = Fexpand_file_name (filename, Qnil);
-  Lisp_Object encoded_filename = ENCODE_FILE (filename);
-  MAKE_LOCK_NAME (lfname, encoded_filename);
+  Lisp_Object lockname = make_lock_file_name (filename);
+  lfname = SSDATA (lockname);
 
   owner = current_lock_owner (&locker, lfname);
   switch (owner)
@@ -857,7 +833,6 @@ DEFUN ("file-locked-p", Ffile_locked_p, Sfile_locked_p, 1, 1, 0,
     default: report_file_errno ("Testing file lock", filename, owner);
     }
 
-  SAFE_FREE ();
   return ret;
 #endif
 }
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 257cbc2d32..b97e0256fb 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -949,6 +949,44 @@ files-tests-file-name-non-special-make-auto-save-file-name
                              (make-auto-save-file-name)
                            (kill-buffer)))))))
 
+(ert-deftest files-test-auto-save-name-default ()
+  (with-temp-buffer
+    (let ((auto-save-file-name-transforms nil))
+      (setq buffer-file-name "/tmp/foo.txt")
+      (should (equal (make-auto-save-file-name) "/tmp/#foo.txt#")))))
+
+(ert-deftest files-test-auto-save-name-transform ()
+  (with-temp-buffer
+    (setq buffer-file-name "/tmp/foo.txt")
+    (let ((auto-save-file-name-transforms
+           '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" nil))))
+      (should (equal (make-auto-save-file-name) "/var/tmp/#foo.txt#")))))
+
+(ert-deftest files-test-auto-save-name-unique ()
+  (with-temp-buffer
+    (setq buffer-file-name "/tmp/foo.txt")
+    (let ((auto-save-file-name-transforms
+           '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))))
+      (should (equal (make-auto-save-file-name) "/var/tmp/#!tmp!foo.txt#")))
+    (let ((auto-save-file-name-transforms
+           '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))))
+      (should (equal (make-auto-save-file-name)
+                     "/var/tmp/#b57c5a04f429a83305859d3350ecdab8315a9037#")))))
+
+(ert-deftest files-test-lock-name-default ()
+  (let ((lock-file-name-transforms nil))
+    (should (equal (make-lock-file-name "/tmp/foo.txt") "/tmp/.#foo.txt"))))
+
+(ert-deftest files-test-lock-name-unique ()
+  (let ((lock-file-name-transforms
+         '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))))
+    (should (equal (make-lock-file-name "/tmp/foo.txt")
+                   "/var/tmp/.#!tmp!foo.txt")))
+  (let ((lock-file-name-transforms
+           '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))))
+    (should (equal (make-lock-file-name "/tmp/foo.txt")
+                   "/var/tmp/.#b57c5a04f429a83305859d3350ecdab8315a9037"))))
+
 (ert-deftest files-tests-file-name-non-special-make-directory ()
   (files-tests--with-temp-non-special (tmpdir nospecial-dir t)
     (let ((default-directory nospecial-dir))


-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no