all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob 370cf86148ab0966e96ffca40a04ae19db79311a 7033 bytes (raw)
name: test/lisp/server-tests.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
 
;;; server-tests.el --- Emacs server test suite  -*- lexical-binding:t -*-

;; Copyright (C) 2022 Free Software Foundation, Inc.

;; 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.

;; 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Code:

(require 'ert)
(require 'server)

(defconst server-tests/emacsclient
  (if installation-directory
      (expand-file-name "lib-src/emacsclient" installation-directory)
    "emacsclient")
  "The emacsclient binary to test.")

(defun server-tests/start-emacsclient (&rest args)
  "Run emacsclient, passing ARGS as arguments to it."
  (let ((socket-name (process-get server-process :server-file)))
    (make-process
     :name server-tests/emacsclient
     :command (append (list server-tests/emacsclient
                            "--socket-name" socket-name)
                      args))))

(defmacro server-tests/with-server (&rest body)
  "Start the Emacs server, evaluate BODY, and then stop the server."
  (declare (indent 0))
  `(progn
     (server-start)
     (unwind-protect
         (progn (should (processp server-process))
                ,@body)
       (let ((inhibit-message t))
         (server-start t t))
       (should (null server-process))
       (should (null server-clients)))))

(defconst server-tests/max-wait-time 5
  "The maximum time to wait in `server-tests/wait-until', in seconds.")

(defmacro server-tests/wait-until (form)
  "Wait until FORM is non-nil, timing out and failing if it takes too long."
  `(let ((start (current-time)))
    (while (not ,form)
      (when (> (float-time (time-since start))
               server-tests/max-wait-time)
        (ert-fail (format "timed out waiting for %S to be non-nil" ',form)))
      (sit-for 0.1))))

(defvar server-tests/variable nil)

;;; Tests:

(ert-deftest server-tests/server-start/sets-minor-mode ()
  "Ensure that calling `server-start' also sets `server-mode' properly."
  (server-tests/with-server
    ;; Make sure starting the server activates the minor mode.
    (should (eq server-mode t))
    (should (memq 'server-mode global-minor-modes)))
  ;; Make sure stopping the server deactivates the minor mode.
  (should (eq server-mode nil))
  (should-not (memq 'server-mode global-minor-modes)))

(ert-deftest server-tests/server-start/stop-prompt-with-client ()
  "Ensure that stopping the server prompts when there are clients."
  (server-tests/with-server
    (let ((yes-or-no-p-called nil)
          (emacsclient (server-tests/start-emacsclient "-c")))
      (server-tests/wait-until (length= (frame-list) 2))
      (cl-letf (((symbol-function 'yes-or-no-p)
                 (lambda (_prompt)
                   (setq yes-or-no-p-called t))))
        (server-start t)
        (should yes-or-no-p-called))
      (server-tests/wait-until (eq (process-status emacsclient) 'exit)))))

(ert-deftest server-tests/server-start/no-stop-prompt-without-client ()
  "Ensure that stopping the server doesn't prompt when there are no clients."
  (server-tests/with-server
    (let ((yes-or-no-p-called nil))
      (cl-letf (((symbol-function 'yes-or-no-p)
                 (lambda (_prompt)
                   (setq yes-or-no-p-called t))))
        (let ((inhibit-message t))
          (server-start t))
        (should-not yes-or-no-p-called)))))

(ert-deftest server-tests/emacsclient/server-edit ()
  "Test that calling `server-edit' from a client buffer exits the client."
  (server-tests/with-server
    (let ((emacsclient (server-tests/start-emacsclient "file.txt")))
      (server-tests/wait-until (get-buffer "file.txt"))
      (should (eq (process-status emacsclient) 'run))
      (should (length= server-clients 1))
      (with-current-buffer "file.txt"
        (server-edit))
      (server-tests/wait-until (eq (process-status emacsclient) 'exit)))))

(ert-deftest server-tests/emacsclient/create-frame ()
  "Test that \"emacsclient -c\" creates a frame."
  (server-tests/with-server
    (let ((emacsclient (server-tests/start-emacsclient "-c")))
      (server-tests/wait-until (length= (frame-list) 2))
      (should (eq (process-status emacsclient) 'run))
      (should (length= server-clients 1))
      (should (eq (frame-parameter (car (frame-list)) 'client)
                  (car server-clients)))))
  ;; The client frame should go away after the server stops.
  (should (length= (frame-list) 1)))

(ert-deftest server-tests/emacsclient/eval ()
  "Test that \"emacsclient --eval\" works correctly."
  (server-tests/with-server
    (let ((value (random)))
      (server-tests/start-emacsclient
       "--eval" (format "(setq server-tests/variable %d)" value))
      (server-tests/wait-until (eq server-tests/variable value)))))

(ert-deftest server-tests/server-force-stop/keeps-frames ()
  "Ensure that `server-force-stop' doesn't delete frames.  See bug#58877.
Note: since that bug is about a behavior when killing Emacs, this
test is somewhat indirect. (Killing the current Emacs instance
would make it hard to check test results!)  Instead, it only
tests that `server-force-stop' doesn't delete frames (and even
then, requires a few tricks to run as a regression test).  So
long as this works, the problem in bug#58877 shouldn't occur."
  (let (terminal)
    (unwind-protect
        (server-tests/with-server
          (let ((emacsclient (server-tests/start-emacsclient "-c")))
            (server-tests/wait-until (length= (frame-list) 2))
            (should (eq (process-status emacsclient) 'run))

            ;; Don't delete the terminal for the client; that would
            ;; kill its frame immediately too.  (This is only an issue
            ;; when running these tests via the command line;
            ;; normally, in an interactive session, we don't need to
            ;; worry about this.  But since we want to check that
            ;; `server-force-stop' doesn't delete frames under normal
            ;; circumstances, we need to bypass terminal deletion
            ;; here.)
            (setq terminal (process-get (car server-clients) 'terminal))
            (process-put (car server-clients) 'no-delete-terminal t)

            (server-force-stop))
          ;; Ensure we didn't delete the frame.
          (should (length= (frame-list) 2)))
      ;; Clean up after ourselves and delete the terminal.
      (when (and terminal
                 (eq (terminal-live-p terminal) t)
                 (not (eq system-type 'windows-nt)))
        (delete-terminal terminal)))))

;;; server-tests.el ends here

debug log:

solving 370cf86148 ...
found 370cf86148 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

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

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.