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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
;;; erc-d-u.el --- Helpers for ERC test server -*- lexical-binding: t -*-
;; Copyright (C) 2020-2025 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/>.
;;; Commentary:
;; The utilities here are kept separate from those in `erc-d' so that
;; tests running the server in a subprocess can use them without
;; having to require the main lib. If migrating outside of test/lisp,
;; there may be no reason to continue this.
;;
;; Another (perhaps misguided) goal here is to avoid having ERC itself
;; as a dependency.
;;
;; FIXME this ^ is no longer the case (ERC is not a dependency)
;;; Code:
(require 'rx)
(require 'subr-x)
(eval-when-compile (require 'ert))
(defvar erc-d-u--canned-buffers nil
"List of canned dialog buffers currently open for reading.")
(cl-defstruct (erc-d-u-scan-d) ; dialog scanner
(buf nil :type buffer)
(done nil :type boolean)
(last nil :type integer)
(hunks nil :type (list-of marker))
(f #'erc-d-u--read-exchange-default :type function))
(cl-defstruct (erc-d-u-scan-e) ; exchange scanner
(sd nil :type erc-d-u-scan-d)
(pos nil :type marker))
(defun erc-d-u--read-dialog (info)
"Read dialog file and stash relevant state in `erc-d-u-scan-d' INFO."
(if (and (buffer-live-p (erc-d-u-scan-d-buf info))
(with-current-buffer (erc-d-u-scan-d-buf info)
(condition-case _err
(progn
(when (erc-d-u-scan-d-last info)
(goto-char (erc-d-u-scan-d-last info))
(forward-list))
(setf (erc-d-u-scan-d-last info) (point))
(down-list)
(push (set-marker (make-marker) (point))
(erc-d-u-scan-d-hunks info)))
((end-of-buffer scan-error)
(setf (erc-d-u-scan-d-done info) t)
nil))))
(make-erc-d-u-scan-e :sd info :pos (car (erc-d-u-scan-d-hunks info)))
(unless (erc-d-u-scan-d-hunks info)
(kill-buffer (erc-d-u-scan-d-buf info))
nil)))
(defun erc-d-u--read-exchange-default (info)
"Read from marker in exchange `erc-d-u-scan-e' object INFO."
(let ((hunks (erc-d-u-scan-e-sd info))
(pos (erc-d-u-scan-e-pos info)))
(or (and (erc-d-u-scan-d-hunks hunks)
(buffer-live-p (erc-d-u-scan-d-buf hunks))
(with-current-buffer (erc-d-u-scan-d-buf hunks)
(goto-char pos)
(condition-case _err
(read pos)
;; Raised unless malformed
(invalid-read-syntax
nil))))
(unless (or (cl-callf (lambda (s) (delq pos s)) ; flip
(erc-d-u-scan-d-hunks hunks))
(not (erc-d-u-scan-d-done hunks)))
(kill-buffer (erc-d-u-scan-d-buf hunks))
nil))))
(defun erc-d-u--read-exchange (info)
"Call exchange reader assigned in `erc-d-u-scan-e' object INFO."
(funcall (erc-d-u-scan-d-f (erc-d-u-scan-e-sd info)) info))
(defun erc-d-u--canned-read (file)
"Dispense a reader for each exchange in dialog FILE."
(let ((buf (generate-new-buffer (file-name-nondirectory file))))
(push buf erc-d-u--canned-buffers)
(with-current-buffer buf
(setq-local parse-sexp-ignore-comments t
coding-system-for-read 'utf-8)
(add-hook 'kill-buffer-hook
(lambda () (setq erc-d-u--canned-buffers
(delq buf erc-d-u--canned-buffers)))
nil 'local)
(insert-file-contents-literally file)
(lisp-data-mode))
(make-erc-d-u-scan-d :buf buf)))
(defvar erc-d-u--library-directory (file-name-directory load-file-name))
(defvar erc-d-u-canned-dialog-dir
(file-name-as-directory (expand-file-name "resources"
erc-d-u--library-directory)))
(defun erc-d-u--normalize-canned-name (dialog)
"Return DIALOG name as a symbol without validating it."
(if (symbolp dialog)
dialog
(intern (file-name-base dialog))))
(defvar erc-d-u-canned-file-name-extension ".eld")
(defun erc-d-u--expand-dialog-symbol (dialog)
"Return filename based on symbol DIALOG."
(let ((name (symbol-name dialog)))
(unless (equal (file-name-extension name)
erc-d-u-canned-file-name-extension)
(setq name (concat name erc-d-u-canned-file-name-extension)))
(expand-file-name name erc-d-u-canned-dialog-dir)))
(defun erc-d-u--massage-canned-name (dialog)
"Return DIALOG in a form acceptable to `erc-d-run'."
(if (or (symbolp dialog) (file-exists-p dialog))
dialog
(erc-d-u--expand-dialog-symbol (intern dialog))))
(defun erc-d-u--canned-load-dialog (dialog)
"Load dispensing exchanges from DIALOG.
If DIALOG is a string, consider it a filename. Otherwise find a file
in `erc-d-u-canned-dialog-dir' with a base name matching the symbol's
name.
Return an iterator that yields exchanges, each one an iterator of spec
forms. The first is a so-called request spec and the rest are composed
of zero or more response specs."
(when (symbolp dialog)
(setq dialog (erc-d-u--expand-dialog-symbol dialog)))
(unless (file-exists-p dialog)
(error "File not found: %s" dialog))
(erc-d-u--canned-read dialog))
(defun erc-d-u--read-exchange-slowly (num orig info)
(when-let ((spec (funcall orig info)))
(when (symbolp (car spec))
(setf spec (copy-sequence spec)
(nth 1 spec) (cond ((functionp num) (funcall num (nth 1 spec)))
((< num 0) (max (nth 1 spec) (- num)))
(t (+ (nth 1 spec) num)))))
spec))
(defun erc-d-u--rewrite-for-slow-mo (num read-info)
"Return READ-INFO with a modified reader.
When NUM is a positive number, delay incoming requests by NUM more
seconds. If NUM is negative, raise insufficient incoming delays to at
least -NUM seconds. If NUM is a function, set each delay to whatever it
returns when called with the existing value."
(let ((orig (erc-d-u-scan-d-f read-info)))
(setf (erc-d-u-scan-d-f read-info)
(apply-partially #'erc-d-u--read-exchange-slowly num orig))
read-info))
(defun erc-d-u--get-remote-port (process)
"Return peer TCP port for client PROCESS.
When absent, just generate an id."
(let ((remote (plist-get (process-contact process t) :remote)))
(if (vectorp remote)
(aref remote (1- (length remote)))
(format "%s:%d" (process-contact process :local)
(logand 1023 (time-convert nil 'integer))))))
(defun erc-d-u--format-bind-address (process)
"Return string or (STRING . INT) for bind address of network PROCESS."
(let ((local (process-contact process :local)))
(if (vectorp local) ; inet
(cons (mapconcat #'number-to-string (seq-subseq local 0 -1) ".")
(aref local (1- (length local))))
local)))
(defun erc-d-u--unkeyword (plist)
"Return a copy of PLIST with keywords keys converted to non-keywords."
(cl-loop for (key value) on plist by #'cddr
when (keywordp key)
do (setq key (intern (substring (symbol-name key) 1)))
append (list key value)))
(defun erc-d-u--massage-rx-args (key val)
" Massage val so it's suitable for an `rx-let' binding.
Handle cases in which VAL is ([ARGLIST] RX-FORM) rather than just
RX-FORM. KEY becomes the binding name."
(if (and (listp val)
(cdr val)
(not (cddr val))
(consp (car val)))
(cons key val)
(list key val)))
(defvar-local erc-d-u--process-buffer nil
"Beacon for erc-d process buffers.
The server process is usually deleted first, but we may want to examine
the buffer afterward.")
(provide 'erc-d-u)
;;; erc-d-u.el ends here
|
