commit 49f6243027d910032f014be15b2c4ac2175c25f8 (HEAD, refs/remotes/origin/master) Author: Robert Pluim Date: Thu Jan 31 14:20:32 2019 +0100 Use IPv6 localhost when family is 'ipv6 This fixes Bug#34193 * src/process.c (Fmake_network_process): Explicitly use ::1 when using IPv6 with 'local. Update docstring. * test/lisp/net/network-stream-tests.el (make-ipv6-tcp-server-with-unspecified-port): (make-ipv6-tcp-server-with-specified-port): Test creating ipv6 local server. (make-server): Add optional family argument, default ipv4 (echo-server-with-local-ipv4): Test connecting to 'local ipv4 (echo-server-with-local-ipv6): Test connecting to 'local ipv6 * doc/lispref/processes.texi (Network Processes): Describe behavior when using 'local. * etc/NEWS: Document new 'make-network-process' behavior when connecting to 'local with ipv6. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index fd6686e882..7b02759b30 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2640,7 +2640,9 @@ Specify the host to connect to. @var{host} should be a host name or Internet address, as a string, or the symbol @code{local} to specify the local host. If you specify @var{host} for a server, it must specify a valid address for the local host, and only clients -connecting to that address will be accepted. +connecting to that address will be accepted. When using @code{local}, +by default IPv4 will be used, specify a @var{family} of @code{ipv6} to +override this. @item :service @var{service} @var{service} specifies a port number to connect to; or, for a server, diff --git a/etc/NEWS b/etc/NEWS index cac379fe7e..2e3d92f251 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -324,6 +324,11 @@ write alists of variables to ".dir-locals.el". This is the same syntax that you can see in the example of a ".dir-locals.el" file in the node "(emacs) Directory Variables" of the user manual. ++++ +** Network connections using 'local can now use IPv6. +'make-network-process' now uses the correct loopback address when +asked to use :host 'local and :family 'ipv6. + * Changes in Specialized Modes and Packages in Emacs 27.1 diff --git a/src/process.c b/src/process.c index 728c14a762..9502ef461e 100644 --- a/src/process.c +++ b/src/process.c @@ -3733,6 +3733,8 @@ also nil, meaning that this process is not associated with any buffer. address. The symbol `local' specifies the local host. If specified for a server process, it must be a valid name or address for the local host, and only clients connecting to that address will be accepted. +`local' will use IPv4 by default, use a FAMILY of 'ipv6 to override +this. :service SERVICE -- SERVICE is name of the service desired, or an integer specifying a port number to connect to. If SERVICE is t, @@ -3983,14 +3985,24 @@ usage: (make-network-process &rest ARGS) */) #ifdef HAVE_LOCAL_SOCKETS if (family != AF_LOCAL) #endif - host = build_string ("127.0.0.1"); + { + if (family == AF_INET6) + host = build_string ("::1"); + else + host = build_string ("127.0.0.1"); + } } else { if (EQ (host, Qlocal)) + { /* Depending on setup, "localhost" may map to different IPv4 and/or IPv6 addresses, so it's better to be explicit (Bug#6781). */ - host = build_string ("127.0.0.1"); + if (family == AF_INET6) + host = build_string ("::1"); + else + host = build_string ("127.0.0.1"); + } CHECK_STRING (host); } diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 6ad0c25903..6151c3064c 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -71,12 +71,39 @@ (= (aref (process-contact server :local) 4) 57869))) (delete-process server))) -(defun make-server (host) +(ert-deftest make-ipv6-tcp-server-with-unspecified-port () + (let ((server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service t + :host 'local))) + (should (and (arrayp (process-contact server :local)) + (numberp (aref (process-contact server :local) 8)) + (> (aref (process-contact server :local) 8) 0))) + (delete-process server))) + +(ert-deftest make-ipv6-tcp-server-with-specified-port () + (let ((server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service 57870 + :host 'local))) + (should (and (arrayp (process-contact server :local)) + (= (aref (process-contact server :local) 8) 57870))) + (delete-process server))) + +(defun make-server (host &optional family) (make-network-process :name "server" :server t :noquery t - :family 'ipv4 + :family (or family 'ipv4) :coding 'raw-text-unix :buffer (get-buffer-create "*server*") :service t @@ -129,6 +156,34 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) +(ert-deftest echo-server-with-local-ipv4 () + (let* ((server (make-server 'local 'ipv4)) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host 'local + :family 'ipv4 + :service port))) + (with-current-buffer (process-buffer proc) + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) + +(ert-deftest echo-server-with-local-ipv6 () + (let* ((server (make-server 'local 'ipv6)) + (port (aref (process-contact server :local) 8)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host 'local + :family 'ipv6 + :service port))) + (with-current-buffer (process-buffer proc) + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) + (ert-deftest echo-server-with-ip () (let* ((server (make-server 'local)) (port (aref (process-contact server :local) 4)) commit 4633b0ef3ff7fc8ac013e4236edf782fb3cadfb4 Author: Juri Linkov Date: Sun Feb 3 23:00:29 2019 +0200 * lisp/tar-mode.el (tar-extract): Call tar--try-jka-compr (bug#34251) * lisp/tar-mode.el (tar--try-jka-compr): New function copied from archive-try-jka-compr. * lisp/arc-mode.el (archive-try-jka-compr): Set buffer-multibyte to t instead of let-binding coding-system-for-read to 'no-conversion. * test/data/decompress/tg.tar.gz: * test/data/decompress/zg.zip: New fixtures. * test/lisp/arc-mode-tests.el (arc-mode-test-zip-extract-gz): * test/lisp/tar-mode-tests.el (tar-mode-test-tar-extract-gz): New tests. * test/lisp/vc/diff-mode-tests.el (diff-mode-test-font-lock) (diff-mode-test-font-lock-syntax-one-line): Skip unless shell and diff executables are found. diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 263f251fc0..2b5b6166ad 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -967,9 +967,9 @@ using `make-temp-file', and the generated name is returned." ;; Don't re-compress this data just before decompressing it. (jka-compr-inhibit t)) (write-region (point-min) (point-max) tmpfile nil 'quiet)) + (set-buffer-multibyte t) (erase-buffer) - (let ((coding-system-for-read 'no-conversion)) - (insert-file-contents tmpfile))) + (insert-file-contents tmpfile)) (delete-file tmpfile))))) (defun archive-file-name-handler (op &rest args) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 5b83d173b4..c5382d3f3d 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -852,6 +852,26 @@ actually appear on disk when you save the tar-file's buffer." (goto-char (posn-point (event-end event))) (tar-extract)) +(defun tar--try-jka-compr () + (when (and auto-compression-mode + (jka-compr-get-compression-info buffer-file-name)) + (let* ((basename (file-name-nondirectory buffer-file-name)) + (tmpname (if (string-match ":\\([^:]+\\)\\'" basename) + (match-string 1 basename) basename)) + (tmpfile (make-temp-file (file-name-sans-extension tmpname) + nil + (file-name-extension tmpname 'period)))) + (unwind-protect + (progn + (let ((coding-system-for-write 'no-conversion) + ;; Don't re-compress this data just before decompressing it. + (jka-compr-inhibit t)) + (write-region (point-min) (point-max) tmpfile nil 'quiet)) + (set-buffer-multibyte t) + (erase-buffer) + (insert-file-contents tmpfile)) + (delete-file tmpfile))))) + (defun tar-file-name-handler (op &rest args) "Helper function for `tar-extract'." (or (eq op 'file-exists-p) @@ -931,6 +951,7 @@ actually appear on disk when you save the tar-file's buffer." (setq buffer-file-name new-buffer-file-name) (setq buffer-file-truename (abbreviate-file-name buffer-file-name)) + (tar--try-jka-compr) ;Pretty ugly hack :-( ;; Force buffer-file-coding-system to what ;; decode-coding-region actually used. (set-buffer-file-coding-system last-coding-system-used t) diff --git a/test/data/decompress/tg.tar.gz b/test/data/decompress/tg.tar.gz new file mode 100644 index 0000000000..3dc8185f56 Binary files /dev/null and b/test/data/decompress/tg.tar.gz differ diff --git a/test/data/decompress/zg.zip b/test/data/decompress/zg.zip new file mode 100644 index 0000000000..c4c998ee63 Binary files /dev/null and b/test/data/decompress/zg.zip differ diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index e685767139..79d3ac6365 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -21,6 +21,8 @@ (require 'ert) (require 'arc-mode) +(defvar arc-mode-tests-data-directory + (expand-file-name "test/data/decompress" source-directory)) (ert-deftest arc-mode-test-archive-int-to-mode () (let ((alist (list (cons 448 "-rwx------") @@ -32,6 +34,18 @@ (dolist (x alist) (should (equal (cdr x) (archive-int-to-mode (car x))))))) +(ert-deftest arc-mode-test-zip-extract-gz () + (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract)))) + (skip-unless (executable-find "gzip")) + (let* ((zip-file (expand-file-name "zg.zip" arc-mode-tests-data-directory)) + zip-buffer gz-buffer) + (unwind-protect + (with-current-buffer (setq zip-buffer (find-file-noselect zip-file)) + (setq gz-buffer (archive-extract)) + (should (equal (char-after) ?\N{SNOWFLAKE}))) + (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer)) + (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer))))) + (provide 'arc-mode-tests) ;; arc-mode-tests.el ends here diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 3ad0ced01d..1fce200721 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -21,6 +21,8 @@ (require 'ert) (require 'tar-mode) +(defvar tar-mode-tests-data-directory + (expand-file-name "test/data/decompress" source-directory)) (ert-deftest tar-mode-test-tar-grind-file-mode () (let ((alist (list (cons 448 "rwx------") @@ -31,6 +33,17 @@ (dolist (x alist) (should (equal (cdr x) (tar-grind-file-mode (car x))))))) +(ert-deftest tar-mode-test-tar-extract-gz () + (skip-unless (executable-find "gzip")) + (let* ((tar-file (expand-file-name "tg.tar.gz" tar-mode-tests-data-directory)) + tar-buffer gz-buffer) + (unwind-protect + (with-current-buffer (setq tar-buffer (find-file-noselect tar-file)) + (setq gz-buffer (tar-extract)) + (should (equal (char-after) ?\N{SNOWFLAKE}))) + (when (buffer-live-p tar-buffer) (kill-buffer tar-buffer)) + (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer))))) + (provide 'tar-mode-tests) ;; tar-mode-tests.el ends here diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 8e690548f0..8695d958ba 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -204,6 +204,8 @@ youthfulness (ert-deftest diff-mode-test-font-lock () "Check font-locking of diff hunks." + (skip-unless (executable-find shell-file-name)) + (skip-unless (executable-find diff-command)) (let ((default-directory diff-mode-tests--datadir) (old "hello_world.c") (new "hello_emacs.c") @@ -263,6 +265,8 @@ youthfulness (ert-deftest diff-mode-test-font-lock-syntax-one-line () "Check diff syntax highlighting for one line with no newline at end." + (skip-unless (executable-find shell-file-name)) + (skip-unless (executable-find diff-command)) (let ((default-directory diff-mode-tests--datadir) (old "hello_world_1.c") (new "hello_emacs_1.c") commit b32ac17c32486d8fce0fb9ecd5e09fe324448d3d Author: Michael Albinus Date: Sun Feb 3 11:07:36 2019 +0100 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 d45695cbec..b9b1e4aab6 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 1f1454925c..bc45acd3ce 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 77ff6d59a5..9f46adb4da 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 54a84ca122..b1c0669048 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 129ffe9eee..dccef81b7b 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 ()