procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Work on accept-process-output in Tramp

Browse source 
* lisp/net/tramp.el (tramp-accept-process-output): Rework timer
handling.
(tramp-call-process): Adapt VEC if nil.
(tramp-interrupt-process): Use `tramp-accept-process-output'.
(tramp-process-lines): New defun.
* lisp/net/tramp-adb.el (tramp-adb-parse-device-names):
* lisp/net/tramp-rclone.el (tramp-rclone-parse-device-names): Use it.

* lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-notify-add-watch):
Use timeout 0 in `tramp-accept-process-output'.

* test/lisp/net/tramp-tests.el (tramp--test-timeout-handler): Move up.
(tramp-test29-start-file-process, tramp-test30-make-process)
(tramp-test32-shell-command)
(tramp--test-shell-command-to-string-asynchronously): Use it.
(tramp-test35-remote-path): Suppress warning.
(tramp--test-asynchronous-requests-timeout): New defconst.
(tramp-test43-asynchronous-requests): Skip if not the only test.
Use `tramp--test-asynchronous-requests-timeout'.
Remove instrumentation.  Use `start-process-shell-command' for
watchdog.  Add timeout in timer function.  Print status messages.
Remove file operations from sentinel.  Suppress timers in
`accept-process-output'.
This commit is contained in:
Michael Albinus 2019-02-03 11:07:36 +01:00
parent 713eece307
commit b32ac17c32
5 changed files with 100 additions and 96 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
lisp/net/tramp-adb.el
View file

@ -191,36 +191,14 @@ pass to the OPERATION."
;;;###tramp-autoload
(defun tramp-adb-parse-device-names (_ignore)
"Return a list of (nil host) tuples allowed to access."
(with-timeout (10)
(with-temp-buffer
;; `call-process' does not react on timer under MS Windows.
;; That's why we use `start-process'.
;; We don't know yet whether we need a user or host name for the
;; connection vector. We assume we don't, it will be OK in most
;; of the cases. Otherwise, there might be an additional trace
;; buffer, which doesn't hurt.
(let ((p (start-process
tramp-adb-program (current-buffer) tramp-adb-program "devices"))
(v (make-tramp-file-name :method tramp-adb-method))
result)
(tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " "))
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
(while (accept-process-output p nil nil t))
(tramp-message v 6 "\n%s" (buffer-string))
(goto-char (point-min))
(while (search-forward-regexp "^\\(\\S-+\\)[[:space:]]+device$" nil t)
(push (list nil (match-string 1)) result))
;; Replace ":" by "#".
(mapc
(lambda (elt)
(setcar
(cdr elt)
(replace-regexp-in-string
":" tramp-prefix-port-format (car (cdr elt)))))
result)
result))))
(delq nil
(mapcar
(lambda (line)
(when (string-match "^\\(\\S-+\\)[[:space:]]+device$" line)
;; Replace ":" by "#".
`(nil ,(replace-regexp-in-string
":" tramp-prefix-port-format (match-string 1 line)))))
(tramp-process-lines nil tramp-adb-program "devices"))))
(defun tramp-adb-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."

2
lisp/net/tramp-gvfs.el
View file

@ -1186,7 +1186,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(set-process-filter p 'tramp-gvfs-monitor-process-filter)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
(while (tramp-accept-process-output p))
(while (tramp-accept-process-output p 0))
(unless (process-live-p p)
(tramp-error
p 'file-notify-error "Monitoring not supported for `%s'" file-name))

24
lisp/net/tramp-rclone.el
View file

@ -171,24 +171,12 @@ pass to the OPERATION."
(defun tramp-rclone-parse-device-names (_ignore)
"Return a list of (nil host) tuples allowed to access."
(with-tramp-connection-property nil "rclone-device-names"
(with-timeout (10)
(with-temp-buffer
;; `call-process' does not react on timer under MS Windows.
;; That's why we use `start-process'.
(let ((p (start-process
tramp-rclone-program (current-buffer)
tramp-rclone-program "listremotes"))
(v (make-tramp-file-name :method tramp-rclone-method))
result)
(tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " "))
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
(while (accept-process-output p nil nil t))
(tramp-message v 6 "\n%s" (buffer-string))
(goto-char (point-min))
(while (search-forward-regexp "^\\(\\S-+\\):$" nil t)
(push (list nil (match-string 1)) result))
result)))))
(delq nil
(mapcar
(lambda (line)
(when (string-match "^\\(\\S-+\\):$" line)
`(nil ,(match-string 1 line))))
(tramp-process-lines nil tramp-rclone-program "listremotes")))))
;; File name primitives.

32
lisp/net/tramp.el
View file

@ -4111,15 +4111,18 @@ for process communication also."
(let ((inhibit-read-only t)
last-coding-system-used
;; We do not want to run timers.
(stimers (with-timeout-suspend))
timer-list timer-idle-list
result)
;; JUST-THIS-ONE is set due to Bug#12145. It is an integer, in
;; order to avoid running timers.
;; JUST-THIS-ONE is set due to Bug#12145.
(tramp-message
proc 10 "%s %s %s %s\n%s"
proc timeout (process-status proc)
(setq result (accept-process-output proc timeout nil 0))
(with-local-quit
(setq result (accept-process-output proc timeout nil t)))
(buffer-string))
;; Reenable the timers.
(with-timeout-unsuspend stimers)
result)))
(defun tramp-check-for-regexp (proc regexp)
@ -4640,6 +4643,7 @@ PROGRAM is nil is trapped also, returning 1. Furthermore, traces
are written with verbosity of 6."
(let ((default-directory (tramp-compat-temporary-file-directory))
(destination (if (eq destination t) (current-buffer) destination))
(vec (or vec (car tramp-current-connection)))
output error result)
(tramp-message
vec 6 "`%s %s' %s %s"
@ -4694,6 +4698,25 @@ are written with verbosity of 6."
(tramp-message vec 6 "%d\n%s" result (error-message-string err))))
result))
(defun tramp-process-lines
(vec program &rest args)
"Calls `process-lines' on the local host.
If an error occurs, it returns nil. Traces are written with
verbosity of 6."
(let ((default-directory (tramp-compat-temporary-file-directory))
(vec (or vec (car tramp-current-connection)))
result)
(if args
(tramp-message vec 6 "%s %s" program (mapconcat 'identity args " "))
(tramp-message vec 6 "%s" program))
(setq result
(condition-case err
(apply 'process-lines program args)
(error
(tramp-error vec (car err) (cdr err)))))
(tramp-message vec 6 "%s" result)
result))
(defun tramp-read-passwd (proc &optional prompt)
"Read a password from user (compat function).
Consults the auth-source package.
@ -4852,8 +4875,7 @@ Only works for Bourne-like shells."
;; Wait, until the process has disappeared. If it doesn't,
;; fall back to the default implementation.
(with-timeout (1 (ignore))
;; We cannot run `tramp-accept-process-output', it blocks timers.
(while (accept-process-output proc nil nil t))
(while (tramp-accept-process-output proc))
;; Report success.
proc)))))

100
test/lisp/net/tramp-tests.el
View file

@ -3798,6 +3798,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
;; Must be a command, because used as `sigusr' handler.
(defun tramp--test-timeout-handler (&rest _ignore)
"Timeout handler, reporting a failed test."
(interactive)
(ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
(ert-deftest tramp-test29-start-file-process ()
"Check `start-file-process'."
:tags '(:expensive-test)
@ -3816,7 +3822,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
(with-timeout (10 (ert-fail "`start-file-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3834,7 +3840,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"cat" (file-name-nondirectory tmp-name)))
(should (processp proc))
;; Read output.
(with-timeout (10 (ert-fail "`start-file-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3855,7 +3861,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
(with-timeout (10 (ert-fail "`start-file-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3888,7 +3894,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
(with-timeout (10 (ert-fail "`make-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3908,7 +3914,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
:file-handler t))
(should (processp proc))
;; Read output.
(with-timeout (10 (ert-fail "`make-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3933,7 +3939,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-string proc "foo")
(process-send-eof proc)
;; Read output.
(with-timeout (10 (ert-fail "`make-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (< (- (point-max) (point-min)) (length "foo"))
(while (accept-process-output proc 0 nil t))))
(should (string-equal (buffer-string) "foo")))
@ -3957,7 +3963,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(process-send-eof proc)
(delete-process proc)
;; Read output.
(with-timeout (10 (ert-fail "`make-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
(should (string-equal (buffer-string) "killed\n")))
@ -3977,7 +3983,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should (processp proc))
;; Read stderr.
(with-current-buffer stderr
(with-timeout (10 (ert-fail "`make-process' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (= (point-min) (point-max))
(while (accept-process-output proc 0 nil t))))
(should
@ -4054,7 +4060,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(format "ls %s" (file-name-nondirectory tmp-name))
(current-buffer))
;; Read output.
(with-timeout (10 (ert-fail "`async-shell-command' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output
(get-buffer-process (current-buffer)) nil nil t)))
;; `ls' could produce colorized output.
@ -4083,7 +4089,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(get-buffer-process (current-buffer))
(format "%s\n" (file-name-nondirectory tmp-name)))
;; Read output.
(with-timeout (10 (ert-fail "`async-shell-command' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output
(get-buffer-process (current-buffer)) nil nil t)))
;; `ls' could produce colorized output.
@ -4107,7 +4113,7 @@ 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))
(with-timeout (10 (ert-fail "`async-shell-command-to-string' timed out"))
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output
(get-buffer-process (current-buffer)) nil nil t)))
(buffer-substring-no-properties (point-min) (point-max))))
@ -4326,7 +4332,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(let* ((tmp-name (tramp--test-make-temp-name))
(default-directory tramp-test-temporary-file-directory)
(orig-exec-path (exec-path))
(orig-exec-path (with-no-warnings (exec-path)))
(tramp-remote-path tramp-remote-path)
(orig-tramp-remote-path tramp-remote-path))
(unwind-protect
@ -5204,9 +5210,11 @@ Use the `ls' command."
(numberp (nth 1 fsi))
(numberp (nth 2 fsi))))))
(defun tramp--test-timeout-handler ()
"Timeout handler, reporting a failed test."
(ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
;; `tramp-test43-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'.")
;; This test is inspired by Bug#16928.
(ert-deftest tramp-test43-asynchronous-requests ()
@ -5216,26 +5224,27 @@ process sentinels. They shall not disturb each other."
;; The test fails from time to time, w/o a reproducible pattern. So
;; we mark it as unstable.
:tags '(:expensive-test :unstable)
;; Recent investigations have uncovered a race condition in
;; `accept-process-output'. Let's check on emba, whether this has
;; been solved.
;; (if (getenv "EMACS_EMBA_CI") '(:expensive-test) '(:expensive-test :unstable))
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
;; This test is sensible wrt to other running tests. Let it work
;; only if it is the only selected test.
;; FIXME: There must be a better solution.
(skip-unless
(= 1 (length
(ert-select-tests (ert--stats-selector ert--current-run-stats) t))))
;; This test could be blocked on hydra. So we set a timeout of 300
;; seconds, and we send a SIGUSR1 signal after 300 seconds.
;; This clearly doesn't work though, because the test not
;; infrequently hangs for hours until killed by the infrastructure.
(with-timeout (300 (tramp--test-timeout-handler))
(with-timeout
(tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler))
(define-key special-event-map [sigusr1] 'tramp--test-timeout-handler)
(tramp--test-instrument-test-case (if (getenv "EMACS_HYDRA_CI") 10 0)
(let* (;; For the watchdog.
(default-directory (expand-file-name temporary-file-directory))
(shell-file-name "/bin/sh")
(watchdog
(start-process
"*watchdog*" nil shell-file-name shell-command-switch
(format "sleep 300; kill -USR1 %d" (emacs-pid))))
(start-process-shell-command
"*watchdog*" nil
(format
"sleep %d; kill -USR1 %d"
tramp--test-asynchronous-requests-timeout (emacs-pid))))
(tmp-name (tramp--test-make-temp-name))
(default-directory tmp-name)
;; Do not cache Tramp properties.
@ -5263,6 +5272,9 @@ process sentinels. They shall not disturb each other."
(cond
((tramp--test-mock-p) 'vc-registered)
(t 'file-attributes)))
;; This is when all timers start. We check inside the
;; timer function, that we don't exceed timeout.
(timer-start (current-time))
timer buffers kill-buffer-query-functions)
(unwind-protect
@ -5277,6 +5289,9 @@ process sentinels. They shall not disturb each other."
(run-at-time
0 timer-repeat
(lambda ()
(when (> (- (time-to-seconds) (time-to-seconds timer-start))
tramp--test-asynchronous-requests-timeout)
(tramp--test-timeout-handler))
(when buffers
(let ((time (float-time))
(default-directory tmp-name)
@ -5286,12 +5301,13 @@ process sentinels. They shall not disturb each other."
"Start timer %s %s" file (current-time-string))
(funcall timer-operation file)
;; Adjust timer if it takes too much time.
(tramp--test-message
"Stop timer %s %s" file (current-time-string))
(when (> (- (float-time) time) timer-repeat)
(setq timer-repeat (* 1.5 timer-repeat))
(setf (timer--repeat-delay timer) timer-repeat)
(tramp--test-message "Increase timer %s" timer-repeat))
(tramp--test-message
"Stop timer %s %s" file (current-time-string)))))))
(tramp--test-message
"Increase timer %s" timer-repeat)))))))
;; Create temporary buffers. The number of buffers
;; corresponds to the number of processes; it could be
@ -5307,9 +5323,9 @@ process sentinels. They shall not disturb each other."
(start-file-process-shell-command
(buffer-name buf) buf
(concat
"(read line && echo $line >$line);"
"(read line && cat $line);"
"(read line && rm $line)")))
"(read line && echo $line >$line && echo $line);"
"(read line && cat $line);"
"(read line && rm -f $line)")))
(file (expand-file-name (buffer-name buf))))
;; Remember the file name. Add counter.
(process-put proc 'foo file)
@ -5325,17 +5341,16 @@ process sentinels. They shall not disturb each other."
(unless (zerop (length string))
(dired-uncache (process-get proc 'foo))
(should (file-attributes (process-get proc 'foo))))))
;; Add process sentinel.
;; Add process sentinel. It shall not perform remote
;; operations, triggering Tramp processes. This blocks.
(set-process-sentinel
proc
(lambda (proc _state)
(tramp--test-message
"Process sentinel %s %s" proc (current-time-string))
(dired-uncache (process-get proc 'foo))
(should-not (file-attributes (process-get proc 'foo)))))))
"Process sentinel %s %s" proc (current-time-string))))))
;; Send a string. Use a random order of the buffers. Mix
;; with regular operation.
;; Send a string to the processes. Use a random order of
;; the buffers. Mix with regular operation.
(let ((buffers (copy-sequence buffers)))
(while buffers
;; Activate timer.
@ -5375,7 +5390,8 @@ process sentinels. They shall not disturb each other."
(tramp--test-message "Check %s" (current-time-string))
(dolist (buf buffers)
(with-current-buffer buf
(should (string-equal (format "%s\n" buf) (buffer-string)))))
(should
(string-equal (format "%s\n%s\n" buf buf) (buffer-string)))))
(should-not
(directory-files
tmp-name nil directory-files-no-dot-files-regexp)))
@ -5387,7 +5403,7 @@ process sentinels. They shall not disturb each other."
(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)))))))
(ignore-errors (delete-directory tmp-name 'recursive))))))
;; This test is inspired by Bug#29163.
(ert-deftest tramp-test44-auto-load ()