214 lines
8.2 KiB
EmacsLisp
214 lines
8.2 KiB
EmacsLisp
;;; erc-d-u.el --- Helpers for ERC test server -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2020-2024 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
|