emacs/lisp/emacs-lisp/ert-x.el

;;; ert-x.el --- Staging area for experimental extensions to ERT  -*- lexical-binding: t -*-

;; Copyright (C) 2008, 2010-2025 Free Software Foundation, Inc.

;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;;         Christian Ohler <ohler@gnu.org>

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

;; This file includes some extra helper functions to use while writing
;; automated tests with ERT.  These have been proposed as extensions
;; to ERT but are not mature yet and likely to change.

;;; Code:

(eval-when-compile (require 'cl-lib))
(require 'ert)
(require 'subr-x)

;;; Simulate commands.

(defun ert-simulate-command (command)
  ;; FIXME: add unread-events
  "Simulate calling COMMAND the way the Emacs command loop would call it.

This effectively executes

  (apply (car COMMAND) (cdr COMMAND))

and returns the same value, but additionally runs hooks like
`pre-command-hook' and `post-command-hook', and sets variables
like `this-command' and `last-command'.

COMMAND should be a list where the car is the command symbol and
the rest are arguments to the command.

NOTE: Since the command is not called by `call-interactively'
test for `called-interactively' in the command will fail."
  (cl-assert (listp command) t)
  (cl-assert (commandp (car command)) t)
  (cl-assert (not unread-command-events) t)
  (let (return-value)
    ;; For the order of things here see command_loop_1 in keyboard.c.
    ;;
    ;; The command loop will reset the command-related variables so
    ;; there is no reason to let-bind them. They are set here,
    ;; however, to be able to test several commands in a row and how
    ;; they affect each other.
    (setq deactivate-mark nil
          this-original-command (car command)
          ;; remap through active keymaps
          this-command (or (command-remapping this-original-command)
                           this-original-command))
    (run-hooks 'pre-command-hook)
    (setq return-value (apply (car command) (cdr command)))
    (run-hooks 'post-command-hook)
    (setq real-last-command (car command)
          last-command this-command)
    (when (boundp 'last-repeatable-command)
      (setq last-repeatable-command real-last-command))
    (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
    (cl-assert (not unread-command-events) t)
    return-value))

(defmacro ert-simulate-keys (keys &rest body)
  "Execute BODY with KEYS as pseudo-interactive input."
  (declare (debug t) (indent 1))
  `(let ((unread-command-events
          ;; Add some C-g to try and make sure we still exit
          ;; in case something goes wrong.
          (append ,keys '(?\C-g ?\C-g ?\C-g)))
         ;; Tell `read-from-minibuffer' not to read from stdin when in
         ;; batch mode.
         (executing-kbd-macro t))
     ,@body))

(defun ert-run-idle-timers ()
  "Run all idle timers (from `timer-idle-list')."
  (dolist (timer (copy-sequence timer-idle-list))
    (timer-event-handler timer)))


;;; Miscellaneous utilities.

(defun ert-filter-string (s &rest regexps)
  "Return a copy of S with all matches of REGEXPS removed.

Elements of REGEXPS may also be two-element lists \(REGEXP
SUBEXP), where SUBEXP is the number of a subexpression in
REGEXP.  In that case, only that subexpression will be removed
rather than the entire match."
  ;; Use a temporary buffer since replace-match copies strings, which
  ;; would lead to N^2 runtime.
  (with-temp-buffer
    (insert s)
    (dolist (x regexps)
      (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
        (goto-char (point-min))
        (while (re-search-forward regexp nil t)
          (replace-match "" t t nil subexp))))
    (buffer-string)))


(defun ert-propertized-string (&rest args)
  "Return a string with properties as specified by ARGS.

ARGS is a list of strings and plists.  The strings in ARGS are
concatenated to produce an output string.  In the output string,
each string from ARGS will be have the preceding plist as its
property list, or no properties if there is no plist before it.

As a simple example,

\(ert-propertized-string \"foo \" \\='(face italic) \"bar\" \" baz\" nil \
\" quux\")

would return the string \"foo bar baz quux\" where the substring
\"bar baz\" has a `face' property with the value `italic'.

None of the ARGS are modified, but the return value may share
structure with the plists in ARGS."
  (with-temp-buffer
    (cl-loop with current-plist = nil
             for x in args do
             (cl-etypecase x
               (string (let ((begin (point)))
                         (insert x)
                         (set-text-properties begin (point) current-plist)))
               (list (unless (evenp (length x))
                       (error "Odd number of args in plist: %S" x))
                     (setq current-plist x))))
    (buffer-string)))

(defun ert-buffer-string-reindented (&optional buffer)
  "Return the contents of BUFFER after reindentation.

BUFFER defaults to current buffer.  Does not modify BUFFER."
  (with-current-buffer (or buffer (current-buffer))
    (let ((clone nil))
      (unwind-protect
          (progn
            ;; `clone-buffer' doesn't work if `buffer-file-name' is non-nil.
            (let ((buffer-file-name nil))
              (setq clone (clone-buffer)))
            (with-current-buffer clone
              (let ((inhibit-read-only t))
                (indent-region (point-min) (point-max)))
              (buffer-string)))
        (when clone
          (let ((kill-buffer-query-functions nil))
            (kill-buffer clone)))))))


(defmacro ert-with-message-capture (var &rest body)
  "Execute BODY while collecting messages in VAR.

Capture messages issued by Lisp code and concatenate them
separated by newlines into one string.  This includes messages
written by `message' as well as objects printed by `print',
`prin1' and `princ' to the echo area.  Messages issued from C
code using the above mentioned functions will not be captured.

This is useful for separating the issuance of messages by the
code under test from the behavior of the *Messages* buffer."
  (declare (debug (symbolp body))
           (indent 1))
  (cl-with-gensyms (g-message-advice g-print-advice g-collector)
    `(let* ((,var "")
            (,g-collector (lambda (msg) (setq ,var (concat ,var msg))))
            (,g-message-advice (ert--make-message-advice ,g-collector))
            (,g-print-advice (ert--make-print-advice ,g-collector)))
       (advice-add 'message :around ,g-message-advice)
       (advice-add 'prin1 :around ,g-print-advice)
       (advice-add 'princ :around ,g-print-advice)
       (advice-add 'print :around ,g-print-advice)
       (unwind-protect
           (progn ,@body)
         (advice-remove 'print ,g-print-advice)
         (advice-remove 'princ ,g-print-advice)
         (advice-remove 'prin1 ,g-print-advice)
         (advice-remove 'message ,g-message-advice)))))

(defun ert--make-message-advice (collector)
  "Create around advice for `message' for `ert-collect-messages'.
COLLECTOR will be called with the message before it is passed
to the real `message'."
  (lambda (func &rest args)
    (if (or (null args) (member (car args) '("" nil)))
        (apply func args)
      (let ((msg (apply #'format-message args)))
        (funcall collector (concat msg "\n"))
        (funcall func "%s" msg)))))

(defun ert--make-print-advice (collector)
  "Create around advice for print functions for `ert-collect-messages'.
The created advice function will just call the original function
unless the output is going to the echo area (when PRINTCHARFUN is
t or PRINTCHARFUN is nil and `standard-output' is t).  If the
output is destined for the echo area, the advice function will
convert it to a string and pass it to COLLECTOR first."
  ;;; FIXME: Pass on OVERRIDES.
  (lambda (func object &optional printcharfun _overrides)
    (if (not (eq t (or printcharfun standard-output)))
        (funcall func object printcharfun)
      (funcall collector (with-output-to-string
                           (funcall func object)))
      (funcall func object printcharfun))))

(defvar ert-resource-directory-format "%s-resources/"
  "Format for `ert-resource-directory'.")
(defvar ert-resource-directory-trim-left-regexp ""
  "Regexp for `string-trim' (left) used by `ert-resource-directory'.")
(defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el"
  "Regexp for `string-trim' (right) used by `ert-resource-directory'.")

(defmacro ert-resource-directory ()
  "Return absolute file name of the resource (test data) directory.

The path to the resource directory is the \"resources\" directory
in the same directory as the test file this is called from.

If that directory doesn't exist, find a directory based on the
test file name.  If the file is named \"foo-tests.el\", return
the absolute file name for \"foo-resources\".

If you want a different resource directory naming scheme, set the
variable `ert-resource-directory-format'.  Before formatting, the
file name will be trimmed using `string-trim' with arguments
`ert-resource-directory-trim-left-regexp' and
`ert-resource-directory-trim-right-regexp'."
  `(when-let* ((testfile ,(or (macroexp-file-name)
                              buffer-file-name)))
     (let ((default-directory (file-name-directory testfile)))
       (file-truename
        (if (file-accessible-directory-p "resources/")
            (expand-file-name "resources/")
          (expand-file-name
           (format ert-resource-directory-format
                   (string-trim testfile
                                ert-resource-directory-trim-left-regexp
                                ert-resource-directory-trim-right-regexp))))))))

(defmacro ert-resource-file (file)
  "Return absolute file name of resource (test data) file named FILE.
A resource file is defined as any file placed in the resource
directory as returned by `ert-resource-directory'."
  `(expand-file-name ,file (ert-resource-directory)))

(defvar ert-temp-file-prefix "emacs-test-"
  "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.")

(defvar ert-temp-file-suffix nil
  "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.")

(defun ert--with-temp-file-generate-suffix (filename)
  "Generate temp file suffix from FILENAME."
  (thread-last
    (file-name-base filename)
    (replace-regexp-in-string (rx string-start
                                  (group (+? not-newline))
                                  (regexp "-?tests?")
                                  string-end)
                              "\\1")
    (concat "-")))

(defmacro ert-with-temp-file (name &rest body)
  "Bind NAME to the name of a new temporary file and evaluate BODY.
Delete the temporary file after BODY exits normally or
non-locally.  NAME will be bound to the file name of the temporary
file.

The following keyword arguments are supported:

:prefix STRING  If non-nil, pass STRING to `make-temp-file' as
                the PREFIX argument.  Otherwise, use the value of
                `ert-temp-file-prefix'.

:suffix STRING  If non-nil, pass STRING to `make-temp-file' as the
                SUFFIX argument.  Otherwise, use the value of
                `ert-temp-file-suffix'; if the value of that
                variable is nil, generate a suffix based on the
                name of the file that `ert-with-temp-file' is
                called from.

:text STRING    If non-nil, pass STRING to `make-temp-file' as
                the TEXT argument.

:buffer SYMBOL  Open the temporary file using `find-file-noselect'
                and bind SYMBOL to the buffer.  Kill the buffer
                after BODY exits normally or non-locally.

:coding CODING  If non-nil, bind `coding-system-for-write' to CODING
                when executing BODY.  This is handy when STRING includes
                non-ASCII characters or the temporary file must have a
                specific encoding or end-of-line format.

See also `ert-with-temp-directory'."
  (declare (indent 1) (debug (symbolp body)))
  (cl-check-type name symbol)
  (let (keyw prefix suffix directory text extra-keywords buffer coding)
    (while (keywordp (setq keyw (car body)))
      (setq body (cdr body))
      (pcase keyw
        (:prefix (setq prefix (pop body)))
        (:suffix (setq suffix (pop body)))
        ;; This is only for internal use by `ert-with-temp-directory'
        ;; and is therefore not documented.
        (:directory (setq directory (pop body)))
        (:text (setq text (pop body)))
        (:buffer (setq buffer (pop body)))
        (:coding (setq coding (pop body)))
        (_ (push keyw extra-keywords) (pop body))))
    (when extra-keywords
      (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " ")))
    (let ((temp-file (make-symbol "temp-file"))
          (prefix (or prefix ert-temp-file-prefix))
          (suffix (or suffix ert-temp-file-suffix
                      (ert--with-temp-file-generate-suffix
                       (or (macroexp-file-name) buffer-file-name)))))
      `(let* ((coding-system-for-write ,(or coding coding-system-for-write))
              (,temp-file (,(if directory 'file-name-as-directory 'identity)
                           (make-temp-file ,prefix ,directory ,suffix ,text)))
              (,name ,(if directory
                          `(file-name-as-directory ,temp-file)
                        temp-file))
              ,@(when buffer
                  (list `(,buffer (find-file-literally ,temp-file)))))
         (unwind-protect
             (progn ,@body)
           (ignore-errors
             ,@(when buffer
                 (list `(with-current-buffer ,buffer
                          (set-buffer-modified-p nil))
                       `(kill-buffer ,buffer))))
           (ignore-errors
             ,(if directory
                  `(delete-directory ,temp-file :recursive)
                `(delete-file ,temp-file))))))))

(defmacro ert-with-temp-directory (name &rest body)
  "Bind NAME to the name of a new temporary directory and evaluate BODY.
Delete the temporary directory after BODY exits normally or
non-locally.

NAME is bound to the directory name, not the directory file
name.  (In other words, it will end with the directory delimiter;
on Unix-like systems, it will end with \"/\".)

The same keyword arguments are supported as in
`ert-with-temp-file' (which see), except for :text."
  (declare (indent 1) (debug (symbolp body)))
  (let ((tail body) keyw)
    (while (keywordp (setq keyw (car tail)))
      (setq tail (cddr tail))
      (pcase keyw (:text (error "Invalid keyword for directory: :text")))))
  `(ert-with-temp-file ,name
     :directory t
     ,@body))

(defun ert-gcc-is-clang-p ()
  "Return non-nil if the `gcc' command actually runs the Clang compiler."
  (require 'ffap)
  (declare-function ffap--gcc-is-clang-p "ffap" ())
  (ffap--gcc-is-clang-p))

(defvar tramp-default-host-alist)
(defvar tramp-methods)
(defvar tramp-remote-path)

;; This should happen on hydra only.
(when (and (featurep 'tramp) (getenv "EMACS_HYDRA_CI"))
  (add-to-list 'tramp-remote-path 'tramp-own-remote-path))

;; If this defvar is used in a test file, `tramp' shall be loaded
;; prior `ert-x'.  There is no default value on w32 systems, which
;; could work out of the box.
(defvar ert-remote-temporary-file-directory
  (when (featurep 'tramp)
    (cond
     ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY"))
     ((eq system-type 'windows-nt) null-device)
     ;; Android's built-in shell is far too dysfunctional to support
     ;; Tramp.
     ((eq system-type 'android) null-device)
     (t (add-to-list
         'tramp-methods
         '("mock"
	   (tramp-login-program	     "sh")
	   (tramp-login-args	     (("-i")))
           (tramp-direct-async       ("-c"))
	   (tramp-remote-shell	     "/bin/sh")
	   (tramp-remote-shell-args  ("-c"))
	   (tramp-connection-timeout 10)))
        (add-to-list
         'tramp-default-host-alist
         `("\\`mock\\'" nil ,(system-name)))
        ;; Emacs's Makefile sets $HOME to a nonexistent value.  Needed
        ;; in batch mode only, therefore.
        (when (and noninteractive (not (file-directory-p "~/")))
          (setenv "HOME" (directory-file-name temporary-file-directory)))
        (format "/mock::%s" temporary-file-directory))))
  "Temporary directory for remote file tests.")


;;;; Obsolete

(cl-defmacro ert-with-test-buffer-selected ((&key name) &body body)
  "Create a test buffer, switch to it, and run BODY.

This combines `ert-with-test-buffer' and `ert-with-buffer-selected'.
The return value is the last form in BODY."
  (declare (obsolete ert-with-test-buffer "31.1")
           (debug ((":name" form) body)) (indent 1))
  `(ert-with-test-buffer (:name ,name :selected t)
     ,@body))

(provide 'ert-x)

;;; ert-x.el ends here