[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master d35868b: Implement file locks for remote files (Bug#49261)
|
From: |
Michael Albinus |
|
Subject: |
master d35868b: Implement file locks for remote files (Bug#49261) |
|
Date: |
Wed, 7 Jul 2021 12:37:02 -0400 (EDT) |
branch: master
commit d35868bec96718705c9bc8aaac3bc583c837033f
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>
Implement file locks for remote files (Bug#49261)
* doc/lispref/files.texi (Magic File Names): Add file-locked-p,
lock-file and unlock-file.
* etc/NEWS: Tramp supports file locks now.
* lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-adb-handle-write-region): Handle LOCKNAME.
* lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
* lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-crypt-handle-file-locked-p, tramp-crypt-handle-lock-file)
(tramp-crypt-handle-unlock-file): New defun.
* lisp/net/tramp-fuse.el (tramp-fuse-mounted-p): Simplify.
(tramp-fuse-unmount): New defun.
* lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-gvfs-maybe-open-connection): Set "lock-pid" connection property.
* lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-rclone-maybe-open-connection): Set "lock-pid" connection property.
* lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-sh-handle-write-region): Handle LOCKNAME.
* lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-smb-handle-copy-directory): Use `sleep-for'.
(tramp-smb-handle-write-region): Handle LOCKNAME.
* lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-sshfs-handle-write-region): Handle LOCKNAME.
(tramp-sshfs-maybe-open-connection): Set "lock-pid" connection property.
* lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-sudoedit-maybe-open-connection):
Set "lock-pid" connection property.
* lisp/net/tramp.el (tramp-file-name-for-operation):
Add `file-locked-p', `lock-file' and `unlock-file'.
(tramp-make-lock-name, tramp-get-lock-file, tramp-get-lock-pid)
(tramp-handle-file-locked-p, tramp-handle-lock-file)
(tramp-handle-unlock-file): New defuns.
(tramp-lock-file-contents-regexp): New regexp.
(tramp-handle-write-region): Handle LOCKNAME.
* src/filelock.c (lock_file, unlock_file_body, Ffile_locked_p):
Call handler if exists.
(Flock_file, Funlock_file): New defuns.
(Qlock_file, Qunlock_file, Qfile_locked_p): Declare symbols.
(Slock_file, Sunlock_file): Declare subroutines.
* test/lisp/net/tramp-archive-tests.el
(tramp-archive-test40-make-nearby-temp-file)
(tramp-archive-test43-file-system-info): Rename.
* test/lisp/net/tramp-tests.el (top): Set `create-lockfiles' to nil.
(tramp--test-fuse-p): New defun.
(tramp-test14-delete-directory): Use it.
(tramp-test39-lock-file): New test.
(tramp-test40-make-nearby-temp-file)
(tramp-test41-special-characters)
(tramp-test41-special-characters-with-stat)
(tramp-test41-special-characters-with-perl)
(tramp-test41-special-characters-with-ls, tramp-test42-utf8)
(tramp-test42-utf8-with-stat, tramp-test42-utf8-with-perl)
(tramp-test42-utf8-with-ls, tramp-test43-file-system-info)
(tramp-test44-asynchronous-requests, tramp-test45-auto-load)
(tramp-test45-delay-load, tramp-test45-recursive-load)
(tramp-test45-remote-load-path, tramp-test46-unload): Rename.
(tramp--test-special-characters, tramp--test-utf8)
(tramp--test-asynchronous-requests-timeout): Modify docstring.
---
doc/lispref/files.texi | 10 +--
etc/NEWS | 6 +-
lisp/net/tramp-adb.el | 30 +++++++--
lisp/net/tramp-archive.el | 3 +
lisp/net/tramp-cache.el | 2 +
lisp/net/tramp-crypt.el | 18 +++++
lisp/net/tramp-fuse.el | 17 +++--
lisp/net/tramp-gvfs.el | 6 ++
lisp/net/tramp-rclone.el | 7 ++
lisp/net/tramp-sh.el | 26 +++++++-
lisp/net/tramp-smb.el | 28 ++++++--
lisp/net/tramp-sshfs.el | 46 ++++++++++---
lisp/net/tramp-sudoedit.el | 7 ++
lisp/net/tramp.el | 109 +++++++++++++++++++++++++++---
src/filelock.c | 58 +++++++++++++++-
test/lisp/net/tramp-archive-tests.el | 4 +-
test/lisp/net/tramp-tests.el | 125 ++++++++++++++++++++++++++++-------
17 files changed, 432 insertions(+), 70 deletions(-)
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 5238597..ae763a2 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -3273,7 +3273,7 @@ first, before handlers for jobs such as remote file
access.
@code{file-equal-p},
@code{file-executable-p}, @code{file-exists-p},
@code{file-in-directory-p},
-@code{file-local-copy},
+@code{file-local-copy}, @code{file-locked-p},
@code{file-modes}, @code{file-name-all-completions},
@code{file-name-as-directory},
@code{file-name-case-insensitive-p},
@@ -3292,7 +3292,7 @@ first, before handlers for jobs such as remote file
access.
@code{get-file-buffer},
@code{insert-directory},
@code{insert-file-contents},@*
-@code{load},
+@code{load}, @code{lock-file},
@code{make-auto-save-file-name},
@code{make-directory},
@code{make-directory-internal},
@@ -3307,6 +3307,7 @@ first, before handlers for jobs such as remote file
access.
@code{substitute-in-file-name},@*
@code{temporary-file-directory},
@code{unhandled-file-name-directory},
+@code{unlock-file},
@code{vc-registered},
@code{verify-visited-file-modtime},@*
@code{write-region}.
@@ -3331,7 +3332,7 @@ first, before handlers for jobs such as remote file
access.
@code{file-equal-p},
@code{file-executable-p}, @code{file-exists-p},
@code{file-in-directory-p},
-@code{file-local-copy},
+@code{file-local-copy}, @code{file-locked-p},
@code{file-modes}, @code{file-name-all-completions},
@code{file-name-as-directory},
@code{file-name-case-insensitive-p},
@@ -3350,7 +3351,7 @@ first, before handlers for jobs such as remote file
access.
@code{get-file-buffer},
@code{insert-directory},
@code{insert-file-contents},
-@code{load},
+@code{load}, @code{lock-file},
@code{make-auto-save-file-name},
@code{make-direc@discretionary{}{}{}tory},
@code{make-direc@discretionary{}{}{}tory-internal},
@@ -3363,6 +3364,7 @@ first, before handlers for jobs such as remote file
access.
@code{start-file-process},
@code{substitute-in-file-name},
@code{unhandled-file-name-directory},
+@code{unlock-file},
@code{vc-regis@discretionary{}{}{}tered},
@code{verify-visited-file-modtime},
@code{write-region}.
diff --git a/etc/NEWS b/etc/NEWS
index 7bf8c1d..0e8a846 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -323,6 +323,7 @@ emulators by using the new input-meta-mode with the special
value
** New frame parameter 'drag-with-tab-line'.
This parameter, similar to 'drag-with-header-line', allows moving frames
by dragging the tab lines of their topmost windows with the mouse.
+
* Editing Changes in Emacs 28.1
@@ -1467,6 +1468,9 @@ rare cases) Tramp blocks Emacs, and we need further debug
information.
directory must be confirmed. In order to suppress this confirmation,
set user option 'tramp-allow-unsafe-temporary-files' to t.
++++
+*** Tramp supports file locks now.
+
** Tempo
---
@@ -2932,7 +2936,7 @@ The former is now declared obsolete.
* Lisp Changes in Emacs 28.1
---
-*** :safe settings in 'defcustom' are now propagated to the loaddefs files.
+*** ':safe' settings in 'defcustom' are now propagated to the loaddefs files.
+++
** New function 'syntax-class-to-char'.
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index f956952..9c1c8ac 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -133,6 +133,7 @@ It is used for TCP/IP devices."
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-adb-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-adb-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -159,6 +160,7 @@ It is used for TCP/IP devices."
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-adb-handle-make-directory)
(make-directory-internal . ignore)
@@ -180,6 +182,7 @@ It is used for TCP/IP devices."
(tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-adb-handle-write-region))
@@ -533,9 +536,10 @@ But handle the case, if the \"test\" command is not
available."
rw-path)))))))
(defun tramp-adb-handle-write-region
- (start end filename &optional append visit _lockname mustbenew)
+ (start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -544,15 +548,26 @@ But handle the case, if the \"test\" command is not
available."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let* ((curbuf (current-buffer))
+ (let* ((auto-saving
+ (string-match-p "^#.+#$" (file-name-nondirectory filename)))
+ file-locked
+ (curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
+
+ ;; Lock file.
+ (when (and (not auto-saving) (file-remote-p lockname)
+ (not (eq (file-locked-p lockname) t)))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok)
(set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600)))
(write-region start end tmpfile append 'no-message)
(with-tramp-progress-reporter
- v 3 (format-message
- "Moving tmp file `%s' to `%s'" tmpfile filename)
+ v 3 (format-message
+ "Moving tmp file `%s' to `%s'" tmpfile filename)
(unwind-protect
(unless (tramp-adb-execute-adb-command
v "push" tmpfile (tramp-compat-file-name-unquote
localname))
@@ -575,6 +590,11 @@ But handle the case, if the \"test\" command is not
available."
(file-attributes filename))
(current-time))))
+ ;; Unlock file.
+ (when (and file-locked (eq (file-locked-p lockname) t))
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
;; The end.
(when (and (null noninteractive)
(or (eq visit t) (null visit) (stringp visit)))
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index d723fd5..a6f479b 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -236,6 +236,7 @@ It must be supported by libarchive(3).")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-archive-handle-file-local-copy)
+ (file-locked-p . ignore)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions .
tramp-archive-handle-file-name-all-completions)
;; `file-name-as-directory' performed by default handler.
@@ -262,6 +263,7 @@ It must be supported by libarchive(3).")
(insert-directory . tramp-archive-handle-insert-directory)
(insert-file-contents . tramp-archive-handle-insert-file-contents)
(load . tramp-archive-handle-load)
+ (lock-file . ignore)
(make-auto-save-file-name . ignore)
(make-directory . tramp-archive-handle-not-implemented)
(make-directory-internal . tramp-archive-handle-not-implemented)
@@ -283,6 +285,7 @@ It must be supported by libarchive(3).")
(tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-archive-handle-not-implemented))
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index a41620a..579234f 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -49,6 +49,8 @@
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
+;; "lock-pid" is the timestamp a (network) process is created, it is
+;; used instead of the pid in file locks.
;;
;; - The key is nil. These are temporary properties related to the
;; local machine. Examples: "parse-passwd" and "parse-group" keep
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index 1d8c0ad..31988bc 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -182,6 +182,7 @@ If NAME doesn't belong to a crypted remote directory, retun
nil."
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-crypt-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-crypt-handle-file-name-all-completions)
;; `file-name-as-directory' performed by default handler.
@@ -208,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun
nil."
(insert-directory . tramp-crypt-handle-insert-directory)
;; `insert-file-contents' performed by default handler.
(load . tramp-handle-load)
+ (lock-file . tramp-crypt-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-crypt-handle-make-directory)
(make-directory-internal . ignore)
@@ -229,6 +231,7 @@ If NAME doesn't belong to a crypted remote directory, retun
nil."
;; `tramp-get-remote-uid' performed by default handler.
(tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-crypt-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -734,6 +737,11 @@ absolute file names."
(let (tramp-crypt-enabled)
(file-executable-p (tramp-crypt-encrypt-file-name filename))))
+(defun tramp-crypt-handle-file-locked-p (filename)
+ "Like `file-locked-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-locked-p (tramp-crypt-encrypt-file-name filename))))
+
(defun tramp-crypt-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
(all-completions
@@ -797,6 +805,11 @@ WILDCARD is not supported."
(delete-region (prop-match-beginning match) (prop-match-end match))
(insert (propertize string 'dired-filename t)))))))
+(defun tramp-crypt-handle-lock-file (filename)
+ "Like `lock-file' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (lock-file (tramp-crypt-encrypt-file-name filename))))
+
(defun tramp-crypt-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name dir) nil
@@ -848,6 +861,11 @@ WILDCARD is not supported."
(tramp-set-file-uid-gid
(tramp-crypt-encrypt-file-name filename) uid gid))))
+(defun tramp-crypt-handle-unlock-file (filename)
+ "Like `unlock-file' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (unlock-file (tramp-crypt-encrypt-file-name filename))))
+
(add-hook 'tramp-unload-hook
(lambda ()
(unload-feature 'tramp-crypt 'force)))
diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el
index ec1db86..93b184a 100644
--- a/lisp/net/tramp-fuse.el
+++ b/lisp/net/tramp-fuse.el
@@ -164,10 +164,9 @@
(or (tramp-get-connection-property
(tramp-get-connection-process vec) "mounted" nil)
(let* ((default-directory (tramp-compat-temporary-file-directory))
- (fuse (concat "fuse." (tramp-file-name-method vec)))
- (mount (shell-command-to-string (format "mount -t %s" fuse))))
- (tramp-message vec 6 "%s %s" "mount -t" fuse)
- (tramp-message vec 6 "\n%s" mount)
+ (command (format "mount -t fuse.%s" (tramp-file-name-method
vec)))
+ (mount (shell-command-to-string command)))
+ (tramp-message vec 6 "%s\n%s" command mount)
(tramp-set-connection-property
(tramp-get-connection-process vec) "mounted"
(when (string-match
@@ -176,6 +175,16 @@
mount)
(match-string 1 mount)))))))
+(defun tramp-fuse-unmount (vec)
+ "Unmount fuse volume determined by VEC."
+ (let ((default-directory (tramp-compat-temporary-file-directory))
+ (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec))))
+ (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command))
+ (tramp-flush-connection-property
+ (tramp-get-connection-process vec) "mounted")
+ ;; Give the caches a chance to expire.
+ (sleep-for 1)))
+
(defun tramp-fuse-local-file-name (filename)
"Return local mount name of FILENAME."
(setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index f1d24dc..e784ea8 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -774,6 +774,7 @@ It has been changed in GVFS 1.14.")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-gvfs-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -800,6 +801,7 @@ It has been changed in GVFS 1.14.")
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-gvfs-handle-make-directory)
(make-directory-internal . ignore)
@@ -821,6 +823,7 @@ It has been changed in GVFS 1.14.")
(tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -2144,6 +2147,9 @@ connection if a previous connection has died for some
reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 3b6de3e..6c710dd 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -96,6 +96,7 @@
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-fuse-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -122,6 +123,7 @@
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-fuse-handle-make-directory)
(make-directory-internal . ignore)
@@ -143,6 +145,7 @@
(tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -358,6 +361,10 @@ connection if a previous connection has died for some
reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property
+ p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 5f597ff..1103722 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -962,6 +962,7 @@ Format specifiers \"%s\" are replaced before the script is
used.")
(file-exists-p . tramp-sh-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-sh-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-sh-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -988,6 +989,7 @@ Format specifiers \"%s\" are replaced before the script is
used.")
(insert-directory . tramp-sh-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-sh-handle-make-directory)
;; `make-directory-internal' performed by default handler.
@@ -1009,6 +1011,7 @@ Format specifiers \"%s\" are replaced before the script
is used.")
(tramp-get-remote-uid . tramp-sh-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . tramp-sh-handle-vc-registered)
(verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime)
(write-region . tramp-sh-handle-write-region))
@@ -3233,9 +3236,10 @@ implementation will be used."
tmpfile)))
(defun tramp-sh-handle-write-region
- (start end filename &optional append visit _lockname mustbenew)
+ (start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -3244,13 +3248,23 @@ implementation will be used."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((uid (or (tramp-compat-file-attribute-user-id
+ (let ((auto-saving
+ (string-match-p "^#.+#$" (file-name-nondirectory filename)))
+ file-locked
+ (uid (or (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
(gid (or (tramp-compat-file-attribute-group-id
(file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer))))
+ ;; Lock file.
+ (when (and (not auto-saving) (file-remote-p lockname)
+ (not (eq (file-locked-p lockname) t)))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(if (and (tramp-local-host-p v)
;; `file-writable-p' calls `file-expand-file-name'. We
;; cannot use `tramp-run-real-handler' therefore.
@@ -3465,6 +3479,12 @@ implementation will be used."
;; Set the ownership.
(when need-chown
(tramp-set-file-uid-gid filename uid gid))
+
+ ;; Unlock file.
+ (when (and file-locked (eq (file-locked-p lockname) t))
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
(when (and (null noninteractive)
(or (eq visit t) (null visit) (stringp visit)))
(tramp-message v 0 "Wrote %s" filename))
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 13edf16..500245b 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -247,6 +247,7 @@ See `tramp-actions-before-shell' for more info.")
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-smb-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-smb-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -273,6 +274,7 @@ See `tramp-actions-before-shell' for more info.")
(insert-directory . tramp-smb-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-smb-handle-make-directory)
(make-directory-internal . tramp-smb-handle-make-directory-internal)
@@ -294,6 +296,7 @@ See `tramp-actions-before-shell' for more info.")
(tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-smb-handle-write-region))
@@ -532,7 +535,7 @@ arguments to pass to the OPERATION."
(tramp-process-actions p v nil tramp-smb-actions-with-tar)
(while (process-live-p p)
- (sit-for 0.1))
+ (sleep-for 0.1))
(tramp-message v 6 "\n%s" (buffer-string))))
;; Reset the transfer process properties.
@@ -1573,9 +1576,10 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(error filename))))
(defun tramp-smb-handle-write-region
- (start end filename &optional append visit _lockname mustbenew)
+ (start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -1584,8 +1588,19 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((curbuf (current-buffer))
+ (let ((auto-saving
+ (string-match-p "^#.+#$" (file-name-nondirectory filename)))
+ file-locked
+ (curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
+
+ ;; Lock file.
+ (when (and (not auto-saving) (file-remote-p lockname)
+ (not (eq (file-locked-p lockname) t)))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok))
;; We say `no-message' here because we don't want the visited file
@@ -1618,6 +1633,11 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(file-attributes filename))
(current-time))))
+ ;; Unlock file.
+ (when (and file-locked (eq (file-locked-p lockname) t))
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
;; The end.
(when (and (null noninteractive)
(or (eq visit t) (null visit) (stringp visit)))
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index cac8c40..babd770 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -96,6 +96,7 @@
(file-exists-p . tramp-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-fuse-handle-file-name-all-completions)
(file-name-as-directory . tramp-handle-file-name-as-directory)
@@ -122,6 +123,7 @@
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-sshfs-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-fuse-handle-make-directory)
(make-directory-internal . ignore)
@@ -143,6 +145,7 @@
(tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-sshfs-handle-write-region))
@@ -279,9 +282,10 @@ arguments to pass to the OPERATION."
(tramp-fuse-local-file-name filename) mode flag))))
(defun tramp-sshfs-handle-write-region
- (start end filename &optional append visit _lockname mustbenew)
+ (start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -290,15 +294,32 @@ arguments to pass to the OPERATION."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (write-region
- start end (tramp-fuse-local-file-name filename) append 'nomessage)
- (tramp-flush-file-properties v localname)
-
- ;; The end.
- (when (and (null noninteractive)
- (or (eq visit t) (null visit) (stringp visit)))
- (tramp-message v 0 "Wrote %s" filename))
- (run-hooks 'tramp-handle-write-region-hook)))
+ (let ((auto-saving
+ (string-match-p "^#.+#$" (file-name-nondirectory filename)))
+ file-locked)
+
+ ;; Lock file.
+ (when (and (not auto-saving) (file-remote-p lockname)
+ (not (eq (file-locked-p lockname) t)))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
+ (let (create-lockfiles)
+ (write-region
+ start end (tramp-fuse-local-file-name filename) append 'nomessage)
+ (tramp-flush-file-properties v localname))
+
+ ;; Unlock file.
+ (when (and file-locked (eq (file-locked-p lockname) t))
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
+ ;; The end.
+ (when (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook))))
;; File name conversions.
@@ -321,6 +342,9 @@ connection if a previous connection has died for some
reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index d641709..aa6f85e 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -88,6 +88,7 @@ See `tramp-actions-before-shell' for more info.")
(file-exists-p . tramp-sudoedit-handle-file-exists-p)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions
. tramp-sudoedit-handle-file-name-all-completions)
@@ -115,6 +116,7 @@ See `tramp-actions-before-shell' for more info.")
(insert-directory . tramp-handle-insert-directory)
(insert-file-contents . tramp-handle-insert-file-contents)
(load . tramp-handle-load)
+ (lock-file . tramp-handle-lock-file)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-sudoedit-handle-make-directory)
(make-directory-internal . ignore)
@@ -136,6 +138,7 @@ See `tramp-actions-before-shell' for more info.")
(tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-sudoedit-handle-write-region))
@@ -713,6 +716,7 @@ ID-FORMAT valid values are `string' and `integer'."
(defun tramp-sudoedit-handle-write-region
(start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
(let* ((uid (or (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
@@ -776,6 +780,9 @@ connection if a previous connection has died for some
reason."
(process-put p 'vector vec)
(set-process-query-on-exit-flag p nil)
+ ;; Mark process for filelock.
+ (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds)))
+
;; Set connection-local variables.
(tramp-set-connection-local-variables vec)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 04ec06d..37d60e8 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2455,6 +2455,8 @@ Must be handled by the callers."
file-name-case-insensitive-p
;; Emacs 27+ only.
file-system-info
+ ;; Emacs 28+ only.
+ file-locked-p lock-file unlock-file
;; Tramp internal magic file name function.
tramp-set-file-uid-gid))
(if (file-name-absolute-p (nth 0 args))
@@ -3816,6 +3818,76 @@ User is always nil."
;; Result.
(cons (expand-file-name filename) (cdr result)))))
+(defun tramp-make-lock-name (file)
+ "Implement MAKE_LOCK_NAME of filelock.c."
+ (expand-file-name
+ (concat ".#" (file-name-nondirectory file)) (file-name-directory file)))
+
+(defun tramp-get-lock-file (file)
+ "Read lockfile of FILE.
+Return nil when there is no lockfile"
+ (let ((lockname (tramp-make-lock-name file)))
+ (or (file-symlink-p lockname)
+ (and (file-readable-p lockname)
+ (with-temp-buffer
+ (insert-file-contents-literally lockname)
+ (buffer-string))))))
+
+(defun tramp-get-lock-pid (file)
+ "Determine pid for lockfile of FILE."
+ ;; Some Tramp methods do not offer a connection process, but just a
+ ;; network process as a place holder. Those processes use the
+ ;; "lock-pid" connection property as fake pid, in fact it is the
+ ;; time stamp the process is created.
+ (let ((p (tramp-get-process (tramp-dissect-file-name file))))
+ (number-to-string
+ (or (process-id p)
+ (tramp-get-connection-property p "lock-pid" (emacs-pid))))))
+
+(defconst tramp-lock-file-contents-regexp
+ ;; USER@HOST.PID[:BOOT_TIME]
+ "\\`\\(.+\\)@\\(.+\\)\\.\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\'"
+ "The format of a lock file.")
+
+(defun tramp-handle-file-locked-p (file)
+ "Like `file-locked-p' for Tramp files."
+ (when-let ((contents (tramp-get-lock-file file))
+ (match (string-match tramp-lock-file-contents-regexp contents)))
+ (or (and (string-equal (match-string 1 contents) (user-login-name))
+ (string-equal (match-string 2 contents) (system-name))
+ (string-equal (match-string 3 contents) (tramp-get-lock-pid file)))
+ (match-string 1 contents))))
+
+(defun tramp-handle-lock-file (file)
+ "Like `lock-file' for Tramp files."
+ ;; See if this file is visited and has changed on disk since it
+ ;; was visited.
+ (catch 'dont-lock
+ (unless (or (null create-lockfiles)
+ (eq (file-locked-p file) t)) ;; Locked by me.
+ (when-let ((contents (tramp-get-lock-file file))
+ (match (string-match tramp-lock-file-contents-regexp
contents)))
+ (unless (ask-user-about-lock
+ file (format
+ "%s@%s (pid %s)" (match-string 1 contents)
+ (match-string 2 contents) (match-string 3 contents)))
+ (throw 'dont-lock nil)))
+
+ (let ((lockname (tramp-make-lock-name file))
+ ;; USER@HOST.PID[:BOOT_TIME]
+ (contents
+ (format
+ "%s@%s.%s" (user-login-name) (system-name)
+ (tramp-get-lock-pid file)))
+ create-lockfiles signal-hook-function)
+ (condition-case nil
+ (make-symbolic-link contents lockname 'ok-if-already-exists)
+ (error (write-region contents nil lockname)))))))
+
+(defun tramp-handle-unlock-file (file)
+ "Like `unlock-file' for Tramp files."
+ (delete-file (tramp-make-lock-name file)))
+
(defun tramp-handle-load (file &optional noerror nomessage nosuffix
must-suffix)
"Like `load' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name file) nil
@@ -4355,9 +4427,10 @@ of."
(t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))
(defun tramp-handle-write-region
- (start end filename &optional append visit _lockname mustbenew)
+ (start end filename &optional append visit lockname mustbenew)
"Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
+ (setq filename (expand-file-name filename)
+ lockname (file-truename (or lockname filename)))
(with-parsed-tramp-file-name filename nil
(when (and mustbenew (file-exists-p filename)
(or (eq mustbenew 'excl)
@@ -4366,7 +4439,10 @@ of."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let ((tmpfile (tramp-compat-make-temp-file filename))
+ (let ((auto-saving
+ (string-match-p "^#.+#$" (file-name-nondirectory filename)))
+ file-locked
+ (tmpfile (tramp-compat-make-temp-file filename))
(modes (tramp-default-file-modes
filename (and (eq mustbenew 'excl) 'nofollow)))
(uid (or (tramp-compat-file-attribute-user-id
@@ -4375,6 +4451,14 @@ of."
(gid (or (tramp-compat-file-attribute-group-id
(file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer))))
+
+ ;; Lock file.
+ (when (and (not auto-saving) (file-remote-p lockname)
+ (not (eq (file-locked-p lockname) t)))
+ (setq file-locked t)
+ ;; `lock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'lock-file lockname))
+
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok))
;; The permissions of the temporary file should be set. If
@@ -4404,13 +4488,18 @@ of."
(current-time))))
;; Set the ownership.
- (tramp-set-file-uid-gid filename uid gid))
-
- ;; The end.
- (when (and (null noninteractive)
- (or (eq visit t) (null visit) (stringp visit)))
- (tramp-message v 0 "Wrote %s" filename))
- (run-hooks 'tramp-handle-write-region-hook)))
+ (tramp-set-file-uid-gid filename uid gid)
+
+ ;; Unlock file.
+ (when (and file-locked (eq (file-locked-p lockname) t))
+ ;; `unlock-file' exists since Emacs 28.1.
+ (tramp-compat-funcall 'unlock-file lockname))
+
+ ;; The end.
+ (when (and (null noninteractive)
+ (or (eq visit t) (null visit) (stringp visit)))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook))))
;; This is used in tramp-sh.el and tramp-sudoedit.el.
(defconst tramp-stat-marker "/////"
diff --git a/src/filelock.c b/src/filelock.c
index 446a262..dcdc635 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -671,6 +671,16 @@ lock_file (Lisp_Object fn)
if (will_dump_p ())
return;
+ /* If the file name has special constructs in it,
+ call the corresponding file name handler. */
+ Lisp_Object handler;
+ handler = Ffind_file_name_handler (fn, Qlock_file);
+ if (!NILP (handler))
+ {
+ call2 (handler, Qlock_file, fn);
+ return;
+ }
+
orig_fn = fn;
fn = Fexpand_file_name (fn, Qnil);
#ifdef WINDOWSNT
@@ -725,6 +735,16 @@ unlock_file_body (Lisp_Object fn)
char *lfname;
USE_SAFE_ALLOCA;
+ /* If the file name has special constructs in it,
+ call the corresponding file name handler. */
+ Lisp_Object handler;
+ handler = Ffind_file_name_handler (fn, Qunlock_file);
+ if (!NILP (handler))
+ {
+ call2 (handler, Qunlock_file, fn);
+ return Qnil;
+ }
+
Lisp_Object filename = Fexpand_file_name (fn, Qnil);
fn = ENCODE_FILE (filename);
@@ -784,6 +804,27 @@ unlock_all_files (void)
}
}
+DEFUN ("lock-file", Flock_file, Slock_file,
+ 0, 1, 0,
+ doc: /* Lock FILE.
+If the option `create-lockfiles' is nil, this does nothing. */)
+ (Lisp_Object file)
+{
+ CHECK_STRING (file);
+ lock_file (file);
+ return Qnil;
+}
+
+DEFUN ("unlock-file", Funlock_file, Sunlock_file,
+ 0, 1, 0,
+ doc: /* Unlock FILE. */)
+ (Lisp_Object file)
+{
+ CHECK_STRING (file);
+ unlock_file (file);
+ return Qnil;
+}
+
DEFUN ("lock-buffer", Flock_buffer, Slock_buffer,
0, 1, 0,
doc: /* Lock FILE, if current buffer is modified.
@@ -844,6 +885,15 @@ t if it is locked by you, else a string saying which user
has locked it. */)
lock_info_type locker;
USE_SAFE_ALLOCA;
+ /* If the file name has special constructs in it,
+ call the corresponding file name handler. */
+ Lisp_Object handler;
+ handler = Ffind_file_name_handler (filename, Qfile_locked_p);
+ if (!NILP (handler))
+ {
+ return call2 (handler, Qfile_locked_p, filename);
+ }
+
filename = Fexpand_file_name (filename, Qnil);
Lisp_Object encoded_filename = ENCODE_FILE (filename);
MAKE_LOCK_NAME (lfname, encoded_filename);
@@ -876,7 +926,13 @@ The name of the (per-buffer) lockfile is constructed by
prepending a
Info node `(emacs)Interlocking'. */);
create_lockfiles = true;
- defsubr (&Sunlock_buffer);
+ DEFSYM (Qlock_file, "lock-file");
+ DEFSYM (Qunlock_file, "unlock-file");
+ DEFSYM (Qfile_locked_p, "file-locked-p");
+
+ defsubr (&Slock_file);
+ defsubr (&Sunlock_file);
defsubr (&Slock_buffer);
+ defsubr (&Sunlock_buffer);
defsubr (&Sfile_locked_p);
}
diff --git a/test/lisp/net/tramp-archive-tests.el
b/test/lisp/net/tramp-archive-tests.el
index ca1163b..aac1b13 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -856,7 +856,7 @@ This tests also `file-executable-p', `file-writable-p' and
`set-file-modes'."
(tramp-archive-cleanup-hash))))
;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-archive-test39-make-nearby-temp-file ()
+(ert-deftest tramp-archive-test40-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless tramp-archive-enabled)
;; Since Emacs 26.1.
@@ -893,7 +893,7 @@ This tests also `file-executable-p', `file-writable-p' and
`set-file-modes'."
(delete-directory tmp-file)
(should-not (file-exists-p tmp-file))))
-(ert-deftest tramp-archive-test42-file-system-info ()
+(ert-deftest tramp-archive-test43-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless tramp-archive-enabled)
;; Since Emacs 27.1.
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 7f89444..0e70f8e 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -33,7 +33,7 @@
;; remote host, set this environment variable to "/dev/null" or
;; whatever is appropriate on your system.
-;; For slow remote connections, `tramp-test43-asynchronous-requests'
+;; For slow remote connections, `tramp-test44-asynchronous-requests'
;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper
;; value less than 10 could help.
@@ -122,6 +122,7 @@
(setq auth-source-save-behavior nil
password-cache-expiry nil
remote-file-name-inhibit-cache nil
+ create-lockfiles nil
tramp-cache-read-persistent-data t ;; For auth-sources.
tramp-copy-size-limit nil
tramp-persistency-file-name nil
@@ -2463,6 +2464,8 @@ This checks also `file-name-as-directory',
`file-name-directory',
"^\\'")
tramp--test-messages))))))))
+ ;; We do not test lockname here. See `tramp-test39-lock-file'.
+
;; Do not overwrite if excluded.
(cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always)
;; Ange-FTP.
@@ -2833,8 +2836,7 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(delete-directory tmp-name1 nil 'trash)
;; tramp-rclone.el and tramp-sshfs.el call the local
;; `delete-directory'. This raises another error.
- :type (if (or (tramp--test-rclone-p) (tramp--test-sshfs-p))
- 'error 'file-error))
+ :type (if (tramp--test-fuse-p) 'error 'file-error))
(delete-directory tmp-name1 'recursive 'trash)
(should-not (file-directory-p tmp-name1))
(should
@@ -5741,8 +5743,77 @@ Use direct async.")
(ignore-errors (delete-file tmp-name1))
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)))))
+;; The functions were introduced in Emacs 28.1.
+(ert-deftest tramp-test39-lock-file ()
+ "Check `lock-file', `unlock-file' and `file-locked-p'."
+ (skip-unless (tramp--test-enabled))
+ (skip-unless (not (tramp--test-ange-ftp-p)))
+ ;; Since Emacs 28.1.
+ (skip-unless (and (fboundp 'lock-file) (fboundp 'unlock-file)))
+
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
+ (let ((tmp-name (tramp--test-make-temp-name nil quoted))
+ (remote-file-name-inhibit-cache t)
+ (create-lockfiles t)
+ (inhibit-message t)
+ ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files.
+ (tramp-cleanup-connection-hook
+ (append
+ (and (tramp--test-fuse-p) '(tramp-fuse-unmount))
+ tramp-cleanup-connection-hook))
+ noninteractive)
+
+ (unwind-protect
+ (progn
+ ;; A simple file lock.
+ (should-not (file-locked-p tmp-name))
+ (lock-file tmp-name)
+ (should (eq (file-locked-p tmp-name) t))
+
+ ;; If it is locked already, nothing changes.
+ (lock-file tmp-name)
+ (should (eq (file-locked-p tmp-name) t))
+
+ ;; A new connection changes process id, and also the
+ ;; lockname contents.
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (should (stringp (file-locked-p tmp-name)))
+
+ ;; Steal the file lock.
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?s)))
+ (lock-file tmp-name))
+ (should (eq (file-locked-p tmp-name) t))
+
+ ;; Ignore the file lock.
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?p)))
+ (lock-file tmp-name))
+ (should (stringp (file-locked-p tmp-name)))
+
+ ;; Quit the file lock machinery.
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q)))
+ (should-error (lock-file tmp-name) :type 'file-locked))
+ (should (stringp (file-locked-p tmp-name)))
+
+ ;; The same for `write-region'.
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q)))
+ (should-error (write-region "foo" nil tmp-name) :type
'file-locked)
+ (should-error
+ (write-region "foo" nil tmp-name nil nil tmp-name)
+ :type 'file-locked))
+ (should (stringp (file-locked-p tmp-name)))
+ (should-not (file-exists-p tmp-name)))
+
+ ;; Cleanup.
+ (ignore-errors (delete-file tmp-name))
+ (unlock-file tmp-name)
+ (should-not (file-locked-p tmp-name))))))
+
;; The functions were introduced in Emacs 26.1.
-(ert-deftest tramp-test39-make-nearby-temp-file ()
+(ert-deftest tramp-test40-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-ange-ftp-p)))
@@ -5825,6 +5896,10 @@ This does not support globbing characters in file names
(yet)."
(string-match-p
"ftp$" (file-remote-p tramp-test-temporary-file-directory 'method)))
+(defun tramp--test-fuse-p ()
+ "Check, whether an FUSE file system isused."
+ (or (tramp--test-rclone-p) (tramp--test-sshfs-p)))
+
(defun tramp--test-gdrive-p ()
"Check, whether the gdrive method is used."
(string-equal
@@ -6115,7 +6190,7 @@ This requires restrictions of file name syntax."
(ignore-errors (delete-directory tmp-name2 'recursive))))))
(defun tramp--test-special-characters ()
- "Perform the test in `tramp-test40-special-characters*'."
+ "Perform the test in `tramp-test41-special-characters*'."
;; Newlines, slashes and backslashes in file names are not
;; supported. So we don't test. And we don't test the tab
;; character on Windows or Cygwin, because the backslash is
@@ -6173,7 +6248,7 @@ This requires restrictions of file name syntax."
files (list (mapconcat #'identity files ""))))))
;; These tests are inspired by Bug#17238.
-(ert-deftest tramp-test40-special-characters ()
+(ert-deftest tramp-test41-special-characters ()
"Check special characters in file names."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
@@ -6181,7 +6256,7 @@ This requires restrictions of file name syntax."
(tramp--test-special-characters))
-(ert-deftest tramp-test40-special-characters-with-stat ()
+(ert-deftest tramp-test41-special-characters-with-stat ()
"Check special characters in file names.
Use the `stat' command."
:tags '(:expensive-test)
@@ -6199,7 +6274,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test40-special-characters-with-perl ()
+(ert-deftest tramp-test41-special-characters-with-perl ()
"Check special characters in file names.
Use the `perl' command."
:tags '(:expensive-test)
@@ -6220,7 +6295,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test40-special-characters-with-ls ()
+(ert-deftest tramp-test41-special-characters-with-ls ()
"Check special characters in file names.
Use the `ls' command."
:tags '(:expensive-test)
@@ -6241,7 +6316,7 @@ Use the `ls' command."
(tramp--test-special-characters)))
(defun tramp--test-utf8 ()
- "Perform the test in `tramp-test41-utf8*'."
+ "Perform the test in `tramp-test42-utf8*'."
(let* ((utf8 (if (and (eq system-type 'darwin)
(memq 'utf-8-hfs (coding-system-list)))
'utf-8-hfs 'utf-8))
@@ -6287,7 +6362,7 @@ Use the `ls' command."
(replace-regexp-in-string "[ \t\n/.?]" "" x)))
language-info-alist)))))))
-(ert-deftest tramp-test41-utf8 ()
+(ert-deftest tramp-test42-utf8 ()
"Check UTF8 encoding in file names and file contents."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-docker-p)))
@@ -6300,7 +6375,7 @@ Use the `ls' command."
(tramp--test-utf8))
-(ert-deftest tramp-test41-utf8-with-stat ()
+(ert-deftest tramp-test42-utf8-with-stat ()
"Check UTF8 encoding in file names and file contents.
Use the `stat' command."
:tags '(:expensive-test)
@@ -6322,7 +6397,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test41-utf8-with-perl ()
+(ert-deftest tramp-test42-utf8-with-perl ()
"Check UTF8 encoding in file names and file contents.
Use the `perl' command."
:tags '(:expensive-test)
@@ -6347,7 +6422,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test41-utf8-with-ls ()
+(ert-deftest tramp-test42-utf8-with-ls ()
"Check UTF8 encoding in file names and file contents.
Use the `ls' command."
:tags '(:expensive-test)
@@ -6371,7 +6446,7 @@ Use the `ls' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test42-file-system-info ()
+(ert-deftest tramp-test43-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless (tramp--test-enabled))
;; Since Emacs 27.1.
@@ -6388,11 +6463,11 @@ Use the `ls' command."
(numberp (nth 1 fsi))
(numberp (nth 2 fsi))))))
-;; `tramp-test43-asynchronous-requests' could be blocked. So we set a
+;; `tramp-test44-asynchronous-requests' could be blocked. So we set a
;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300
;; seconds. Similar check is performed in the timer function.
(defconst tramp--test-asynchronous-requests-timeout 300
- "Timeout for `tramp-test43-asynchronous-requests'.")
+ "Timeout for `tramp-test44-asynchronous-requests'.")
(defmacro tramp--test-with-proper-process-name-and-buffer (proc &rest body)
"Set \"process-name\" and \"process-buffer\" connection properties.
@@ -6428,7 +6503,7 @@ This is needed in timer functions as well as process
filters and sentinels."
(tramp-flush-connection-property v "process-buffer")))))
;; This test is inspired by Bug#16928.
-(ert-deftest tramp-test43-asynchronous-requests ()
+(ert-deftest tramp-test44-asynchronous-requests ()
"Check parallel asynchronous requests.
Such requests could arrive from timers, process filters and
process sentinels. They shall not disturb each other."
@@ -6628,11 +6703,11 @@ process sentinels. They shall not disturb each other."
(ignore-errors (cancel-timer timer))
(ignore-errors (delete-directory tmp-name 'recursive))))))
-;; (tramp--test--deftest-direct-async-process
tramp-test43-asynchronous-requests
+;; (tramp--test--deftest-direct-async-process
tramp-test44-asynchronous-requests
;; "Check parallel direct asynchronous requests." 'unstable)
;; This test is inspired by Bug#29163.
-(ert-deftest tramp-test44-auto-load ()
+(ert-deftest tramp-test45-auto-load ()
"Check that Tramp autoloads properly."
;; If we use another syntax but `default', Tramp is already loaded
;; due to the `tramp-change-syntax' call.
@@ -6657,7 +6732,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test44-delay-load ()
+(ert-deftest tramp-test45-delay-load ()
"Check that Tramp is loaded lazily, only when needed."
;; The autoloaded Tramp objects are different since Emacs 26.1. We
;; cannot test older Emacsen, therefore.
@@ -6690,7 +6765,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument (format code tm)))))))))
-(ert-deftest tramp-test44-recursive-load ()
+(ert-deftest tramp-test45-recursive-load ()
"Check that Tramp does not fail due to recursive load."
(skip-unless (tramp--test-enabled))
@@ -6714,7 +6789,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code))))))))
-(ert-deftest tramp-test44-remote-load-path ()
+(ert-deftest tramp-test45-remote-load-path ()
"Check that Tramp autoloads its packages with remote `load-path'."
;; The autoloaded Tramp objects are different since Emacs 26.1. We
;; cannot test older Emacsen, therefore.
@@ -6743,7 +6818,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test45-unload ()
+(ert-deftest tramp-test46-unload ()
"Check that Tramp and its subpackages unload completely.
Since it unloads Tramp, it shall be the last test to run."
:tags '(:expensive-test)
@@ -6826,7 +6901,7 @@ If INTERACTIVE is non-nil, the tests are run
interactively."
;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and
;; for direct async processes.
;; * Check, why direct async processes do not work for
-;; `tramp-test43-asynchronous-requests'.
+;; `tramp-test44-asynchronous-requests'.
(provide 'tramp-tests)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master d35868b: Implement file locks for remote files (Bug#49261),
Michael Albinus <=