[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module
|
From: |
dick . r . chiang |
|
Subject: |
bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module |
|
Date: |
Mon, 29 Nov 2021 20:38:05 -0500 |
|
User-agent: |
Gnus/5.14 (Gnus v5.14) Commercial/28.0.50 (gnu/linux) |
>From 18e2cfa112c3393b4191bb3497bf9a0ae643c2a2 Mon Sep 17 00:00:00 2001
From: dickmao <dick.r.chiang@gmail.com>
Date: Mon, 29 Nov 2021 20:31:28 -0500
Subject: [PATCH] Don't repeat yourself (DRY)
* test/lisp/net/network-stream-tests.el
(network-test--resolve-system-name): DRY.
(network-stream-tests--resolve-system-name): DRY.
(network-stream-tests-echo-server): DRY.
(echo-server-with-dns): DRY.
(echo-server-with-localhost): DRY.
(echo-server-with-local-ipv4): DRY.
(echo-server-with-local-ipv6): DRY.
(echo-server-with-ip): DRY.
(echo-server-nowait): DRY.
(make-tls-server): DRY.
(network-stream-tests-make-network-process): DRY.
(network-stream-tests-open-stream): DRY.
(network-stream-tests-doit): DRY.
(connect-to-tls-ipv4-wait): DRY.
(connect-to-tls-ipv4-nowait): DRY.
(connect-to-tls-ipv6-nowait): DRY.
(open-network-stream-tls-wait): DRY.
(open-network-stream-tls-nowait): DRY.
(open-network-stream-tls): DRY.
(open-network-stream-tls-nocert): DRY.
(open-gnutls-stream-new-api-default): DRY.
(open-gnutls-stream-new-api-wait): DRY.
(open-gnutls-stream-old-api-wait): DRY.
(open-gnutls-stream-new-api-nowait): DRY.
(open-gnutls-stream-old-api-nowait): DRY.
(open-gnutls-stream-new-api-errors): DRY.
---
test/lisp/net/network-stream-tests.el | 730 ++++++++------------------
1 file changed, 206 insertions(+), 524 deletions(-)
diff --git a/test/lisp/net/network-stream-tests.el
b/test/lisp/net/network-stream-tests.el
index 8f5bddb71f..fbb0d4af9b 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -138,7 +138,7 @@ server-process-filter
(t
))))
-(defun network-test--resolve-system-name ()
+(defun network-stream-tests--resolve-system-name ()
(cl-loop for address in (network-lookup-address-info (system-name))
when (or (and (= (length address) 5)
;; IPv4 localhost addresses start with 127.
@@ -148,594 +148,276 @@ network-test--resolve-system-name
(equal address [0 0 0 0 0 0 0 1 0])))
return t))
+(defmacro network-stream-tests-retry (&rest body)
+ `(cl-loop with status
+ repeat 30
+ when (setq status (condition-case err
+ (progn ,@body)
+ (error (prog1 nil
+ (message "retry: %s"
+ (error-message-string
err))))))
+ return status
+ do (accept-process-output nil 0.3)))
+
+(defmacro network-stream-tests-echo-server (make-server iport &rest params)
+ `(let* ((server ,make-server)
+ (port (aref (process-contact server :local) ,iport))
+ (buffer (generate-new-buffer "*foo*"))
+ (proc (make-network-process :name "foo"
+ :buffer buffer
+ :service port
+ ,@params)))
+ (network-stream-tests-retry (not (eq (process-status proc) 'connect)))
+ (unwind-protect
+ (with-current-buffer (process-buffer proc)
+ (process-send-string proc "echo foo")
+ (network-stream-tests-retry (equal (buffer-string) "foo\n")))
+ (when (process-live-p proc) (delete-process proc))
+ (let (kill-buffer-query-functions)
+ (kill-buffer buffer))
+ (when (process-live-p server) (delete-process server)))))
+
(ert-deftest echo-server-with-dns ()
- (unless (network-test--resolve-system-name)
- (ert-skip "Can't test resolver for (system-name)"))
-
- (let* ((server (make-server (system-name)))
- (port (aref (process-contact server :local) 4))
- (proc (make-network-process :name "foo"
- :buffer (generate-new-buffer "*foo*")
- :host (system-name)
- :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)))
+ (skip-unless (network-stream-tests--resolve-system-name))
+ (network-stream-tests-echo-server
+ (make-server (system-name)) 4
+ :host (system-name)))
(ert-deftest echo-server-with-localhost ()
- (let* ((server (make-server 'local))
- (port (aref (process-contact server :local) 4))
- (proc (make-network-process :name "foo"
- :buffer (generate-new-buffer "*foo*")
- :host "localhost"
- :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)))
+ (network-stream-tests-echo-server
+ (make-server 'local) 4
+ :host "localhost"))
+
(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)))
+ (network-stream-tests-echo-server
+ (make-server 'local 'ipv4) 4
+ :host 'local
+ :family 'ipv4))
(ert-deftest echo-server-with-local-ipv6 ()
(skip-unless (featurep 'make-network-process '(:family ipv6)))
- (let ((server (ignore-errors (make-server 'local 'ipv6))))
- (skip-unless server)
- (let* ((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))))
+ (network-stream-tests-echo-server
+ (make-server 'local 'ipv6) 8
+ :host 'local
+ :family 'ipv6))
(ert-deftest echo-server-with-ip ()
- (let* ((server (make-server 'local))
- (port (aref (process-contact server :local) 4))
- (proc (make-network-process :name "foo"
- :buffer (generate-new-buffer "*foo*")
- :host "127.0.0.1"
- :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)))
+ (network-stream-tests-echo-server
+ (make-server 'local) 4
+ :host "127.0.0.1"))
(ert-deftest echo-server-nowait ()
- (let* ((server (make-server 'local))
- (port (aref (process-contact server :local) 4))
- (proc (make-network-process :name "foo"
- :buffer (generate-new-buffer "*foo*")
- :host "localhost"
- :nowait t
- :family 'ipv4
- :service port))
- (times 0))
- (should (eq (process-status proc) 'connect))
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect)))
- (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)))
-
-(defun make-tls-server (port)
- (start-process "gnutls" (generate-new-buffer "*tls*")
- "gnutls-serv" "--http"
- "--x509keyfile"
- (ert-resource-file "key.pem")
- "--x509certfile"
- (ert-resource-file "cert.pem")
- "--port" (format "%s" port)))
+ (network-stream-tests-echo-server
+ (make-server 'local) 4
+ :host "localhost"
+ :nowait t
+ :family 'ipv4))
+
+(defun make-tls-server ()
+ (let ((free-port (with-temp-buffer
+ (let ((proc (make-network-process
+ :name "free-port"
+ :noquery t
+ :host "127.0.0.1"
+ :buffer (current-buffer)
+ :server t
+ :stop t
+ :service t)))
+ (prog1 (process-contact proc :service)
+ (delete-process proc))))))
+ (cons free-port
+ (start-process "gnutls" (generate-new-buffer "*tls*")
+ "gnutls-serv" "--http"
+ "--x509keyfile"
+ (ert-resource-file "key.pem")
+ "--x509certfile"
+ (ert-resource-file "cert.pem")
+ "--port" (format "%s" free-port)))))
+
+(defmacro network-stream-tests-make-network-process (negotiate &rest params)
+ `(pcase-let ((`(,port . ,server) (make-tls-server))
+ (buffer (generate-new-buffer "*foo*")))
+ (unwind-protect
+ (network-stream-tests-doit
+ port server
+ (make-network-process
+ :name "bar"
+ :buffer buffer
+ :service port
+ ,@params)
+ ,negotiate)
+ (let (kill-buffer-query-functions)
+ (kill-buffer buffer))
+ (when (process-live-p server) (delete-process server)))))
+
+(defmacro network-stream-tests-open-stream (func &rest params)
+ `(pcase-let ((`(,port . ,server) (make-tls-server))
+ (buffer (generate-new-buffer "*foo*")))
+ (unwind-protect
+ (network-stream-tests-doit
+ port server
+ (,func
+ "bar"
+ buffer
+ "localhost"
+ port
+ ,@params))
+ (let (kill-buffer-query-functions)
+ (kill-buffer buffer))
+ (when (process-live-p server) (delete-process server)))))
+
+(cl-defmacro network-stream-tests-doit (port server form &optional negotiate)
+ `(let ((network-security-level 'low)
+ proc status)
+ (unwind-protect
+ (progn
+ (with-current-buffer (process-buffer ,server)
+ (message "gnutls-serv on %s: %s" ,port (buffer-string)))
+ (should (setq proc (network-stream-tests-retry ,form)))
+ (,(if negotiate 'funcall 'ignore)
+ #'gnutls-negotiate :process proc
+ :type 'gnutls-x509pki
+ :hostname "localhost")
+ (network-stream-tests-retry (not (eq (process-status proc)
'connect)))
+ (should (consp (setq status (network-stream-tests-retry
+ (gnutls-peer-status proc)))))
+ (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
+ (should (stringp issuer))
+ (setq issuer (split-string issuer ","))
+ (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))
+ (when (process-live-p proc) (delete-process proc)))))
(ert-deftest connect-to-tls-ipv4-wait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44332))
- (times 0)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (make-network-process
- :name "bar"
- :buffer (generate-new-buffer "*foo*")
- :host "localhost"
- :service 44332))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (gnutls-negotiate :process proc
- :type 'gnutls-x509pki
- :hostname "localhost"))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-make-network-process
+ t
+ :host "localhost"))
(ert-deftest connect-to-tls-ipv4-nowait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44331))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (make-network-process
- :name "bar"
- :buffer (generate-new-buffer "*foo*")
- :nowait t
- :family 'ipv4
- :tls-parameters
- (cons 'gnutls-x509pki
- (gnutls-boot-parameters
- :hostname "localhost"))
- :host "localhost"
- :service 44331))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (setq times 0)
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-make-network-process
+ nil
+ :nowait t
+ :family 'ipv4
+ :tls-parameters
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :hostname "localhost"))
+ :host "localhost"))
(ert-deftest connect-to-tls-ipv6-nowait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
(skip-unless (not (eq system-type 'windows-nt)))
(skip-unless (featurep 'make-network-process '(:family ipv6)))
- (let ((server (make-tls-server 44333))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (make-network-process
- :name "bar"
- :buffer (generate-new-buffer "*foo*")
- :family 'ipv6
- :nowait t
- :tls-parameters
- (cons 'gnutls-x509pki
- (gnutls-boot-parameters
- :hostname "localhost"))
- :host "::1"
- :service 44333))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (setq times 0)
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-make-network-process
+ nil
+ :family 'ipv6
+ :nowait t
+ :tls-parameters
+ (cons 'gnutls-x509pki
+ (gnutls-boot-parameters
+ :hostname "localhost"))
+ :host "::1"))
(ert-deftest open-network-stream-tls-wait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44334))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-network-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44334
- :type 'tls
- :nowait nil))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-network-stream
+ :type 'tls
+ :nowait nil))
(ert-deftest open-network-stream-tls-nowait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44335))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-network-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44335
- :type 'tls
- :nowait t))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (setq times 0)
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-network-stream
+ :type 'tls
+ :nowait t))
(ert-deftest open-network-stream-tls ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44336))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-network-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44336
- :type 'tls))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-network-stream
+ :type 'tls))
(ert-deftest open-network-stream-tls-nocert ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44337))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-network-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44337
- :type 'tls
- :client-certificate nil))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-network-stream
+ :type 'tls
+ :client-certificate nil))
(ert-deftest open-gnutls-stream-new-api-default ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44665))
- (times 0)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44665))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+ (network-stream-tests-open-stream
+ open-gnutls-stream))
(ert-deftest open-gnutls-stream-new-api-wait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44666))
- (times 0)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44666
- (list :nowait nil)))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+ (network-stream-tests-open-stream
+ open-gnutls-stream
+ (list :nowait nil)))
(ert-deftest open-gnutls-stream-old-api-wait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44667))
- (times 0)
- (nowait nil) ; Workaround Bug#47080
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44667
- nowait))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- ;; This sleep-for is needed for the native MS-Windows build. If
- ;; it is removed, the next test mysteriously fails because the
- ;; initial part of the echo is not received.
- (sleep-for 0.1)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))))
+ (network-stream-tests-open-stream
+ open-gnutls-stream
+ nil))
(ert-deftest open-gnutls-stream-new-api-nowait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44668))
- (times 0)
- (network-security-level 'low)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44668
- (list :nowait t)))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (setq times 0)
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-gnutls-stream
+ (list :nowait t)))
(ert-deftest open-gnutls-stream-old-api-nowait ()
+ :expected-result (if (getenv "CI") t :passed)
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (let ((server (make-tls-server 44669))
- (times 0)
- (network-security-level 'low)
- (nowait t)
- proc status)
- (unwind-protect
- (progn
- (sleep-for 1)
- (with-current-buffer (process-buffer server)
- (message "gnutls-serv: %s" (buffer-string)))
-
- ;; It takes a while for gnutls-serv to start.
- (while (and (null (ignore-errors
- (setq proc (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44669
- nowait))))
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (should proc)
- (setq times 0)
- (while (and (eq (process-status proc) 'connect)
- (< (setq times (1+ times)) 10))
- (sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
- (if (process-live-p server) (delete-process server)))
- (setq status (gnutls-peer-status proc))
- (should (consp status))
- (delete-process proc)
- (let ((issuer (plist-get (plist-get status :certificate) :issuer)))
- (should (stringp issuer))
- (setq issuer (split-string issuer ","))
- (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
+ (network-stream-tests-open-stream
+ open-gnutls-stream
+ t))
(ert-deftest open-gnutls-stream-new-api-errors ()
(skip-unless (gnutls-available-p))
- (should-error
- (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44777
- (list t)))
- (should-error
- (open-gnutls-stream
- "bar"
- (generate-new-buffer "*foo*")
- "localhost"
- 44777
- (vector :nowait t))))
+ (pcase-let ((`(,port . ,server) (make-tls-server)))
+ (kill-process server)
+ (should-error
+ (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ port
+ (list t)))
+ (should-error
+ (open-gnutls-stream
+ "bar"
+ (generate-new-buffer "*foo*")
+ "localhost"
+ port
+ (vector :nowait t)))))
(ert-deftest check-network-process-coding-system-bind ()
"Check that binding coding-system-for-{read,write} works."
--
2.26.2
In Commercial Emacs 28.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version
3.22.30, cairo version 1.15.10)
of 2021-11-28 built on dick
Repository revision: ba36150bd9afe7125ca15d0031ef76e534e26fae
Repository branch: longlines
Windowing system distributor 'The X.Org Foundation', version 11.0.11906000
System Description: Ubuntu 18.04.4 LTS
Configured using:
'configure --prefix=/home/dick/.local --with-tree-sitter
--enable-dumping-overwrite --enable-profiling CC=gcc-10 'CFLAGS=-g3 -Og
-I/home/dick/.local/include/' LDFLAGS=-L/home/dick/.local/lib
PKG_CONFIG_PATH=/home/dick/.local/lib/pkgconfig CXX=gcc-10'
Configured features:
CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG JSON
TREE-SITTER LCMS2 LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG
RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM
XPM GTK3 ZLIB
Important settings:
value of $LANG: en_US.UTF-8
locale-coding-system: utf-8-unix
Major mode: Magit
Minor modes in effect:
async-bytecomp-package-mode: t
global-git-commit-mode: t
shell-dirtrack-mode: t
projectile-mode: t
flx-ido-mode: t
override-global-mode: t
global-hl-line-mode: t
winner-mode: t
tooltip-mode: t
show-paren-mode: t
mouse-wheel-mode: t
file-name-shadow-mode: t
global-font-lock-mode: t
font-lock-mode: t
blink-cursor-mode: t
auto-composition-mode: t
auto-encryption-mode: t
auto-compression-mode: t
buffer-read-only: t
column-number-mode: t
line-number-mode: t
transient-mark-mode: t
Load-path shadows:
/home/dick/gomacro-mode/gomacro-mode hides
/home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode
/home/dick/.emacs.d/elpa/hydra-20170924.2259/lv hides
/home/dick/.emacs.d/elpa/lv-20191106.1238/lv
/home/dick/.emacs.d/elpa/magit-3.3.0/magit-section-pkg hides
/home/dick/.emacs.d/elpa/magit-section-3.3.0/magit-section-pkg
/home/dick/org-gcal.el/org-gcal hides
/home/dick/.emacs.d/elpa/org-gcal-0.3/org-gcal
/home/dick/.emacs.d/elpa/tree-sitter-0.15.2/tree-sitter hides
/home/dick/.local/share/emacs/28.0.50/lisp/tree-sitter
/home/dick/.emacs.d/lisp/json hides
/home/dick/.local/share/emacs/28.0.50/lisp/json
/home/dick/.emacs.d/elpa/transient-0.3.6/transient hides
/home/dick/.local/share/emacs/28.0.50/lisp/transient
/home/dick/.emacs.d/elpa/hierarchy-20171221.1151/hierarchy hides
/home/dick/.local/share/emacs/28.0.50/lisp/emacs-lisp/hierarchy
Features:
(shadow emacsbug git-rebase supercite regi bbdb-message sendmail
footnote cus-start cl-print debug backtrace rect eieio-opt speedbar
ezimage dframe shortdoc jka-compr goto-addr help-fns radix-tree
find-func mule-util magit-extras face-remap magit-patch-changelog
magit-patch magit-submodule magit-obsolete magit-popup async-bytecomp
async magit-blame magit-stash magit-reflog magit-bisect magit-push
magit-pull magit-fetch magit-clone magit-remote magit-commit
magit-sequence magit-notes magit-worktree magit-tag magit-merge
magit-branch magit-reset magit-files magit-refs magit-status magit
magit-repos magit-apply magit-wip magit-log which-func imenu magit-diff
smerge-mode diff git-commit log-edit pcvs-util add-log magit-core
magit-margin magit-transient magit-process with-editor server magit-mode
transient url-queue shr-color pulse ivy delsel colir ivy-overlay ffap
dumb-jump f cl flow-fill qp sort smiley gnus-async gnus-ml gravatar dns
mail-extr gnus-notifications gnus-fun notifications gnus-kill gnus-dup
disp-table utf-7 mm-archive url-cache nnrss nnfolder nndiscourse
benchmark rbenv nnhackernews nntwitter nntwitter-api bbdb-gnus
gnus-demon nntp nnmairix nnml nnreddit gnus-topic url-http url-auth
url-gw network-stream gnutls nsm request virtualenvwrapper gud json-rpc
python tramp-sh gnus-score score-mode gnus-bcklg gnus-srvr gnus-cite
anaphora bbdb-mua bbdb-com bbdb bbdb-site timezone gnus-delay gnus-draft
gnus-cache gnus-agent gnus-msg gnus-art mm-uu mml2015 mm-view mml-smime
smime dig gnus-sum shr kinsoku svg dom nndraft nnmh gnus-group mm-url
gnus-undo use-package use-package-delight use-package-diminish
gnus-start gnus-dbus gnus-cloud nnimap nnmail mail-source utf7 netrc
nnoo gnus-spec gnus-int gnus-range message yank-media rmc puny rfc822
mml mml-sec epa epg rfc6068 epg-config mm-decode mm-bodies mm-encode
mailabbrev gmm-utils mailheader gnus-win ag vc-svn find-dired s dired-x
dired dired-loaddefs misearch multi-isearch vc-git diff-mode vc
vc-dispatcher bug-reference cc-mode cc-fonts cc-guess cc-menus cc-cmds
cc-styles cc-align cc-engine cc-vars cc-defs tramp-archive tramp-gvfs
tramp-cache zeroconf dbus xml tramp tramp-loaddefs trampver
tramp-integration files-x tramp-compat shell pcomplete parse-time
iso8601 ls-lisp format-spec paredit-ext paredit subed subed-vtt
subed-srt subed-common subed-mpv subed-debug subed-config inf-ruby
ruby-mode smie company pcase haskell-interactive-mode
haskell-presentation-mode haskell-process haskell-session
haskell-compile haskell-mode haskell-cabal haskell-utils
haskell-font-lock haskell-indentation haskell-string
haskell-sort-imports haskell-lexeme haskell-align-imports
haskell-complete-module haskell-ghc-support noutline outline
flymake-proc flymake warnings etags fileloop generator xref project
dabbrev haskell-customize hydra lv use-package-ensure solarized-theme
solarized-definitions projectile lisp-mnt mail-parse rfc2231 ibuf-ext
ibuffer ibuffer-loaddefs thingatpt magit-autorevert autorevert
filenotify magit-git magit-section magit-utils crm dash rx grep compile
comint ansi-color gnus nnheader gnus-util rmail rmail-loaddefs rfc2047
rfc2045 ietf-drums mm-util mail-prsvr mail-utils text-property-search
time-date flx-ido flx google-translate-default-ui
google-translate-core-ui facemenu color ido google-translate-core
google-translate-tk google-translate-backend use-package-bind-key
bind-key auto-complete easy-mmode advice edmacro kmacro popup cus-edit
pp cus-load wid-edit emms-player-mplayer emms-player-simple emms
emms-compat cl-extra use-package-core derived hl-line winner ring
help-mode finder-inf json-reformat-autoloads json-snatcher-autoloads
sml-mode-autoloads tornado-template-mode-autoloads info package
browse-url url url-proxy url-privacy url-expand url-methods url-history
url-cookie url-domsuf url-util mailcap url-handlers url-parse
auth-source cl-seq eieio eieio-core cl-macs eieio-loaddefs
password-cache json map url-vars seq gv subr-x byte-opt bytecomp
byte-compile cconv cl-loaddefs cl-lib iso-transl tooltip eldoc paren
electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel
term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image
regexp-opt fringe tree-sitter tabulated-list replace newcomment
text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow
isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax
font-core term/tty-colors frame minibuffer cl-generic cham georgian
utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean
japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european
ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop
case-table epa-hook jka-cmpr-hook help simple abbrev obarray
cl-preloaded nadvice button loaddefs faces cus-face macroexp files
window text-properties overlay sha1 md5 base64 format env code-pages
mule custom widget keymap hashtable-print-readable backquote threads
dbusbind inotify lcms2 dynamic-setting system-font-setting
font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty
make-network-process emacs)
Memory information:
((conses 16 1969180 294620)
(symbols 48 48794 39)
(strings 32 221116 65789)
(string-bytes 1 7664223)
(vectors 16 109891)
(vector-slots 8 2944995 231043)
(floats 8 2724 5770)
(intervals 56 234293 3942)
(buffers 992 66))
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module,
dick . r . chiang <=
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, Robert Pluim, 2021/11/30
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, dick, 2021/11/30
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, Lars Ingebrigtsen, 2021/11/30
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, dick, 2021/11/30
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, Lars Ingebrigtsen, 2021/11/30
- bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module, Robert Pluim, 2021/11/30