emacs/test/lisp/erc/resources/erc-d/erc-d-u.el

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