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'.

diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index d45695cbecce03466849d0e8623bec80ab07e0c1..b9b1e4aab6c0e736720e4b55398b12117be0ceef 100644 (file)
--- 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 1f1454925ca2fa8533672d797fb951aea352a654..bc45acd3ce644e2ba3a274010d5f8ab50d6fcaf0 100644 (file)
--- 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 77ff6d59a593d2d939876d9214f5cfc2be40287d..9f46adb4da69b3e9861449962307bbe979ce8aed 100644 (file)
--- 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")))))
 
 \f
 ;; File name primitives.

diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 54a84ca122f9a63a0a933d19c00c3b409330ec86..b1c066904810bda50eefeb68b73eaa01288713fe 100644 (file)
--- 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 129ffe9eee7f2380bb40d6bfbd75e9799f14b553..dccef81b7b52e6e9bb934f7a11c0b108f10684a1 100644 (file)
--- 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 ()