[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master b32ac17: Work on accept-process-output in Tramp
|
From: |
Michael Albinus |
|
Subject: |
[Emacs-diffs] master b32ac17: Work on accept-process-output in Tramp |
|
Date: |
Sun, 3 Feb 2019 05:07:46 -0500 (EST) |
branch: master
commit b32ac17c32486d8fce0fb9ecd5e09fe324448d3d
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
Work on accept-process-output in Tramp
* 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'.
---
lisp/net/tramp-adb.el | 38 ++++------------
lisp/net/tramp-gvfs.el | 2 +-
lisp/net/tramp-rclone.el | 24 +++--------
lisp/net/tramp.el | 32 +++++++++++---
test/lisp/net/tramp-tests.el | 100 +++++++++++++++++++++++++------------------
5 files changed, 100 insertions(+), 96 deletions(-)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index d45695c..b9b1e4a 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -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."
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 1f14549..bc45acd 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -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))
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 77ff6d5..9f46adb 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -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.
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 54a84ca..b1c0669 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -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)))))
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 129ffe9..dccef81 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -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 ()
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master b32ac17: Work on accept-process-output in Tramp,
Michael Albinus <=