From: Michael Albinus Date: Mon, 17 Feb 2020 08:54:42 +0000 (+0100) Subject: Sync with Tramp 2.5.0 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ac98caa0cdd12bed335be653ed4bc621e9bac543;p=emacs.git Sync with Tramp 2.5.0 --- diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 6609064c222..2868b491cba 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 651289213c0..46bde747433 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 81485da246a..bd924abdaa6 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)