Commit 7075ebbf authored by Michael Albinus's avatar Michael Albinus
Browse files

Make remote file locks more robust

* lisp/net/tramp.el (tramp-handle-write-region):
* lisp/net/tramp-adb.el (tramp-adb-handle-write-region):
* lisp/net/tramp-smb.el (tramp-smb-handle-write-region):
* lisp/net/tramp-sshfs.el (tramp-sshfs-handle-write-region):
Make file locks more robust.

* test/lisp/net/tramp-tests.el (tramp-test39-make-lock-file-name):
Rename and extend.
parent 1bd012ce
Pipeline #11463 failed with stages
in 58 seconds
...@@ -549,14 +549,14 @@ But handle the case, if the \"test\" command is not available." ...@@ -549,14 +549,14 @@ But handle the case, if the \"test\" command is not available."
(format "File %s exists; overwrite anyway? " filename))))) (format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename)) (tramp-error v 'file-already-exists filename))
(let (file-locked (let ((file-locked (eq (file-locked-p lockname) t))
(curbuf (current-buffer)) (curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename))) (tmpfile (tramp-compat-make-temp-file filename)))
;; Lock file. ;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
(file-remote-p lockname) (file-remote-p lockname)
(not (eq (file-locked-p lockname) t))) (not file-locked))
(setq file-locked t) (setq file-locked t)
;; `lock-file' exists since Emacs 28.1. ;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname)) (tramp-compat-funcall 'lock-file lockname))
...@@ -592,7 +592,7 @@ But handle the case, if the \"test\" command is not available." ...@@ -592,7 +592,7 @@ But handle the case, if the \"test\" command is not available."
(current-time)))) (current-time))))
;; Unlock file. ;; Unlock file.
(when (and file-locked (eq (file-locked-p lockname) t)) (when file-locked
;; `unlock-file' exists since Emacs 28.1. ;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname)) (tramp-compat-funcall 'unlock-file lockname))
......
...@@ -1589,14 +1589,14 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ...@@ -1589,14 +1589,14 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
(format "File %s exists; overwrite anyway? " filename))))) (format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename)) (tramp-error v 'file-already-exists filename))
(let (file-locked (let ((file-locked (eq (file-locked-p lockname) t))
(curbuf (current-buffer)) (curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename))) (tmpfile (tramp-compat-make-temp-file filename)))
;; Lock file. ;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
(file-remote-p lockname) (file-remote-p lockname)
(not (eq (file-locked-p lockname) t))) (not file-locked))
(setq file-locked t) (setq file-locked t)
;; `lock-file' exists since Emacs 28.1. ;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname)) (tramp-compat-funcall 'lock-file lockname))
...@@ -1635,7 +1635,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ...@@ -1635,7 +1635,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
(current-time)))) (current-time))))
;; Unlock file. ;; Unlock file.
(when (and file-locked (eq (file-locked-p lockname) t)) (when file-locked
;; `unlock-file' exists since Emacs 28.1. ;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname)) (tramp-compat-funcall 'unlock-file lockname))
......
...@@ -295,12 +295,12 @@ arguments to pass to the OPERATION." ...@@ -295,12 +295,12 @@ arguments to pass to the OPERATION."
(format "File %s exists; overwrite anyway? " filename))))) (format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename)) (tramp-error v 'file-already-exists filename))
(let (file-locked) (let ((file-locked (eq (file-locked-p lockname) t)))
;; Lock file. ;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
(file-remote-p lockname) (file-remote-p lockname)
(not (eq (file-locked-p lockname) t))) (not file-locked))
(setq file-locked t) (setq file-locked t)
;; `lock-file' exists since Emacs 28.1. ;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname)) (tramp-compat-funcall 'lock-file lockname))
...@@ -311,7 +311,7 @@ arguments to pass to the OPERATION." ...@@ -311,7 +311,7 @@ arguments to pass to the OPERATION."
(tramp-flush-file-properties v localname)) (tramp-flush-file-properties v localname))
;; Unlock file. ;; Unlock file.
(when (and file-locked (eq (file-locked-p lockname) t)) (when file-locked
;; `unlock-file' exists since Emacs 28.1. ;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname)) (tramp-compat-funcall 'unlock-file lockname))
......
...@@ -4463,7 +4463,7 @@ of." ...@@ -4463,7 +4463,7 @@ of."
(format "File %s exists; overwrite anyway? " filename))))) (format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename)) (tramp-error v 'file-already-exists filename))
(let (file-locked (let ((file-locked (eq (file-locked-p lockname) t))
(tmpfile (tramp-compat-make-temp-file filename)) (tmpfile (tramp-compat-make-temp-file filename))
(modes (tramp-default-file-modes (modes (tramp-default-file-modes
filename (and (eq mustbenew 'excl) 'nofollow))) filename (and (eq mustbenew 'excl) 'nofollow)))
...@@ -4477,7 +4477,7 @@ of." ...@@ -4477,7 +4477,7 @@ of."
;; Lock file. ;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) (when (and (not (auto-save-file-name-p (file-name-nondirectory filename)))
(file-remote-p lockname) (file-remote-p lockname)
(not (eq (file-locked-p lockname) t))) (not file-locked))
(setq file-locked t) (setq file-locked t)
;; `lock-file' exists since Emacs 28.1. ;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname)) (tramp-compat-funcall 'lock-file lockname))
...@@ -4515,7 +4515,7 @@ of." ...@@ -4515,7 +4515,7 @@ of."
(tramp-set-file-uid-gid filename uid gid) (tramp-set-file-uid-gid filename uid gid)
;; Unlock file. ;; Unlock file.
(when (and file-locked (eq (file-locked-p lockname) t)) (when file-locked
;; `unlock-file' exists since Emacs 28.1. ;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname)) (tramp-compat-funcall 'unlock-file lockname))
......
...@@ -2466,7 +2466,8 @@ This checks also `file-name-as-directory', `file-name-directory', ...@@ -2466,7 +2466,8 @@ This checks also `file-name-as-directory', `file-name-directory',
"^\\'") "^\\'")
tramp--test-messages)))))))) tramp--test-messages))))))))
;; We do not test lockname here. See `tramp-test39-lock-file'. ;; We do not test lockname here. See
;; `tramp-test39-make-lock-file-name'.
;; Do not overwrite if excluded. ;; Do not overwrite if excluded.
(cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always) (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always)
...@@ -5746,8 +5747,8 @@ Use direct async.") ...@@ -5746,8 +5747,8 @@ Use direct async.")
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)))))
;; The functions were introduced in Emacs 28.1. ;; The functions were introduced in Emacs 28.1.
(ert-deftest tramp-test39-lock-file () (ert-deftest tramp-test39-make-lock-file-name ()
"Check `lock-file', `unlock-file' and `file-locked-p'." "Check `make-lock-file-name', `lock-file', `unlock-file' and `file-locked-p'."
(skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-ange-ftp-p))) (skip-unless (not (tramp--test-ange-ftp-p)))
;; Since Emacs 28.1. ;; Since Emacs 28.1.
...@@ -5783,6 +5784,15 @@ Use direct async.") ...@@ -5783,6 +5784,15 @@ Use direct async.")
(with-no-warnings (lock-file tmp-name1)) (with-no-warnings (lock-file tmp-name1))
(should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) (should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
;; `save-buffer' removes the lock.
(with-temp-buffer
(set-visited-file-name tmp-name1)
(insert "foo")
(save-buffer))
(should-not (with-no-warnings (file-locked-p tmp-name1)))
(with-no-warnings (lock-file tmp-name1))
(should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
;; A new connection changes process id, and also the ;; A new connection changes process id, and also the
;; lockname contents. ;; lockname contents.
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
...@@ -5838,8 +5848,7 @@ Use direct async.") ...@@ -5838,8 +5848,7 @@ Use direct async.")
(should-error (should-error
(set-visited-file-name tmp-name1) (set-visited-file-name tmp-name1)
:type 'file-locked))) :type 'file-locked)))
(should (stringp (with-no-warnings (file-locked-p tmp-name1)))) (should (stringp (with-no-warnings (file-locked-p tmp-name1)))))
(should-not (file-exists-p tmp-name1)))
;; Cleanup. ;; Cleanup.
(ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-file tmp-name1))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment