[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/tramp-thread-safe ac98caa: Sync with Tramp 2.5.0
|
From: |
Michael Albinus |
|
Subject: |
feature/tramp-thread-safe ac98caa: Sync with Tramp 2.5.0 |
|
Date: |
Mon, 17 Feb 2020 03:54:57 -0500 (EST) |
branch: feature/tramp-thread-safe
commit ac98caa0cdd12bed335be653ed4bc621e9bac543
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
Sync with Tramp 2.5.0
---
lisp/net/tramp-ftp.el | 7 +-
lisp/net/tramp.el | 184 +++++++++++++++++++++------------------
test/lisp/net/tramp-tests.el | 200 +++++++++++++++++++++++--------------------
3 files changed, 208 insertions(+), 183 deletions(-)
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index 6609064..2868b49 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -130,7 +130,7 @@ pass to the OPERATION."
(ange-ftp-ftp-name-arg "")
(ange-ftp-ftp-name-res nil)
(v (tramp-dissect-file-name
- (apply 'tramp-file-name-for-operation operation args) t)))
+ (apply #'tramp-file-name-for-operation operation args) t)))
(setf (tramp-file-name-method v) tramp-ftp-method)
;; Set "process-name" for thread support.
(tramp-set-connection-property
@@ -147,10 +147,9 @@ pass to the OPERATION."
;; completion. We don't use `with-parsed-tramp-file-name',
;; because this returns another user but the one declared in
;; "~/.netrc".
+ ((memq operation '(file-directory-p file-exists-p))
(if (apply #'ange-ftp-hook-function operation args)
- (let ((v (tramp-dissect-file-name (car args) t)))
- (setf (tramp-file-name-method v) tramp-ftp-method)
- (tramp-set-connection-property v "started" t))
+ (tramp-set-connection-property v "started" t)
nil))
;; If the second argument of `copy-file' or `rename-file' is a
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 6512892..46bde74 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2320,16 +2320,17 @@ preventing reentrant calls of Tramp.")
(defun tramp-get-mutex (vec)
"Return the mutex locking Tramp threads for VEC."
- (let ((p (tramp-get-connection-process vec)))
- (if p
+ (if-let ((p (and (tramp-connectable-p vec)
+ (tramp-get-connection-process vec))))
(with-tramp-connection-property p "mutex"
(tramp-compat-funcall 'make-mutex (process-name p)))
- tramp-mutex)))
+ tramp-mutex))
;; Main function.
(defun tramp-file-name-handler (operation &rest args)
"Invoke Tramp file name handler for OPERATION and ARGS.
-Fall back to normal file name handler if no Tramp file name handler exists."
+Fall back to normal file name handler if no Tramp file name handler exists.
+If Emacs is compiled --with-threads, the body is protected by a mutex."
(let ((filename (apply #'tramp-file-name-for-operation operation args))
;; `file-remote-p' is called for everything, even for symbolic
;; links which look remote. We don't want to get an error.
@@ -2338,88 +2339,103 @@ Fall back to normal file name handler if no Tramp file
name handler exists."
(save-match-data
(setq filename (tramp-replace-environment-variables filename))
(with-parsed-tramp-file-name filename nil
- (let ((current-connection tramp-current-connection)
- (foreign
- (tramp-find-foreign-file-name-handler filename operation))
- (signal-hook-function #'tramp-signal-hook-function)
- result)
- ;; Set `tramp-current-connection'.
- (unless
- (tramp-file-name-equal-p v (car tramp-current-connection))
- (setq tramp-current-connection (list v)))
-
- ;; Call the backend function.
- (unwind-protect
- (if foreign
- (let ((sf (symbol-function foreign)))
- ;; Some packages set the default directory to
- ;; a remote path, before respective Tramp
- ;; packages are already loaded. This results
- ;; in recursive loading. Therefore, we load
- ;; the Tramp packages locally.
- (when (autoloadp sf)
- ;; FIXME: Not clear why we need these bindings here.
- ;; The explanation above is not convincing and
- ;; the bug#9114 for which it was added doesn't
- ;; clarify the core of the problem.
- (let ((default-directory
- (tramp-compat-temporary-file-directory))
- file-name-handler-alist)
- (autoload-do-load sf foreign)))
- ;; (tramp-message
- ;; v 4 "Running `%s'..." (cons operation args))
- ;; If `non-essential' is non-nil, Tramp shall
- ;; not open a new connection.
- ;; If Tramp detects that it shouldn't continue
- ;; to work, it throws the `suppress' event.
- ;; This could happen for example, when Tramp
- ;; tries to open the same connection twice in
- ;; a short time frame.
- ;; In both cases, we try the default handler then.
- (setq result
- (catch 'non-essential
- (catch 'suppress
- (when (and tramp-locked (not tramp-locker))
- (setq tramp-locked nil)
- (tramp-error
- v 'file-error
- "Forbidden reentrant call of Tramp"))
- (let ((tl tramp-locked))
- (setq tramp-locked t)
- (unwind-protect
- (let ((tramp-locker t))
- (apply foreign operation args))
- (setq tramp-locked tl))))))
- ;; (tramp-message
- ;; v 4 "Running `%s'...`%s'" (cons operation args)
result)
- (cond
- ((eq result 'non-essential)
- (tramp-message
- v 5 "Non-essential received in operation %s"
- (cons operation args))
- (tramp-run-real-handler operation args))
- ((eq result 'suppress)
- (let ((inhibit-message t))
+ ;; Give other threads a chance.
+ (tramp-compat-thread-yield)
+ ;; The mutex allows concurrent run of operations. It
+ ;; guarantees, that the threads are not mixed.
+ (tramp-compat-with-mutex (tramp-get-mutex v)
+ (let ((current-connection tramp-current-connection)
+ (foreign
+ (tramp-find-foreign-file-name-handler filename operation))
+ (signal-hook-function #'tramp-signal-hook-function)
+ result)
+ ;; Set `tramp-current-connection'.
+ (unless
+ (tramp-file-name-equal-p v (car tramp-current-connection))
+ (setq tramp-current-connection (list v)))
+
+ ;; Call the backend function.
+ (unwind-protect
+ (if foreign
+ (let ((sf (symbol-function foreign))
+ p)
+ ;; Some packages set the default directory
+ ;; to a remote path, before respective Tramp
+ ;; packages are already loaded. This
+ ;; results in recursive loading. Therefore,
+ ;; we load the Tramp packages locally.
+ (when (autoloadp sf)
+ ;; FIXME: Not clear why we need these bindings
here.
+ ;; The explanation above is not convincing and
+ ;; the bug#9114 for which it was added doesn't
+ ;; clarify the core of the problem.
+ (let ((default-directory
+ (tramp-compat-temporary-file-directory))
+ file-name-handler-alist)
+ (autoload-do-load sf foreign)))
+ ;; (tramp-message
+ ;; v 4 "Running `%s'..." (cons operation args))
+ ;; Switch process thread.
+ (when (and tramp-mutex
+ (tramp-connectable-p v)
+ (setq p (tramp-get-connection-process v)))
+ (tramp-compat-funcall
+ 'set-process-thread
+ p (tramp-compat-current-thread)))
+ ;; If `non-essential' is non-nil, Tramp
+ ;; shall not open a new connection.
+ ;; If Tramp detects that it shouldn't
+ ;; continue to work, it throws the
+ ;; `suppress' event. This could happen for
+ ;; example, when Tramp tries to open the
+ ;; same connection twice in a short time
+ ;; frame.
+ ;; In both cases, we try the default handler
+ ;; then.
+ (setq result
+ (catch 'non-essential
+ (catch 'suppress
+ (when (and tramp-locked (not tramp-locker))
+ (setq tramp-locked nil)
+ (tramp-error
+ v 'file-error
+ "Forbidden reentrant call of Tramp"))
+ (let ((tl tramp-locked))
+ (setq tramp-locked t)
+ (unwind-protect
+ (let ((tramp-locker t))
+ (apply foreign operation args))
+ (setq tramp-locked tl))))))
+ ;; (tramp-message
+ ;; v 4 "Running `%s'...`%s'" (cons operation args)
result)
+ (cond
+ ((eq result 'non-essential)
(tramp-message
- v 1 "Suppress received in operation %s"
+ v 5 "Non-essential received in operation %s"
(cons operation args))
- (tramp-cleanup-connection v t)
- (tramp-run-real-handler operation args)))
- (t result)))
-
- ;; Nothing to do for us. However, since we are in
- ;; `tramp-mode', we must suppress the volume
- ;; letter on MS Windows.
- (setq result (tramp-run-real-handler operation args))
- (if (stringp result)
- (tramp-drop-volume-letter result)
- result))
-
- ;; Reset `tramp-current-connection'.
- (unless
- (tramp-file-name-equal-p
- (car current-connection) (car tramp-current-connection))
- (setq tramp-current-connection current-connection))))))
+ (tramp-run-real-handler operation args))
+ ((eq result 'suppress)
+ (let ((inhibit-message t))
+ (tramp-message
+ v 1 "Suppress received in operation %s"
+ (cons operation args))
+ (tramp-cleanup-connection v t)
+ (tramp-run-real-handler operation args)))
+ (t result)))
+
+ ;; Nothing to do for us. However, since we are
+ ;; in `tramp-mode', we must suppress the volume
+ ;; letter on MS Windows.
+ (setq result (tramp-run-real-handler operation args))
+ (if (stringp result)
+ (tramp-drop-volume-letter result)
+ result))
+
+ ;; Reset `tramp-current-connection'.
+ (unless
+ (tramp-file-name-equal-p
+ (car current-connection) (car tramp-current-connection))
+ (setq tramp-current-connection current-connection)))))))
;; When `tramp-mode' is not enabled, or the file name is quoted,
;; we don't do anything.
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 81485da..bd924ab 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -4358,7 +4358,7 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(while (accept-process-output proc 0 nil t)))
;; We cannot use `string-equal', because tramp-adb.el
;; echoes also the sent string. And a remote macOS sends
- ;; a slightly modified string. On MS-Windows,
+ ;; a slightly modified string. On MS Windows,
;; `delete-process' sends an unknown signal.
(should
(string-match
@@ -6114,107 +6114,116 @@ process sentinels. They shall not disturb each
other."
(ignore-errors (cancel-timer timer))
(ignore-errors (delete-directory tmp-name 'recursive))))))
-(ert-deftest tramp-test43-threads ()
+(ert-deftest tramp-test44-threads ()
"Check that Tramp cooperates with threads."
(skip-unless (tramp--test-enabled))
(skip-unless (featurep 'threads))
- (skip-unless (= (length (all-threads)) 1))
- (skip-unless (not (thread-last-error)))
+ (skip-unless (= (length (with-no-warnings (all-threads))) 1))
+ (skip-unless (not (with-no-warnings (thread-last-error))))
+ ;; We need the thread features introduced in Emacs 27.
+ (skip-unless (bound-and-true-p main-thread))
+ ;; For the time being it works only in the feature branch.
+ (skip-unless
+ (string-equal
+ (bound-and-true-p emacs-repository-branch) "feature/tramp-thread-safe"))
- ;; We cannot bind the variables dynamically; they are used in the threads.
- (defvar tmp-name1 (tramp--test-make-temp-name))
- (defvar tmp-name2 (tramp--test-make-temp-name))
- (defvar tmp-mutex (make-mutex "mutex"))
- (defvar tmp-condvar1 (make-condition-variable tmp-mutex "condvar1"))
- (defvar tmp-condvar2 (make-condition-variable tmp-mutex "condvar2"))
+ (tramp--test-instrument-test-case 0
+ (with-no-warnings
+ (with-timeout (60 (tramp--test-timeout-handler))
+ ;; We cannot bind the variables dynamically; they are used in the
threads.
+ (defvar tmp-name1 (tramp--test-make-temp-name))
+ (defvar tmp-name2 (tramp--test-make-temp-name))
+ (defvar tmp-mutex (make-mutex "mutex"))
+ (defvar tmp-condvar1 (make-condition-variable tmp-mutex "condvar1"))
+ (defvar tmp-condvar2 (make-condition-variable tmp-mutex "condvar2"))
+
+ ;; Rename simple file.
+ (unwind-protect
+ (let (tmp-thread1 tmp-thread2)
+ (write-region "foo" nil tmp-name1)
+ (should (file-exists-p tmp-name1))
+ (should-not (file-exists-p tmp-name2))
+
+ (should (mutexp tmp-mutex))
+ (should (condition-variable-p tmp-condvar1))
+ (should (condition-variable-p tmp-condvar2))
+
+ ;; This thread renames `tmp-name1' to `tmp-name2' twice.
+ (setq
+ tmp-thread1
+ (make-thread
+ (lambda ()
+ ;; Rename first time.
+ (rename-file tmp-name1 tmp-name2)
+ ;; Notify thread2.
+ (with-mutex (condition-mutex tmp-condvar2)
+ (condition-notify tmp-condvar2 t))
+ ;; Rename second time, once we've got notification from thread2.
+ (with-mutex (condition-mutex tmp-condvar1)
+ (condition-wait tmp-condvar1))
+ (rename-file tmp-name1 tmp-name2))
+ "thread1"))
+
+ (should (threadp tmp-thread1))
+ (should (thread-live-p tmp-thread1))
+
+ ;; This thread renames `tmp-name2' to `tmp-name1' twice.
+ (setq
+ tmp-thread2
+ (make-thread
+ (lambda ()
+ ;; Rename first time, once we've got notification from thread1.
+ (with-mutex (condition-mutex tmp-condvar2)
+ (condition-wait tmp-condvar2))
+ (rename-file tmp-name2 tmp-name1)
+ ;; Notify thread1.
+ (with-mutex (condition-mutex tmp-condvar1)
+ (condition-notify tmp-condvar1 t))
+ ;; Rename second time, once we've got notification from
+ ;; the main thread.
+ (with-mutex (condition-mutex tmp-condvar2)
+ (condition-wait tmp-condvar2))
+ (rename-file tmp-name2 tmp-name1))
+ "thread2"))
+
+ (should (threadp tmp-thread2))
+ (should (thread-live-p tmp-thread2))
+ (should (= (length (all-threads)) 3))
+
+ ;; Wait for thread1.
+ (thread-join tmp-thread1)
+ ;; Checks.
+ (should-not (thread-live-p tmp-thread1))
+ (should (= (length (all-threads)) 2))
+ (should-not (thread-last-error))
+ (should (file-exists-p tmp-name2))
+ (should-not (file-exists-p tmp-name1))
- ;; Rename simple file.
- (unwind-protect
- (let (tmp-thread1 tmp-thread2)
- (write-region "foo" nil tmp-name1)
- (should (file-exists-p tmp-name1))
- (should-not (file-exists-p tmp-name2))
-
- (should (mutexp tmp-mutex))
- (should (condition-variable-p tmp-condvar1))
- (should (condition-variable-p tmp-condvar2))
-
- ;; This thread renames `tmp-name1' to `tmp-name2' twice.
- (setq
- tmp-thread1
- (make-thread
- (lambda ()
- ;; Rename first time.
- (rename-file tmp-name1 tmp-name2)
;; Notify thread2.
(with-mutex (condition-mutex tmp-condvar2)
(condition-notify tmp-condvar2 t))
- ;; Rename second time, once we've got notification from thread2.
- (with-mutex (condition-mutex tmp-condvar1)
- (condition-wait tmp-condvar1))
- (rename-file tmp-name1 tmp-name2))
- "thread1"))
-
- (should (threadp tmp-thread1))
- (should (thread-live-p tmp-thread1))
-
- ;; This thread renames `tmp-name2' to `tmp-name1' twice.
- (setq
- tmp-thread2
- (make-thread
- (lambda ()
- ;; Rename first time, once we've got notification from thread1.
- (with-mutex (condition-mutex tmp-condvar2)
- (condition-wait tmp-condvar2))
- (rename-file tmp-name2 tmp-name1)
- ;; Notify thread1.
- (with-mutex (condition-mutex tmp-condvar1)
- (condition-notify tmp-condvar1 t))
- ;; Rename second time, once we've got notification from
- ;; the main thread.
- (with-mutex (condition-mutex tmp-condvar2)
- (condition-wait tmp-condvar2))
- (rename-file tmp-name2 tmp-name1))
- "thread2"))
-
- (should (threadp tmp-thread2))
- (should (thread-live-p tmp-thread2))
- (should (= (length (all-threads)) 3))
-
- ;; Wait for thread1.
- (thread-join tmp-thread1)
- ;; Checks.
- (should-not (thread-live-p tmp-thread1))
- (should (= (length (all-threads)) 2))
- (should-not (thread-last-error))
- (should (file-exists-p tmp-name2))
- (should-not (file-exists-p tmp-name1))
-
- ;; Notify thread2.
- (with-mutex (condition-mutex tmp-condvar2)
- (condition-notify tmp-condvar2 t))
-
- ;; Wait for thread2.
- (thread-join tmp-thread2)
- ;; Checks.
- (should-not (thread-live-p tmp-thread2))
- (should (= (length (all-threads)) 1))
- (should-not (thread-last-error))
- (should (file-exists-p tmp-name1))
- (should-not (file-exists-p tmp-name2)))
- ;; Cleanup.
- (ignore-errors (delete-file tmp-name1))
- (ignore-errors (delete-file tmp-name2))
- ;; We could have spurious threads still running; wait for them to die.
- (while (cdr (all-threads))
- (thread-signal (cadr (all-threads)) 'error nil)
- (thread-yield))
- ;; Cleanup errors.
- (thread-last-error 'cleanup)))
+ ;; Wait for thread2.
+ (thread-join tmp-thread2)
+ ;; Checks.
+ (should-not (thread-live-p tmp-thread2))
+ (should (= (length (all-threads)) 1))
+ (should-not (thread-last-error))
+ (should (file-exists-p tmp-name1))
+ (should-not (file-exists-p tmp-name2)))
+
+ ;; Cleanup.
+ (ignore-errors (delete-file tmp-name1))
+ (ignore-errors (delete-file tmp-name2))
+ ;; We could have spurious threads still running; wait for them to die.
+ (while (cdr (all-threads))
+ (thread-signal (cadr (all-threads)) 'error nil)
+ (thread-yield))
+ ;; Cleanup errors.
+ (ignore-errors (thread-last-error 'cleanup)))))))
;; 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.
@@ -6239,7 +6248,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.
@@ -6272,7 +6281,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))
@@ -6296,7 +6305,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.
@@ -6325,7 +6334,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)
@@ -6409,6 +6418,7 @@ If INTERACTIVE is non-nil, the tests are run
interactively."
;; * Implement `tramp-test31-interrupt-process' for `adb'.
;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. A remote
;; file name operation cannot run in the timer. Remove `:unstable' tag?
+;; * Fix `tramp-test44-threads'.
(provide 'tramp-tests)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- feature/tramp-thread-safe ac98caa: Sync with Tramp 2.5.0,
Michael Albinus <=