diff options
Diffstat (limited to 'test/src/process-tests.el')
| -rw-r--r-- | test/src/process-tests.el | 991 |
1 files changed, 924 insertions, 67 deletions
diff --git a/test/src/process-tests.el b/test/src/process-tests.el index b26f9391909..7d3d9eb72b8 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -1,19 +1,21 @@ -;;; process-tests.el --- Testing the process facilities +;;; process-tests.el --- Testing the process facilities -*- lexical-binding: t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -21,61 +23,74 @@ ;;; Code: +(require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory +(require 'puny) +(require 'subr-x) +(require 'dns) +(require 'url-http) + +(declare-function thread-last-error "thread.c") +(declare-function thread-join "thread.c") +(declare-function make-thread "thread.c") ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) -;; Start a process that exits immediately. Call WAIT-FUNCTION, -;; possibly multiple times, to wait for the process to complete. -(defun process-test-sentinel-wait-function-working-p (wait-function) - (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) +(defun process-test-wait-for-sentinel (proc exit-status &optional wait-function) + "Set a sentinel on PROC and wait for it to be called with EXIT-STATUS. +Call WAIT-FUNCTION, possibly multiple times, to wait for the +process to complete." + (let ((wait-function (or wait-function #'accept-process-output)) (sentinel-called nil) (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) process-test-sentinel-wait-timeout))) (funcall wait-function)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) - sentinel-called)) + (should sentinel-called) + (should (eq (process-status proc) 'exit)) + (should (= (process-exit-status proc) exit-status)))) (ert-deftest process-test-sentinel-accept-process-output () (skip-unless (executable-find "bash")) - (should (process-test-sentinel-wait-function-working-p - #'accept-process-output))) + (with-timeout (60 (ert-fail "Test timed out")) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))) + (should (process-test-wait-for-sentinel proc 20))))) (ert-deftest process-test-sentinel-sit-for () (skip-unless (executable-find "bash")) - (should - (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t))))) + (with-timeout (60 (ert-fail "Test timed out")) + (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))) + (should (process-test-wait-for-sentinel + proc 20 (lambda () (sit-for 0.01 t))))))) (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () "Check that Emacs hides CreateProcess deficiency (bug#18745)." - (let (batfile) - (unwind-protect - (progn - ;; CreateProcess will fail when both the bat file and 1st - ;; argument are quoted, so include spaces in both of those - ;; to force quoting. - (setq batfile (make-temp-file "echo args" nil ".bat")) - (with-temp-file batfile - (insert "@echo arg1=%1, arg2=%2\n")) - (with-temp-buffer - (call-process batfile nil '(t t) t "x &y") - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) - (with-temp-buffer - (call-process-shell-command - (mapconcat #'shell-quote-argument (list batfile "x &y") " ") - nil '(t t) t) - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) - (when batfile (delete-file batfile)))))) + (ert-with-temp-file batfile + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + :prefix "echo args" + :suffix ".bat" + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))))) (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" @@ -84,28 +99,19 @@ "echo hello stderr! >&2; " "exit 20")) :buffer stdout-buffer - :stderr stderr-buffer)) - (sentinel-called nil) - (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) - (setq sentinel-called t))) - (while (not (or sentinel-called - (> (- (float-time) start-time) - process-test-sentinel-wait-timeout))) - (accept-process-output)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) + :stderr stderr-buffer))) + (process-test-wait-for-sentinel proc 20) (should (with-current-buffer stdout-buffer (goto-char (point-min)) (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")) - (let* ((sentinel-called nil) - (stderr-sentinel-called nil) + (with-timeout (60 (ert-fail "Test timed out")) + (let* ((stderr-sentinel-called nil) (stdout-output nil) (stderr-output nil) (stdout-buffer (generate-new-buffer "*stdout*")) @@ -117,36 +123,62 @@ (concat "echo hello stdout!; " "echo hello stderr! >&2; " "exit 20")) - :stderr stderr-proc)) - (start-time (float-time))) - (set-process-filter proc (lambda (proc input) + :stderr stderr-proc))) + (set-process-filter proc (lambda (_proc input) (push input stdout-output))) - (set-process-sentinel proc (lambda (proc msg) - (setq sentinel-called t))) - (set-process-filter stderr-proc (lambda (proc input) + (set-process-filter stderr-proc (lambda (_proc input) (push input stderr-output))) - (set-process-sentinel stderr-proc (lambda (proc input) + (set-process-sentinel stderr-proc (lambda (_proc _input) (setq stderr-sentinel-called t))) - (while (not (or sentinel-called - (> (- (float-time) start-time) - process-test-sentinel-wait-timeout))) - (accept-process-output)) - (cl-assert (eq (process-status proc) 'exit)) - (cl-assert (= (process-exit-status proc) 20)) - (should sentinel-called) + (process-test-wait-for-sentinel proc 20) (should (equal 1 (with-current-buffer stdout-buffer (point-max)))) (should (equal "hello stdout!\n" - (mapconcat #'identity (nreverse stdout-output) ""))) + (mapconcat #'identity (nreverse stdout-output)))) (should stderr-sentinel-called) (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) + (proc (start-process + "test proc" (current-buffer) + (concat invocation-directory invocation-name) + "-Q" "--batch" "--eval" + (prin1-to-string + '(let ((s nil) (count 0)) + (while (setq s (read-from-minibuffer + (format "%d> " count))) + (princ s) + (princ "\n") + (setq count (1+ count)))))))) + (set-process-query-on-exit-flag proc nil) + (send-string proc "one\n") + (while (not (equal (buffer-substring (pos-bol) (point-max)) + "1> ")) + (accept-process-output proc)) ; Read "one". + (should (equal (buffer-string) "0> one\n1> ")) + (set-process-filter proc t) ; Stop reading from proc. + (send-string proc "two\n") + (should-not + (accept-process-output proc 1)) ; Can't read "two" yet. + (should (equal (buffer-string) "0> one\n1> ")) + (set-process-filter proc nil) ; Resume reading from proc. + (while (not (equal (buffer-substring (pos-bol) (point-max)) + "2> ")) + (accept-process-output proc)) ; Read "Two". + (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. @@ -160,7 +192,832 @@ (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" + :command '("sleep" "1h") + :noquery t + :connection-type 'pipe + :stderr (current-buffer)))) + (unwind-protect + (let ((new-processes (cl-set-difference (process-list) + previous-processes + :test #'eq))) + (should new-processes) + (dolist (process new-processes) + (should-not (process-query-on-exit-flag process)))) + (kill-process process)))))) + +;; Return t if OUTPUT could have been generated by merging the INPUTS somehow. +(defun process-tests--mixable (output &rest inputs) + (while (and output (let ((ins inputs)) + (while (and ins (not (eq (car (car ins)) (car output)))) + (setq ins (cdr ins))) + (if ins + (setcar ins (cdr (car ins)))) + ins)) + (setq output (cdr output))) + (not (apply #'append output inputs))) + +(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"))) + (with-temp-buffer + (let ((process (make-process + :name "mix-stderr" + :command (list "bash" "-c" + "echo stdout && echo stderr >&2") + :buffer (current-buffer) + :sentinel #'ignore + :noquery t + :connection-type 'pipe))) + (while (or (accept-process-output process) + (process-live-p process))) + (should (eq (process-status process) 'exit)) + (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"))))))) + +(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 _) + (setq have-called-debugger t) + ;; Allow entering the debugger later in the same + ;; test run, before going back to the command + ;; loop. + (setq internal-when-entered-debugger -1)))) + (should (eq :got-error ;; NOTE: `should-error' would inhibit debugger. + (condition-case-unless-debug () + ;; Emacs doesn't search for absolute filenames, so + ;; the error will be hit in the w32 process spawn + ;; code. + (make-process :name "test" :command '("c:/No-Such-Command")) + (error :got-error)))) + (should have-called-debugger)))) + +(defun make-process/test-connection-type (ttys &rest args) + "Make a process and check whether its standard streams match TTYS. +This calls `make-process', passing ARGS to adjust how the process +is created. TTYS should be a list of 3 boolean values, +indicating whether the subprocess's stdin, stdout, and stderr +should be a TTY, respectively." + (declare (indent 1)) + (let* (;; MS-Windows doesn't support communicating via pty. + (ttys (if (eq system-type 'windows-nt) '(nil nil nil) ttys)) + (expected-output (concat (and (nth 0 ttys) "stdin\n") + (and (nth 1 ttys) "stdout\n") + (and (nth 2 ttys) "stderr\n"))) + (stdout-buffer (generate-new-buffer "*stdout*")) + (proc (apply + #'make-process + :name "test" + :command (list "sh" "-c" + (concat "if [ -t 0 ]; then echo stdin; fi; " + "if [ -t 1 ]; then echo stdout; fi; " + "if [ -t 2 ]; then echo stderr; fi")) + :buffer stdout-buffer + args))) + (should (eq (and (process-tty-name proc 'stdin) t) (nth 0 ttys))) + (should (eq (and (process-tty-name proc 'stdout) t) (nth 1 ttys))) + (should (eq (and (process-tty-name proc 'stderr) t) (nth 2 ttys))) + (process-test-wait-for-sentinel proc 0) + (should (equal (with-current-buffer stdout-buffer (buffer-string)) + expected-output)))) + +(ert-deftest make-process/connection-type/pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t t t) + :connection-type 'pty)) + +(ert-deftest make-process/connection-type/pty-2 () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t t t) + :connection-type '(pty . pty))) + +(ert-deftest make-process/connection-type/pipe () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil nil nil) + :connection-type 'pipe)) + +(ert-deftest make-process/connection-type/pipe-2 () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil nil nil) + :connection-type '(pipe . pipe))) + +(ert-deftest make-process/connection-type/in-pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(t nil nil) + :connection-type '(pty . pipe))) + +(ert-deftest make-process/connection-type/out-pty () + (skip-unless (executable-find "sh")) + (make-process/test-connection-type '(nil t t) + :connection-type '(pipe . pty))) + +(ert-deftest make-process/connection-type/pty-with-stderr-buffer () + (skip-unless (executable-find "sh")) + (let ((stderr-buffer (generate-new-buffer "*stderr*"))) + (make-process/test-connection-type '(t t nil) + :connection-type 'pty :stderr stderr-buffer))) + +(ert-deftest make-process/connection-type/out-pty-with-stderr-buffer () + (skip-unless (executable-find "sh")) + (let ((stderr-buffer (generate-new-buffer "*stderr*"))) + (make-process/test-connection-type '(nil t nil) + :connection-type '(pipe . pty) :stderr stderr-buffer))) + +(ert-deftest make-process/file-handler/found () + "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) + (should (equal default-directory "test-handler:/dir/")) + (should (equal args '(make-process :name "name" + :command ("/some/binary") + :file-handler t))) + (cl-incf file-handler-calls) + 'fake-process)) + (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") + #'file-handler))) + (default-directory "test-handler:/dir/")) + (should (eq (make-process :name "name" + :command '("/some/binary") + :file-handler t) + 'fake-process)) + (should (= file-handler-calls 1))))))) + +(ert-deftest make-process/file-handler/not-found () + "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)))))) + +(ert-deftest make-process/file-handler/disable () + "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"))))))) + +(defun process-tests--file-handler (operation &rest _args) + (cl-ecase operation + (unhandled-file-name-directory "/") + (make-process (ert-fail "file name handler called unexpectedly")))) + +(put #'process-tests--file-handler 'operations + '(unhandled-file-name-directory make-process)) + +(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)))) + +;; The following tests require working DNS + +;; This will need updating when IANA assign more IPv6 global ranges. +(defun ipv6-is-available () + (and (featurep 'make-network-process '(:family ipv6)) + (cl-rassoc-if + (lambda (elt) + (and (eq 9 (length elt)) + (= (logand (aref elt 0) #xe000) #x2000))) + (network-interface-list)))) + +;; Check if the Internet seems to be working. Mainly to pacify +;; Debian's CI system. +(defvar internet-is-working + (progn + (require 'dns) + (dns-query "google.com"))) + +(ert-deftest lookup-family-specification () + "`network-lookup-address-info' should only accept valid family symbols." + (skip-unless internet-is-working) + (with-timeout (60 (ert-fail "Test timed out")) + (should-error (network-lookup-address-info "localhost" 'both)) + (should (network-lookup-address-info "localhost" 'ipv4)) + (when (ipv6-is-available) + (should (network-lookup-address-info "localhost" 'ipv6))))) + +(ert-deftest lookup-hints-specification () + "`network-lookup-address-info' should only accept valid hints arg." + (should-error (network-lookup-address-info "1.1.1.1" nil t)) + (should-error (network-lookup-address-info "1.1.1.1" 'ipv4 t)) + (should (network-lookup-address-info "1.1.1.1" nil 'numeric)) + (should (network-lookup-address-info "1.1.1.1" 'ipv4 'numeric)) + (when (ipv6-is-available) + (should-error (network-lookup-address-info "::1" nil t)) + (should-error (network-lookup-address-info "::1" 'ipv6 't)) + (should (network-lookup-address-info "::1" nil 'numeric)) + (should (network-lookup-address-info "::1" 'ipv6 'numeric)))) + +(ert-deftest lookup-hints-values () + "`network-lookup-address-info' should succeed/fail in looking up various numeric IP addresses." + (let ((ipv4-invalid-addrs + '("localhost" "343.1.2.3" "1.2.3.4.5")) + ;; These are valid for IPv4 but invalid for IPv6 + (ipv4-addrs + '("127.0.0.1" "127.0.1" "127.1" "127" "1" "0" + "0xe3010203" "0xe3.1.2.3" "227.0x1.2.3" + "034300201003" "0343.1.2.3" "227.001.2.3")) + (ipv6-only-invalid-addrs + '("fe80:1" "e301:203:1" "e301::203::1" + "1:2:3:4:5:6:7:8:9" "0xe301:203::1" + "343:10001:2::3" + ;; "00343:1:2::3" is invalid on GNU/Linux and FreeBSD, but + ;; valid on macOS. macOS is wrong here, but such is life. + )) + ;; These are valid for IPv6 but invalid for IPv4 + (ipv6-addrs + '("fe80::1" "e301::203:1" "e301:203::1" + "e301:0203::1" "::1" "::0" + "0343:1:2::3" "343:001:2::3"))) + (dolist (a ipv4-invalid-addrs) + (should-not (network-lookup-address-info a nil 'numeric)) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv6-addrs) + (should-not (network-lookup-address-info a 'ipv4 'numeric))) + (dolist (a ipv4-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv4 'numeric))) + (when (ipv6-is-available) + (dolist (a ipv4-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-only-invalid-addrs) + (should-not (network-lookup-address-info a 'ipv6 'numeric))) + (dolist (a ipv6-addrs) + (should (network-lookup-address-info a nil 'numeric)) + (should (network-lookup-address-info a 'ipv6 'numeric)) + (should (network-lookup-address-info (upcase a) nil 'numeric)) + (should (network-lookup-address-info (upcase a) 'ipv6 'numeric)))))) + +(ert-deftest lookup-unicode-domains () + "Unicode domains should fail." + (skip-unless internet-is-working) + (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"))))) + +(ert-deftest unibyte-domain-name () + "Unibyte domain names should work." + (skip-unless internet-is-working) + (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." + (skip-unless internet-is-working) + (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 (and (ipv6-is-available) + (dns-query "google.com" 'AAAA)) + (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 internet-is-working) + (with-timeout (60 (ert-fail "Test timed out")) + (should (eq nil (network-lookup-address-info "emacs.invalid"))))) + +;; End of tests requiring DNS + +(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))))) + +;; 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 ((cat (executable-find "cat"))) + (skip-unless cat) + (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 cat) + :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) + ;; The process now should either be running, or have + ;; already failed before `exec'. + (should (memq (process-status process) '(run exit))) + (when (process-live-p process) + (process-send-eof process)) + (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))) + ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). + (skip-unless (not (eq system-type 'cygwin))) + (with-timeout (60 (ert-fail "Test timed out")) + (ert-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)." + ;; This test cannot be run if PTYs aren't supported. + (skip-unless (not (eq system-type 'windows-nt))) + (with-timeout (60 (ert-fail "Test timed out")) + (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 ((sleep (executable-find "sleep")) + (tty-names ())) + (skip-unless sleep) + (dotimes (i 10) + (let* ((host (make-process :name (format "tty host %d" i) + :command (list sleep "60") + :buffer nil + :coding 'utf-8-unix + :connection-type 'pty + :noquery t)) + (tty-name (process-tty-name host))) + (should (processp host)) + (push host processes) + ;; FIXME: The assumption below that using :connection 'pty + ;; in make-process necessarily produces a process with PTY + ;; connection is unreliable and non-portable. + ;; make-process can legitimately and silently fall back on + ;; pipes if allocating a PTY fails (and on MS-Windows it + ;; always fails). The following code also assumes that + ;; process-tty-name produces a file name that can be + ;; passed to 'stat' and to make-serial-process, which is + ;; also non-portable. + (should tty-name) + (should (file-exists-p tty-name)) + (should-not (member tty-name tty-names)) + (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) + +(ert-deftest process-tests/sentinel-called () + "Check that sentinels are called after processes finish." + (let ((command (process-tests--emacs-command))) + (skip-unless command) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (process-tests--eval + command '(print "first")) + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + +(ert-deftest process-tests/sentinel-with-multiple-processes () + "Check that sentinels are called in time even when other processes +have written output." + (let ((command (process-tests--emacs-command))) + (skip-unless command) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (process-tests--eval + command '(print "first")) + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (push (make-process + :name "bash" + :command (process-tests--eval + command + '(progn (sleep-for 10) (print "second"))) + :noquery t + :connection-type conn-type) + processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + +(ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (fboundp 'make-thread)) + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--with-processes processes + (let ((threads ()) + (cat (executable-find "cat"))) + (skip-unless cat) + (dotimes (i 10) + (let* ((name (format "test %d" i)) + (process (make-process :name name + :command (list cat) + :coding 'no-conversion + :noquery t + :connection-type 'pipe))) + (push process processes) + (set-process-thread process nil) + (push (make-thread + (lambda () + (while (accept-process-output process))) + name) + threads))) + (mapc #'process-send-eof processes) + (cl-loop for process in processes + and thread in threads + do + (should-not (thread-join thread)) + (should-not (thread-last-error)) + (should (eq (process-status process) 'exit)) + (should (eql (process-exit-status process) 0))))))) + +(defun process-tests--eval (command form) + "Return a command that evaluates FORM in an Emacs subprocess. +COMMAND must be a list returned by +`process-tests--emacs-command'." + (let ((print-gensym t) + (print-circle t) + (print-length nil) + (print-level nil) + (print-escape-control-characters t) + (print-escape-newlines t) + (print-escape-multibyte t) + (print-escape-nonascii t)) + `(,@command "--quick" "--batch" ,(format "--eval=%S" form)))) + +(defun process-tests--emacs-command () + "Return a command to reinvoke the current Emacs instance. +Return nil if that doesn't appear to be possible." + (when-let ((binary (process-tests--emacs-binary)) + (dump (process-tests--dump-file))) + (cons binary + (unless (eq dump :not-needed) + (list (concat "--dump-file=" + (file-name-unquote dump))))))) + +(defun process-tests--emacs-binary () + "Return the filename of the currently running Emacs binary. +Return nil if that can't be determined." + (and (stringp invocation-name) + (not (file-remote-p invocation-name)) + (not (file-name-absolute-p invocation-name)) + (stringp invocation-directory) + (not (file-remote-p invocation-directory)) + (file-name-absolute-p invocation-directory) + (when-let ((file (process-tests--usable-file-for-reinvoke + (expand-file-name invocation-name + invocation-directory)))) + (and (file-executable-p file) file)))) + +(defun process-tests--dump-file () + "Return the filename of the dump file used to start Emacs. +Return nil if that can't be determined. Return `:not-needed' if +Emacs wasn't started with a dump file." + (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) + (when-let ((file (process-tests--usable-file-for-reinvoke + (cdr (assq 'dump-file-name stats))))) + (and (file-readable-p file) file)) + :not-needed)) + +(defun process-tests--usable-file-for-reinvoke (filename) + "Return a version of FILENAME that can be used to reinvoke Emacs. +Return nil if FILENAME doesn't exist." + (when (and (stringp filename) + (not (file-remote-p filename))) + (cl-callf file-truename filename) + (and (stringp filename) + (not (file-remote-p filename)) + (file-name-absolute-p filename) + (file-regular-p filename) + filename))) + +;; Bug#46284 +(ert-deftest process-sentinel-interrupt-event () + "Test that interrupting a process on Windows sends \"interrupt\" to sentinel." + (skip-unless (eq system-type 'windows-nt)) + (with-temp-buffer + (let* ((proc-buf (current-buffer)) + ;; Start a new emacs process to wait idly until interrupted. + (cmd "emacs -batch --eval=\"(sit-for 50000)\"") + (proc (start-file-process-shell-command + "test/process-sentinel-signal-event" proc-buf cmd)) + (events '())) + + ;; Capture any incoming events. + (set-process-sentinel proc + (lambda (_prc event) + (push event events))) + ;; Wait for the process to start. + (sleep-for 2) + (should (equal 'run (process-status proc))) + ;; Interrupt the sub-process and wait for it to die. + (interrupt-process proc) + (sleep-for 2) + ;; Should have received SIGINT... + (should (equal 'signal (process-status proc))) + (should (equal 2 (process-exit-status proc))) + ;; ...and the change description should be "interrupt". + (should (equal '("interrupt\n") events))))) + +(ert-deftest process-num-processors () + "Sanity checks for num-processors." + (should (equal (num-processors) (num-processors))) + (should (integerp (num-processors))) + (should (< 0 (num-processors)))) (provide 'process-tests) -;; process-tests.el ends here. +;;; process-tests.el ends here |