unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module
@ 2021-11-30  1:38 dick.r.chiang
  2021-11-30 10:33 ` Robert Pluim
  0 siblings, 1 reply; 15+ messages in thread
From: dick.r.chiang @ 2021-11-30  1:38 UTC (permalink / raw)
  To: 52194

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: 0001-Don-t-repeat-yourself-DRY.patch --]
[-- Type: text/x-diff, Size: 35054 bytes --]

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


[-- Attachment #2: Type: text/plain, Size: 7732 bytes --]




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))

^ permalink raw reply related	[flat|nested] 15+ messages in thread
end of thread, other threads:[~2021-12-02  4:35 UTC | newest]

Thread overview: 15+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2021-11-30  1:38 bug#52194: 28.0.50; [PATCH] Put paid to a flappy test module dick.r.chiang
2021-11-30 10:33 ` Robert Pluim
2021-11-30 13:16   ` Lars Ingebrigtsen
2021-11-30 13:41     ` Robert Pluim
2021-11-30 13:53       ` dick
2021-11-30 14:12         ` Robert Pluim
2021-11-30 14:25     ` dick
2021-11-30 14:34       ` Lars Ingebrigtsen
2021-11-30 14:51         ` dick
2021-11-30 15:12           ` Robert Pluim
2021-11-30 15:12           ` Lars Ingebrigtsen
2021-11-30 17:16           ` Eli Zaretskii
2021-12-01  7:05           ` Richard Stallman
2021-12-01 15:05             ` dick
2021-12-02  4:35               ` Richard Stallman

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).