diff options
Diffstat (limited to 'test/src/process-tests.el')
| -rw-r--r-- | test/src/process-tests.el | 442 |
1 files changed, 414 insertions, 28 deletions
diff --git a/test/src/process-tests.el b/test/src/process-tests.el index e15ad47f968..cddf955853e 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -1,6 +1,6 @@ ;;; process-tests.el --- Testing the process facilities -*- lexical-binding: t -*- -;; Copyright (C) 2013-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-2021 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -23,8 +23,11 @@ ;;; Code: +(require 'cl-lib) (require 'ert) (require 'puny) +(require 'rx) +(require 'subr-x) ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -47,13 +50,15 @@ (ert-deftest process-test-sentinel-accept-process-output () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (should (process-test-sentinel-wait-function-working-p - #'accept-process-output))) + #'accept-process-output)))) (ert-deftest process-test-sentinel-sit-for () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (should - (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t)))))) (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () @@ -79,6 +84,7 @@ (ert-deftest process-test-stderr-buffer () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((stdout-buffer (generate-new-buffer "*stdout*")) (stderr-buffer (generate-new-buffer "*stderr*")) (proc (make-process :name "test" @@ -103,10 +109,11 @@ (looking-at "hello stdout!"))) (should (with-current-buffer stderr-buffer (goto-char (point-min)) - (looking-at "hello stderr!"))))) + (looking-at "hello stderr!")))))) (ert-deftest process-test-stderr-filter () (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((sentinel-called nil) (stderr-sentinel-called nil) (stdout-output nil) @@ -145,10 +152,11 @@ (should (equal 1 (with-current-buffer stderr-buffer (point-max)))) (should (equal "hello stderr!\n" - (mapconcat #'identity (nreverse stderr-output) ""))))) + (mapconcat #'identity (nreverse stderr-output) "")))))) (ert-deftest set-process-filter-t () "Test setting process filter to t and back." ;; Bug#36591 + (with-timeout (60 (ert-fail "Test timed out")) (with-temp-buffer (let* ((print-level nil) (print-length nil) @@ -180,11 +188,12 @@ (line-beginning-position) (point-max)) "2> ")) (accept-process-output proc)) ; Read "Two". - (should (equal (buffer-string) "0> one\n1> two\n2> "))))) + (should (equal (buffer-string) "0> one\n1> two\n2> ")))))) (ert-deftest start-process-should-not-modify-arguments () "`start-process' must not modify its arguments in-place." ;; See bug#21831. + (with-timeout (60 (ert-fail "Test timed out")) (let* ((path (pcase system-type ((or 'windows-nt 'ms-dos) ;; Make sure the file name uses forward slashes. @@ -198,11 +207,12 @@ (should (process-live-p (condition-case nil (start-process "" nil path) (error nil)))) - (should (equal path samepath)))) + (should (equal path samepath))))) (ert-deftest make-process/noquery-stderr () "Checks that Bug#30031 is fixed." (skip-unless (executable-find "sleep")) + (with-timeout (60 (ert-fail "Test timed out")) (with-temp-buffer (let* ((previous-processes (process-list)) (process (make-process :name "sleep" @@ -217,7 +227,7 @@ (should new-processes) (dolist (process new-processes) (should-not (process-query-on-exit-flag process)))) - (kill-process process))))) + (kill-process process)))))) ;; Return t if OUTPUT could have been generated by merging the INPUTS somehow. (defun process-tests--mixable (output &rest inputs) @@ -233,6 +243,7 @@ (ert-deftest make-process/mix-stderr () "Check that `make-process' mixes the output streams if STDERR is nil." (skip-unless (executable-find "bash")) + (with-timeout (60 (ert-fail "Test timed out")) ;; Frequent random (?) failures on hydra.nixos.org, with no process output. ;; Maybe this test should be tagged unstable? See bug#31214. (skip-unless (not (getenv "EMACS_HYDRA_CI"))) @@ -251,11 +262,12 @@ (should (eq (process-exit-status process) 0)) (should (process-tests--mixable (string-to-list (buffer-string)) (string-to-list "stdout\n") - (string-to-list "stderr\n")))))) + (string-to-list "stderr\n"))))))) (ert-deftest make-process-w32-debug-spawn-error () "Check that debugger runs on `make-process' failure (Bug#33016)." (skip-unless (eq system-type 'windows-nt)) + (with-timeout (60 (ert-fail "Test timed out")) (let* ((debug-on-error t) (have-called-debugger nil) (debugger (lambda (&rest _) @@ -271,11 +283,12 @@ ;; code. (make-process :name "test" :command '("c:/No-Such-Command")) (error :got-error)))) - (should have-called-debugger))) + (should have-called-debugger)))) (ert-deftest make-process/file-handler/found () - "Check that the ‘:file-handler’ argument of ‘make-process’ + "Check that the `:file-handler’ argument of `make-process’ works as expected if a file name handler is found." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-handler-calls 0)) (cl-flet ((file-handler (&rest args) @@ -292,27 +305,29 @@ works as expected if a file name handler is found." :command '("/some/binary") :file-handler t) 'fake-process)) - (should (= file-handler-calls 1)))))) + (should (= file-handler-calls 1))))))) (ert-deftest make-process/file-handler/not-found () - "Check that the ‘:file-handler’ argument of ‘make-process’ + "Check that the `:file-handler’ argument of `make-process’ works as expected if no file name handler is found." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-name-handler-alist ()) (default-directory invocation-directory) (program (expand-file-name invocation-name invocation-directory))) (should (processp (make-process :name "name" :command (list program "--version") - :file-handler t))))) + :file-handler t)))))) (ert-deftest make-process/file-handler/disable () - "Check ‘make-process’ works as expected if it shouldn’t use the + "Check `make-process’ works as expected if it shouldn’t use the file name handler." + (with-timeout (60 (ert-fail "Test timed out")) (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") #'process-tests--file-handler))) (default-directory "test-handler:/dir/") (program (expand-file-name invocation-name invocation-directory))) (should (processp (make-process :name "name" - :command (list program "--version")))))) + :command (list program "--version"))))))) (defun process-tests--file-handler (operation &rest _args) (cl-ecase operation @@ -325,48 +340,419 @@ file name handler." (ert-deftest make-process/stop () "Check that `make-process' doesn't accept a `:stop' key. See Bug#30460." + (with-timeout (60 (ert-fail "Test timed out")) (should-error (make-process :name "test" :command (list (expand-file-name invocation-name invocation-directory)) - :stop t))) + :stop t)))) ;; All the following tests require working DNS, which appears not to ;; be the case for hydra.nixos.org, so disable them there for now. (ert-deftest lookup-family-specification () - "network-lookup-address-info should only accept valid family symbols." + "`network-lookup-address-info' should only accept valid family symbols." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "google.com" 'both)) (should (network-lookup-address-info "google.com" 'ipv4)) (when (featurep 'make-network-process '(:family ipv6)) - (should (network-lookup-address-info "google.com" 'ipv6)))) + (should (network-lookup-address-info "google.com" 'ipv6))))) (ert-deftest lookup-unicode-domains () - "Unicode domains should fail" + "Unicode domains should fail." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "faß.de")) - (should (network-lookup-address-info (puny-encode-domain "faß.de")))) + (should (network-lookup-address-info (puny-encode-domain "faß.de"))))) (ert-deftest unibyte-domain-name () - "Unibyte domain names should work" + "Unibyte domain names should work." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - (should (network-lookup-address-info (string-to-unibyte "google.com")))) + (with-timeout (60 (ert-fail "Test timed out")) + (should (network-lookup-address-info (string-to-unibyte "google.com"))))) (ert-deftest lookup-google () - "Check that we can look up google IP addresses" + "Check that we can look up google IP addresses." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-timeout (60 (ert-fail "Test timed out")) (let ((addresses-both (network-lookup-address-info "google.com")) (addresses-v4 (network-lookup-address-info "google.com" 'ipv4))) (should addresses-both) (should addresses-v4)) (when (featurep 'make-network-process '(:family ipv6)) - (should (network-lookup-address-info "google.com" 'ipv6)))) + (should (network-lookup-address-info "google.com" 'ipv6))))) (ert-deftest non-existent-lookup-failure () + "Check that looking up non-existent domain returns nil." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - "Check that looking up non-existent domain returns nil" - (should (eq nil (network-lookup-address-info "emacs.invalid")))) + (with-timeout (60 (ert-fail "Test timed out")) + (should (eq nil (network-lookup-address-info "emacs.invalid"))))) + +(defmacro process-tests--ignore-EMFILE (&rest body) + "Evaluate BODY, ignoring EMFILE errors." + (declare (indent 0) (debug t)) + (let ((err (make-symbol "err")) + (message (make-symbol "message"))) + `(let ((,message (process-tests--EMFILE-message))) + (condition-case ,err + ,(macroexp-progn body) + (file-error + ;; If we couldn't determine the EMFILE message, just ignore + ;; all `file-error' signals. + (and ,message + (not (string-equal (caddr ,err) ,message)) + (signal (car ,err) (cdr ,err)))))))) + +(defmacro process-tests--with-buffers (var &rest body) + "Bind VAR to nil and evaluate BODY. +Afterwards, kill all buffers in the list VAR. BODY should add +some buffer objects to VAR." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + `(let ((,var nil)) + (unwind-protect + ,(macroexp-progn body) + (mapc #'kill-buffer ,var)))) + +(defmacro process-tests--with-processes (var &rest body) + "Bind VAR to nil and evaluate BODY. +Afterwards, delete all processes in the list VAR. BODY should +add some process objects to VAR." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + `(let ((,var nil)) + (unwind-protect + ,(macroexp-progn body) + (mapc #'delete-process ,var)))) + +(defmacro process-tests--with-raised-rlimit (&rest body) + "Evaluate BODY using a higher limit for the number of open files. +Attempt to set the resource limit for the number of open files +temporarily to the highest possible value." + (declare (indent 0) (debug t)) + (let ((prlimit (make-symbol "prlimit")) + (soft (make-symbol "soft")) + (hard (make-symbol "hard")) + (pid-arg (make-symbol "pid-arg"))) + `(let ((,prlimit (executable-find "prlimit")) + (,pid-arg (format "--pid=%d" (emacs-pid))) + (,soft nil) (,hard nil)) + (cl-flet ((set-limit + (value) + (cl-check-type value natnum) + (when ,prlimit + (call-process ,prlimit nil nil nil + ,pid-arg + (format "--nofile=%d:" value))))) + (when ,prlimit + (with-temp-buffer + (when (eql (call-process ,prlimit nil t nil + ,pid-arg "--nofile" + "--raw" "--noheadings" + "--output=SOFT,HARD") + 0) + (goto-char (point-min)) + (when (looking-at (rx (group (+ digit)) (+ blank) + (group (+ digit)) ?\n)) + (setq ,soft (string-to-number + (match-string-no-properties 1)) + ,hard (string-to-number + (match-string-no-properties 2)))))) + (and ,soft ,hard (< ,soft ,hard) + (set-limit ,hard))) + (unwind-protect + ,(macroexp-progn body) + (when ,soft (set-limit ,soft))))))) + +(defmacro process-tests--fd-setsize-test (&rest body) + "Run BODY as a test for FD_SETSIZE overflow. +Try to generate pipe processes until we are close to the +FD_SETSIZE limit. Within BODY, only a small number of file +descriptors should still be available. Furthermore, raise the +maximum number of open files in the Emacs process above +FD_SETSIZE." + (declare (indent 0) (debug t)) + (let ((process (make-symbol "process")) + (processes (make-symbol "processes")) + (buffer (make-symbol "buffer")) + (buffers (make-symbol "buffers")) + ;; FD_SETSIZE is typically 1024 on Unix-like systems. On + ;; MS-Windows we artificially limit FD_SETSIZE to 64, see the + ;; commentary in w32proc.c. + (fd-setsize (if (eq system-type 'windows-nt) 64 1024))) + `(process-tests--with-raised-rlimit + (process-tests--with-buffers ,buffers + (process-tests--with-processes ,processes + ;; First, allocate enough pipes to definitely exceed the + ;; FD_SETSIZE limit. + (cl-loop for i from 1 to ,(1+ fd-setsize) + for ,buffer = (generate-new-buffer + (format " *pipe %d*" i)) + do (push ,buffer ,buffers) + for ,process = (process-tests--ignore-EMFILE + (make-pipe-process + :name (format "pipe %d" i) + ;; Prevent delete-process from + ;; trying to read from pipe + ;; processes that didn't exit + ;; yet, because no one is + ;; writing to those pipes, and + ;; the read will stall. + :stop (eq system-type 'windows-nt) + :buffer ,buffer + :coding 'no-conversion + :noquery t)) + while ,process + do (push ,process ,processes)) + (unless (cddr ,processes) + (ert-fail "Couldn't allocate enough pipes")) + ;; Delete two pipes to test more edge cases. + (delete-process (pop ,processes)) + (delete-process (pop ,processes)) + ,@body))))) + +(defmacro process-tests--with-temp-file (var &rest body) + "Bind VAR to the name of a new regular file and evaluate BODY. +Afterwards, delete the file." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + (let ((file (make-symbol "file"))) + `(let ((,file (make-temp-file "emacs-test-"))) + (unwind-protect + (let ((,var ,file)) + ,@body) + (delete-file ,file))))) + +(defmacro process-tests--with-temp-directory (var &rest body) + "Bind VAR to the name of a new directory and evaluate BODY. +Afterwards, delete the directory." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type var symbol) + (let ((dir (make-symbol "dir"))) + `(let ((,dir (make-temp-file "emacs-test-" :dir))) + (unwind-protect + (let ((,var ,dir)) + ,@body) + (delete-directory ,dir :recursive))))) + +;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests +;; generate lots of process objects of the various kinds. Running the +;; tests with assertions enabled should not result in any crashes due +;; to file descriptor set overflow. These tests first generate lots +;; of unused pipe processes to fill up the file descriptor space. +;; Then, they create a few instances of the process type under test. + +(ert-deftest process-tests/fd-setsize-no-crash/make-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (let ((sleep (executable-find "sleep"))) + (skip-unless sleep) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type `%s'" conn-type)) + (process-tests--fd-setsize-test + (process-tests--with-processes processes + ;; Start processes until we exhaust the file descriptor + ;; set size. We assume that each process requires at + ;; least one file descriptor. + (dotimes (i 10) + (let ((process + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we + ;; ignore `file-error'. + (process-tests--ignore-EMFILE + (make-process :name (format "test %d" i) + :command (list sleep "5") + :connection-type conn-type + :coding 'no-conversion + :noquery t)))) + (when process (push process processes)))) + ;; We should have managed to start at least one process. + (should processes) + (dolist (process processes) + (while (accept-process-output process)) + (should (eq (process-status process) 'exit)) + ;; If there's an error between fork and exec, Emacs + ;; will use exit statuses between 125 and 127, see + ;; process.h. This can happen if the child process + ;; tries to set up terminal device but fails due to + ;; file number limits. We don't treat this as an + ;; error. + (should (memql (process-exit-status process) + '(0 125 126 127))))))))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-pipe-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--fd-setsize-test + (process-tests--with-buffers buffers + (process-tests--with-processes processes + ;; Start processes until we exhaust the file descriptor set + ;; size. We assume that each process requires at least one + ;; file descriptor. + (dotimes (i 10) + (let ((buffer (generate-new-buffer (format " *%d*" i)))) + (push buffer buffers) + (let ((process + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we ignore + ;; `file-error'. + (process-tests--ignore-EMFILE + (make-pipe-process :name (format "test %d" i) + :buffer buffer + :coding 'no-conversion + :noquery t)))) + (when process (push process processes))))) + ;; We should have managed to start at least one process. + (should processes)))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-network-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (skip-unless (featurep 'make-network-process '(:server t))) + (skip-unless (featurep 'make-network-process '(:family local))) + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--with-temp-directory directory + (process-tests--with-processes processes + (let* ((num-clients 10) + (socket-name (expand-file-name "socket" directory)) + ;; Run a UNIX server to connect to. + (server (make-network-process :name "server" + :server num-clients + :buffer nil + :service socket-name + :family 'local + :coding 'no-conversion + :noquery t))) + (push server processes) + (process-tests--fd-setsize-test + ;; Start processes until we exhaust the file descriptor + ;; set size. We assume that each process requires at + ;; least one file descriptor. + (dotimes (i num-clients) + (let ((client + ;; Failure to allocate more file descriptors + ;; should signal `file-error', but not crash. + ;; Since we don't know the exact limit, we ignore + ;; `file-error'. + (process-tests--ignore-EMFILE + (make-network-process + :name (format "client %d" i) + :service socket-name + :family 'local + :coding 'no-conversion + :noquery t)))) + (when client (push client processes)))) + ;; We should have managed to start at least one process. + (should processes))))))) + +(ert-deftest process-tests/fd-setsize-no-crash/make-serial-process () + "Check that Emacs doesn't crash when trying to use more than +FD_SETSIZE file descriptors (Bug#24325)." + (with-timeout (60 (ert-fail "Test timed out")) + (skip-unless (file-executable-p shell-file-name)) + (skip-unless (executable-find "tty")) + (skip-unless (executable-find "sleep")) + ;; `process-tests--new-pty' probably only works with GNU Bash. + (skip-unless (string-equal + (file-name-nondirectory shell-file-name) "bash")) + (process-tests--with-processes processes + ;; In order to use `make-serial-process', we need to create some + ;; pseudoterminals. The easiest way to do that is to start a + ;; normal process using the `pty' connection type. We need to + ;; ensure that the terminal stays around while we connect to it. + ;; Create the host processes before the dummy pipes so we have a + ;; high chance of succeeding here. + (let ((tty-names ())) + (dotimes (_ 10) + (cl-destructuring-bind + (host tty-name) (process-tests--new-pty) + (should (processp host)) + (push host processes) + (should tty-name) + (should (file-exists-p tty-name)) + (push tty-name tty-names))) + (process-tests--fd-setsize-test + (process-tests--with-processes processes + (process-tests--with-buffers buffers + (dolist (tty-name tty-names) + (let ((buffer (generate-new-buffer + (format " *%s*" tty-name)))) + (push buffer buffers) + ;; Failure to allocate more file descriptors should + ;; signal `file-error', but not crash. Since we + ;; don't know the exact limit, we ignore + ;; `file-error'. + (let ((process (process-tests--ignore-EMFILE + (make-serial-process + :name (format "test %s" tty-name) + :port tty-name + :speed 9600 + :buffer buffer + :coding 'no-conversion + :noquery t)))) + (when process (push process processes)))))) + ;; We should have managed to start at least one process. + (should processes))))))) + +(defvar process-tests--EMFILE-message :unknown + "Cached result of the function `process-tests--EMFILE-message'.") + +(defun process-tests--EMFILE-message () + "Return the error message for the EMFILE POSIX error. +Return nil if that can't be determined." + (when (eq process-tests--EMFILE-message :unknown) + (setq process-tests--EMFILE-message + (with-temp-buffer + (when (eql (ignore-error 'file-error + (call-process "errno" nil t nil "EMFILE")) + 0) + (goto-char (point-min)) + (when (looking-at (rx "EMFILE" (+ blank) (+ digit) + (+ blank) (group (+ nonl)))) + (match-string-no-properties 1)))))) + process-tests--EMFILE-message) + +(defun process-tests--new-pty () + "Allocate a new pseudoterminal. +Return a list (PROCESS TTY-NAME)." + ;; The command below will typically only work with GNU Bash. + (should (string-equal (file-name-nondirectory shell-file-name) + "bash")) + (process-tests--with-temp-file temp-file + (should-not (file-remote-p temp-file)) + (let* ((command (list shell-file-name shell-command-switch + (format "tty > %s && sleep 60" + (shell-quote-argument + (file-name-unquote temp-file))))) + (process (make-process :name "tty host" + :command command + :buffer nil + :coding 'utf-8-unix + :connection-type 'pty + :noquery t)) + (tty-name nil) + (coding-system-for-read 'utf-8-unix) + (coding-system-for-write 'utf-8-unix)) + ;; Wait until TTY name has arrived. + (with-timeout (2 (message "Timed out waiting for TTY name")) + (while (and (process-live-p process) (not tty-name)) + (sleep-for 0.1) + (when-let ((attributes (file-attributes temp-file))) + (when (cl-plusp (file-attribute-size attributes)) + (with-temp-buffer + (insert-file-contents temp-file) + (goto-char (point-max)) + ;; `tty' has printed a trailing newline. + (skip-chars-backward "\n") + (unless (bobp) + (setq tty-name (buffer-substring-no-properties + (point-min) (point))))))))) + (list process tty-name)))) (provide 'process-tests) -;; process-tests.el ends here. +;;; process-tests.el ends here |