Commit 138447c3 authored by Michael Albinus's avatar Michael Albinus
Browse files

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.
parent 3b19663b
......@@ -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)
......
......@@ -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
......
......@@ -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
;; <http://lists.gnu.org/archive/html/tramp-devel/2017-01/msg00010.html>.
(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)
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment