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
| | ;;; erc-d-u.el --- Helpers for ERC test server -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
;;
;; This file is part of GNU Emacs.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see
;; <https://www.gnu.org/licenses/>.
;;; 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 'generator)
(require 'subr-x)
(eval-when-compile (require 'ert))
(defvar erc-d-u--canned-buffers nil
"List of canned dialog buffers currently open for reading.")
(defun erc-d-u--canned-read (file)
"Read canned FILE as generator and yield exchanges as iterators."
(let* ((buf (generate-new-buffer (file-name-nondirectory file)))
(coding-system-for-read 'utf-8)
(parse-sexp-ignore-comments t)
;; Actually, "done" only means outer exchange genny is done.
last done specs
;;
(done-cb (lambda ()
(kill-buffer buf)
(setq erc-d-u--canned-buffers
(delq buf erc-d-u--canned-buffers))))
(fspec (iter-lambda (pos)
(let (val)
(while (and specs
(with-current-buffer buf
(goto-char pos)
(condition-case _err
(setq val (read pos))
;; Raised unless malformed
(invalid-read-syntax nil))))
(iter-yield val)))
(setq specs (delq pos specs))
(unless (or specs (not done))
(funcall done-cb)
(setq done-cb #'ignore)))))
(push buf erc-d-u--canned-buffers)
(with-current-buffer buf
(insert-file-contents-literally file)
(lisp-data-mode))
(iter-lambda ()
;; Yielding isn't allowed inside save-excursion, etc.
(while (with-current-buffer buf
(condition-case _err
(progn
(when last
(goto-char last)
(forward-list))
(setq last (point))
(down-list)
(push (set-marker (make-marker) (point)) specs)
t)
((end-of-buffer scan-error)
(setq done t)
nil)))
;; Suppose we *could* yield specs directly here but then
;; detecting exchange boundaries is more of a headache
(iter-yield (funcall fspec (car specs))))
(unless specs
(funcall done-cb))
nil)))
(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 "erc-d-self-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 "lispdata")
(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 &optional start)
"Load and maybe START dispensing exchanges from DIALOG.
If DIALOG is a string, consider it a file path. 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))
(let ((genny (erc-d-u--canned-read dialog)))
(if start (funcall genny) genny)))
(defun erc-d-u--rewrite-for-slow-mo (num ex-it)
"Return modified iterator or generator from original EX-IT.
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* ((genny-in (zerop (car (func-arity ex-it))))
(g (iter-lambda ()
(let ((ex-it (if genny-in (funcall ex-it) ex-it))
next)
(while
(when (setq next (condition-case err
(iter-next ex-it)
(iter-end-of-sequence
(setq ex-it nil)
(cdr err))))
(iter-yield
(funcall
(iter-lambda ()
(iter-do (spec next)
(when (symbolp (car spec))
(let ((new (cond
((functionp num)
(funcall num (nth 1 spec)))
((< num 0)
(max (nth 1 spec) (- num)))
(t (+ (nth 1 spec) num)))))
(setf (nth 1 spec) new)))
(iter-yield spec)))))
t))
next))))
(if genny-in g (funcall g))))
(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)))
(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
|