From 138447c3abd749d1c27d99d7089b1b0903352ade Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 29 Jun 2017 18:22:38 +0200 Subject: [PATCH] Improve timer handling when Tramp accepts output * lisp/net/tramp-compat.el: Avoid compiler warning. * lisp/net/tramp-sh.el (tramp-sh-file-name-handler): Remove lock machinery. * lisp/net/tramp.el (tramp-locked, tramp-locker): Move up. (tramp-file-name-handler): Add lock machinery from `tramp-sh-file-name-handler'. Allow timers to run. (tramp-accept-process-output): Remove nasty workaround. Suppress timers. * test/lisp/net/tramp-tests.el (shell-command-sentinel): Suppress run in tests. (tramp--instrument-test-case-p): New defvar. (tramp--instrument-test-case): Use it in order to allow nested calls. (tramp--test-message, tramp--test-backtrace): New defsubst, will be used for occasional test instrumentation. (tramp-test00-availability, tramp-test31-vc-registered): Use them. (tramp-test28-shell-command) (tramp--test-shell-command-to-string-asynchronously): Suppress nasty messages. Don't overwrite sentinel. (tramp-test36-asynchronous-requests): Rewrite major parts. Expect :passed. --- lisp/net/tramp-compat.el | 3 +- lisp/net/tramp-sh.el | 19 +-- lisp/net/tramp.el | 91 +++++++------- test/lisp/net/tramp-tests.el | 231 +++++++++++++++++++++-------------- 4 files changed, 191 insertions(+), 153 deletions(-) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index c998df814c1..b2df4d6324b 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -252,7 +252,8 @@ If NAME is a remote file name, the local part of NAME is unquoted." (eval-after-load 'tramp '(unless (memq tramp-syntax (tramp-compat-funcall (quote tramp-syntax-values))) - (tramp-change-syntax (tramp-compat-tramp-syntax)))) + (tramp-compat-funcall + (quote tramp-change-syntax) (tramp-compat-tramp-syntax)))) (provide 'tramp-compat) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f7b457ebf04..94518d0d359 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3500,21 +3500,10 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (when (and tramp-locked (not tramp-locker)) - (setq tramp-locked nil) - (tramp-error - (car-safe tramp-current-connection) 'file-error - "Forbidden reentrant call of Tramp")) - (let ((tl tramp-locked)) - (setq tramp-locked t) - (unwind-protect - (let ((tramp-locker t)) - (save-match-data - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (apply (cdr fn) args) - (tramp-run-real-handler operation args))))) - (setq tramp-locked tl)))) + (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8d81ac64aa2..9c327c410a7 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2053,6 +2053,33 @@ ARGS are the arguments OPERATION has been called with." `(let ((debug-on-error tramp-debug-on-error)) (condition-case-unless-debug ,var ,bodyform ,@handlers))) +;; In Emacs, there is some concurrency due to timers. If a timer +;; interrupts Tramp and wishes to use the same connection buffer as +;; the "main" Emacs, then garbage might occur in the connection +;; buffer. Therefore, we need to make sure that a timer does not use +;; the same connection buffer as the "main" Emacs. We implement a +;; cheap global lock, instead of locking each connection buffer +;; separately. The global lock is based on two variables, +;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true +;; (with setq) to indicate a lock. But Tramp also calls itself during +;; processing of a single file operation, so we need to allow +;; recursive calls. That's where the `tramp-locker' variable comes in +;; -- it is let-bound to t during the execution of the current +;; handler. So if `tramp-locked' is t and `tramp-locker' is also t, +;; then we should just proceed because we have been called +;; recursively. But if `tramp-locker' is nil, then we are a timer +;; interrupting the "main" Emacs, and then we signal an error. + +(defvar tramp-locked nil + "If non-nil, then Tramp is currently busy. +Together with `tramp-locker', this implements a locking mechanism +preventing reentrant calls of Tramp.") + +(defvar tramp-locker nil + "If non-nil, then a caller has locked Tramp. +Together with `tramp-locked', this implements a locking mechanism +preventing reentrant calls of Tramp.") + ;; Main function. (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. @@ -2090,7 +2117,20 @@ Falls back to normal file name handler if no Tramp file name handler exists." (setq result (catch 'non-essential (catch 'suppress - (apply foreign operation args)))) + (when (and tramp-locked (not tramp-locker)) + (setq tramp-locked nil) + (tramp-error + (car-safe tramp-current-connection) + '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)) + ;; Give timers a chance. + (unless (setq tramp-locked tl) + (sit-for 0.001 'nodisp))))))) (cond ((eq result 'non-essential) (tramp-message @@ -2145,33 +2185,6 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; we don't do anything. (tramp-run-real-handler operation args)))) -;; In Emacs, there is some concurrency due to timers. If a timer -;; interrupts Tramp and wishes to use the same connection buffer as -;; the "main" Emacs, then garbage might occur in the connection -;; buffer. Therefore, we need to make sure that a timer does not use -;; the same connection buffer as the "main" Emacs. We implement a -;; cheap global lock, instead of locking each connection buffer -;; separately. The global lock is based on two variables, -;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true -;; (with setq) to indicate a lock. But Tramp also calls itself during -;; processing of a single file operation, so we need to allow -;; recursive calls. That's where the `tramp-locker' variable comes in -;; -- it is let-bound to t during the execution of the current -;; handler. So if `tramp-locked' is t and `tramp-locker' is also t, -;; then we should just proceed because we have been called -;; recursively. But if `tramp-locker' is nil, then we are a timer -;; interrupting the "main" Emacs, and then we signal an error. - -(defvar tramp-locked nil - "If non-nil, then Tramp is currently busy. -Together with `tramp-locker', this implements a locking mechanism -preventing reentrant calls of Tramp.") - -(defvar tramp-locker nil - "If non-nil, then a caller has locked Tramp. -Together with `tramp-locked', this implements a locking mechanism -preventing reentrant calls of Tramp.") - ;;;###autoload (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler. @@ -3631,31 +3644,17 @@ connection buffer." "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set for process communication also." - ;; FIXME: There are problems, when an asynchronous process runs in - ;; parallel, and also timers are active. See - ;; . - (when (and timer-event-last - (string-prefix-p "*tramp/" (process-name proc)) - (let (result) - (maphash - (lambda (key _value) - (and (processp key) - (not (string-prefix-p "*tramp/" (process-name key))) - (process-live-p key) - (setq result t))) - tramp-cache-data) - result)) - (sit-for 0.01 'nodisp)) (with-current-buffer (process-buffer proc) (let (buffer-read-only last-coding-system-used) - ;; Under Windows XP, accept-process-output doesn't return + ;; Under Windows XP, `accept-process-output' doesn't return ;; sometimes. So we add an additional timeout. JUST-THIS-ONE - ;; is set due to Bug#12145. + ;; is set due to Bug#12145. It is an integer, in order to avoid + ;; running timers as well. (tramp-message proc 10 "%s %s %s\n%s" proc (process-status proc) (with-timeout (timeout) - (accept-process-output proc timeout nil t)) + (accept-process-output proc timeout nil 0)) (buffer-string))))) (defun tramp-check-for-regexp (proc regexp) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index a90e3fff355..a10b8579032 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -53,6 +53,8 @@ (defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) (defvar tramp-remote-process-environment) +;; Suppress nasty messages. +(fset 'shell-command-sentinel 'ignore) ;; There is no default value on w32 systems, which could work out of the box. (defconst tramp-test-temporary-file-directory @@ -126,29 +128,52 @@ If QUOTED is non-nil, the local part of the file is quoted." (make-temp-name "tramp-test") (if local temporary-file-directory tramp-test-temporary-file-directory)))) +;; Don't print messages in nested `tramp--instrument-test-case' calls. +(defvar tramp--instrument-test-case-p nil + "Whether `tramp--instrument-test-case' run. +This shall used dynamically bound only.") + (defmacro tramp--instrument-test-case (verbose &rest body) "Run BODY with `tramp-verbose' equal VERBOSE. Print the the content of the Tramp debug buffer, if BODY does not eval properly in `should' or `should-not'. `should-error' is not handled properly. BODY shall not contain a timeout." (declare (indent 1) (debug (natnump body))) - `(let ((tramp-verbose ,verbose) + `(let ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) + (tramp-message-show-message t) (tramp-debug-on-error t) (debug-ignored-errors - (cons "^make-symbolic-link not supported$" debug-ignored-errors))) + (cons "^make-symbolic-link not supported$" debug-ignored-errors)) + inhibit-message) (unwind-protect - (progn ,@body) - (when (> tramp-verbose 3) + (let ((tramp--instrument-test-case-p t)) ,@body) + ;; Unwind forms. + (when (and (null tramp--instrument-test-case-p) (> tramp-verbose 3)) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (with-current-buffer (tramp-get-connection-buffer v) (message "%s" (buffer-string))) (with-current-buffer (tramp-get-debug-buffer v) (message "%s" (buffer-string)))))))) +(defsubst tramp--test-message (fmt-string &rest arguments) + "Emit a message into ERT *Messages*." + (tramp--instrument-test-case 0 + (apply + 'tramp-message + (tramp-dissect-file-name tramp-test-temporary-file-directory) 0 + fmt-string arguments))) + +(defsubst tramp--test-backtrace () + "Dump a backtrace into ERT *Messages*." + (tramp--instrument-test-case 10 + (tramp-backtrace + (tramp-dissect-file-name tramp-test-temporary-file-directory)))) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) - (message "Remote directory: `%s'" tramp-test-temporary-file-directory) + (tramp--test-message + "Remote directory: `%s'" tramp-test-temporary-file-directory) (should (ignore-errors (and (file-remote-p tramp-test-temporary-file-directory) @@ -2759,6 +2784,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) + ;; Suppress nasty messages. + (inhibit-message t) kill-buffer-query-functions) (unwind-protect (with-temp-buffer @@ -2787,7 +2814,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (async-shell-command (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) - (set-process-sentinel (get-buffer-process (current-buffer)) nil) ;; Read output. (with-timeout (10 (ert-fail "`async-shell-command' timed out")) (while (< (- (point-max) (point-min)) @@ -2816,7 +2842,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) (async-shell-command "read line; ls $line" (current-buffer)) - (set-process-sentinel (get-buffer-process (current-buffer)) nil) (process-send-string (get-buffer-process (current-buffer)) (format "%s\n" (file-name-nondirectory tmp-name))) @@ -2847,8 +2872,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer (async-shell-command command (current-buffer)) - ;; Suppress nasty messages. - (set-process-sentinel (get-buffer-process (current-buffer)) nil) (with-timeout (10) (while (get-buffer-process (current-buffer)) (accept-process-output (get-buffer-process (current-buffer)) 0.1))) @@ -3046,11 +3069,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We must force a reconnect, in order to activate $BZR_HOME. (tramp-cleanup-connection (tramp-dissect-file-name tramp-test-temporary-file-directory) - nil 'keep-password) + 'keep-debug 'keep-password) '(Bzr)) - (t nil))))) + (t nil)))) + ;; Suppress nasty messages. + (inhibit-message t)) (skip-unless vc-handled-backends) - (message "%s" vc-handled-backends) + (unless quoted (tramp--test-message "%s" vc-handled-backends)) (unwind-protect (progn @@ -3656,90 +3681,114 @@ Use the `ls' command." "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - ;; Mark as failed until bug has been fixed. - :expected-result :failed :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - ;; Keep instrumentation verbosity 0 until Tramp bug is fixed. - ;; This has the side effect, that this test fails instead to - ;; abort. Good for hydra. - (tramp--instrument-test-case 0 - (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) - (default-directory tmp-name) - (remote-file-name-inhibit-cache t) - timer buffers kill-buffer-query-functions) + (let* ((tmp-name (tramp--test-make-temp-name)) + (default-directory tmp-name) + ;; Do not cache Tramp properties. + (remote-file-name-inhibit-cache t) + (process-file-side-effects t) + ;; Suppress nasty messages. + (inhibit-message t) + (number-proc 10) + (timer-repeat 1) + ;; We must distinguish due to performance reasons. + (timer-operation + (cond + ((string-equal "mock" (file-remote-p tmp-name 'method)) + 'vc-registered) + (t 'file-attributes))) + timer buffers kill-buffer-query-functions) - (unwind-protect - (progn - (make-directory tmp-name) - - ;; Setup a timer in order to raise an ordinary command - ;; again and again. `vc-registered' is well suited, - ;; because there are many checks. - (setq - timer - (run-at-time - 0 1 - (lambda () - (when buffers - (vc-registered - (buffer-name (nth (random (length buffers)) buffers))))))) - - ;; Create temporary buffers. The number of buffers - ;; corresponds to the number of processes; it could be - ;; increased in order to make pressure on Tramp. - (dotimes (_i 5) - (add-to-list 'buffers (generate-new-buffer "*temp*"))) - - ;; Open asynchronous processes. Set process sentinel. - (dolist (buf buffers) - (async-shell-command "read line; touch $line; echo $line" buf) + (unwind-protect + (progn + (make-directory tmp-name) + + ;; Setup a timer in order to raise an ordinary command again + ;; and again. `vc-registered' is well suited, because there + ;; are many checks. + (setq + timer + (run-at-time + 0 timer-repeat + (lambda () + (when buffers + (let ((file + (buffer-name (nth (random (length buffers)) buffers)))) + (funcall timer-operation file)))))) + + ;; Create temporary buffers. The number of buffers + ;; corresponds to the number of processes; it could be + ;; increased in order to make pressure on Tramp. + (dotimes (_i number-proc) + (add-to-list 'buffers (generate-new-buffer "foo"))) + + ;; Open asynchronous processes. Set process sentinel. + (dolist (buf buffers) + (let ((proc + (start-file-process-shell-command + (buffer-name buf) buf + (concat + "(read line && echo $line >$line);" + "(read line && cat $line);" + "(read line && rm $line)"))) + (file (expand-file-name (buffer-name buf)))) + ;; Remember the file name. Add counter. + (process-put proc 'foo file) + (process-put proc 'bar 0) + ;; Add process filter. + (set-process-filter + proc + (lambda (proc string) + (with-current-buffer (process-buffer proc) + (insert string)) + (unless (zerop (length string)) + (should (file-attributes (process-get proc 'foo)))))) + ;; Add process sentinel. (set-process-sentinel - (get-buffer-process buf) + proc (lambda (proc _state) - (delete-file (buffer-name (process-buffer proc)))))) - - ;; Send a string. Use a random order of the buffers. Mix - ;; with regular operation. - (let ((buffers (copy-sequence buffers)) - buf) - (while buffers - (setq buf (nth (random (length buffers)) buffers)) - (process-send-string - (get-buffer-process buf) (format "'%s'\n" buf)) - (file-attributes (buffer-name buf)) - (setq buffers (delq buf buffers)))) - - ;; Wait until the whole output has been read. - (with-timeout ((* 10 (length buffers)) - (ert-fail "`async-shell-command' timed out")) - (let ((buffers (copy-sequence buffers)) - buf) - (while buffers - (setq buf (nth (random (length buffers)) buffers)) - (if (ignore-errors - (memq (process-status (get-buffer-process buf)) - '(run open))) - (accept-process-output (get-buffer-process buf) 0.1) - (setq buffers (delq buf buffers)))))) - - ;; Check. - (dolist (buf buffers) - (with-current-buffer buf - (should - (string-equal (format "'%s'\n" buf) (buffer-string))))) - (should-not - (directory-files - tmp-name nil directory-files-no-dot-files-regexp))) - - ;; Cleanup. - (ignore-errors (cancel-timer timer)) - (ignore-errors (delete-directory tmp-name 'recursive)) - (dolist (buf buffers) - (ignore-errors (kill-buffer buf)))))))) + (should-not (file-attributes (process-get proc 'foo))))))) + + ;; Send a string. Use a random order of the buffers. Mix + ;; with regular operation. + (let ((buffers (copy-sequence buffers))) + (while buffers + (let* ((buf (nth (random (length buffers)) buffers)) + (proc (get-buffer-process buf)) + (file (process-get proc 'foo)) + (count (process-get proc 'bar))) + ;; Regular operation. + (if (= count 0) + (should-not (file-attributes file)) + (should (file-attributes file))) + ;; Send string to process. + (process-send-string proc (format "%s\n" (buffer-name buf))) + (accept-process-output proc 0.1 nil 0) + ;; Regular operation. + (if (= count 2) + (should-not (file-attributes file)) + (should (file-attributes file))) + (process-put proc 'bar (1+ count)) + (unless (process-live-p proc) + (setq buffers (delq buf buffers)))))) + + ;; Checks. All process output shall exists in the + ;; respective buffers. All created files shall be deleted. + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (format "%s\n" buf) (buffer-string))))) + (should-not + (directory-files tmp-name nil directory-files-no-dot-files-regexp))) + + ;; Cleanup. + (dolist (buf buffers) + (ignore-errors (delete-process (get-buffer-process buf))) + (ignore-errors (kill-buffer buf))) + (ignore-errors (cancel-timer timer)) + (ignore-errors (delete-directory tmp-name 'recursive))))) (ert-deftest tramp-test37-recursive-load () "Check that Tramp does not fail due to recursive load." @@ -3836,8 +3885,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?). ;; * Fix Bug#27009. Set expected error of ;; `tramp-test29-environment-variables-and-port-numbers'. -;; * Fix Bug#16928. Set expected error of `tramp-test36-asynchronous-requests'. -;; * Fix `tramp-test38-unload' (Not all symbols are unbound). Set +;; * Fix Bug#16928 in `tramp-test36-asynchronous-requests'. +;; * Fix `tramp-test39-unload' (Not all symbols are unbound). Set ;; expected error. (defun tramp-test-all (&optional interactive) -- 2.39.2