1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-29 07:58:28 +00:00
emacs/admin/cus-test.el
Michael Albinus 13c7249105 Fix cus-test-deps
* admin/cus-test.el (cus-test-deps): Add the "quail/" subdirectory
to default-directory, temporarily.
2024-01-23 19:24:29 +01:00

582 lines
19 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; cus-test.el --- tests for custom types and load problems -*- lexical-binding: t; -*-
;; Copyright (C) 1998, 2000, 2002-2024 Free Software Foundation, Inc.
;; Author: Markus Rost <rost@math.uni-bielefeld.de>
;; Created: 13 Sep 1998
;; Keywords: maint
;; 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 provides simple tests to detect custom options with
;; incorrect customization types and load problems for custom and
;; autoload dependencies.
;;
;; The basic tests can be run in batch mode. Invoke them with
;;
;; src/emacs -batch -l admin/cus-test.el -f cus-test-opts [all]
;;
;; src/emacs -batch -l admin/cus-test.el -f cus-test-deps
;;
;; src/emacs -batch -l admin/cus-test.el -f cus-test-libs [all]
;;
;; src/emacs -batch -l admin/cus-test.el -f cus-test-noloads
;;
;; or as a part of the test suite with
;;
;; make -C test test-custom-opts
;; make -C test test-custom-deps
;; make -C test test-custom-libs
;; make -C test test-custom-noloads
;;
;; in the emacs source directory.
;;
;; For interactive use: Load this file. Then
;;
;; M-x cus-test-apropos REGEXP RET
;;
;; checks the options matching REGEXP. In particular
;;
;; M-x cus-test-apropos RET
;;
;; checks all options. The detected options are stored in the
;; variable `cus-test-errors'.
;;
;; Only those options are checked which have been already loaded.
;; Therefore `cus-test-apropos' is more efficient after loading many
;; libraries.
;;
;; M-x cus-test-load-custom-loads
;;
;; loads all (!) custom dependencies and
;;
;; M-x cus-test-load-libs
;;
;; loads all (!) libraries with autoloads.
;;
;; Options with a custom-get property, usually defined by a :get
;; declaration, are stored in the variable
;;
;; `cus-test-vars-with-custom-get'
;;
;; Options with a state of 'changed ("changed outside the customize
;; buffer") are stored in the variable
;;
;; `cus-test-vars-with-changed-state'
;;
;; These lists are prepared just in case one wants to investigate
;; those options further.
;;
;; The command `cus-test-opts' tests many (all?) custom options.
;;
;; The command `cus-test-deps' is like `cus-test-load-custom-loads'
;; but reports about load errors.
;;
;; The command `cus-test-libs' runs for all libraries with autoloads
;; separate emacs processes of the form "emacs -batch -l LIB".
;;
;; The command `cus-test-noloads' returns a list of variables which
;; are somewhere declared as custom options, but not loaded by
;; `custom-load-symbol'.
;;; Code:
;;; Workarounds. For a smooth run and to avoid some side effects.
(defvar cus-test-after-load-libs-hook nil
"Used to switch off undesired side effects of loading libraries.")
(defvar cus-test-skip-list nil
"List of variables to disregard by `cus-test-apropos'.")
(defvar cus-test-libs-noloads
;; Loading dunnet in batch mode leads to a Dead end.
;; blessmail writes a file.
;; characters cannot be loaded twice ("Category `a' is already defined").
'("play/dunnet.el" "emulation/edt-mapper.el"
"loadup.el" "mail/blessmail.el" "international/characters.el"
"cedet/ede/loaddefs.el" "cedet/semantic/loaddefs.el"
"net/tramp-loaddefs.el")
"List of files not to load by `cus-test-load-libs'.
Names should be as they appear in loaddefs.el.")
;; This avoids a hang of `cus-test-apropos' in 21.2.
;; (add-to-list 'cus-test-skip-list 'sh-alias-alist)
(defvar viper-mode)
(or noninteractive
;; Never Viperize.
(setq viper-mode nil))
;; Don't create a file `save-place-file'.
(eval-after-load "saveplace"
'(remove-hook 'kill-emacs-hook 'save-place-kill-emacs-hook))
;; Don't create a file `abbrev-file-name'.
(setq save-abbrevs nil)
;; Avoid compile logs from advised functions.
(eval-after-load "bytecomp"
'(setq ad-default-compilation-action 'never))
;;; Main code:
;; We want to log all messages.
(setq message-log-max t)
(require 'cus-edit)
(require 'cus-load)
(defvar cus-test-errors nil
"List of problematic variables found by `cus-test-apropos'.
Each element is (VARIABLE . PROBLEM); see `cus-test--format-error'.")
(defvar cus-test-tested-variables nil
"List of options tested by last call of `cus-test-apropos'.")
;; I haven't understood this :get stuff. The symbols with a
;; custom-get property are stored here.
(defvar cus-test-vars-with-custom-get nil
"Set by `cus-test-apropos' to a list of options with :get property.")
(defvar cus-test-vars-with-changed-state nil
"Set by `cus-test-apropos' to a list of options with state \\='changed.")
(defvar cus-test-deps-errors nil
"List of require/load problems found by `cus-test-deps'.")
(defvar cus-test-deps-required nil
"List of dependencies required by `cus-test-deps'.
Only unloaded features will be require'd.")
(defvar cus-test-deps-loaded nil
"List of dependencies loaded by `cus-test-deps'.")
(defvar cus-test-libs-errors nil
"List of load problems found by `cus-test-load-libs' or `cus-test-libs'.")
(defvar cus-test-libs-loaded nil
"List of files loaded by `cus-test-load-libs' or `cus-test-libs'.")
(defvar cus-test-vars-not-cus-loaded nil
"A list of options not loaded by `custom-load-symbol'.
Set by `cus-test-noloads'.")
;; (defvar cus-test-vars-cus-loaded nil
;; "A list of options loaded by `custom-load-symbol'.")
(defun cus-test--format-error (err)
"Format an element of `cus-test-errors'."
(pcase err
(`(,var :type-error ,value ,type)
(format "variable: %s\n value: %S\n type: %S" var value type))
(`(,var :other-error ,e)
(format "variable: %s\n error: %S" var e))
(_ (format "%S" err))))
(defun cus-test-apropos (regexp)
"Check the options matching REGEXP.
The detected problematic options are stored in `cus-test-errors'."
(interactive "sVariable regexp: ")
(setq cus-test-errors nil)
(setq cus-test-tested-variables nil)
(mapc
(lambda (symbol)
(push symbol cus-test-tested-variables)
;; Be verbose in case we hang.
(message "Cus Test running...%s %s"
(length cus-test-tested-variables) symbol)
(condition-case alpha
;; FIXME This defaults to 'sexp if no type was specified.
;; Always report such instances as a type mismatch.
;; Currently abusing cusver-scan to do that.
(let* ((type (custom-variable-type symbol))
(conv (widget-convert type))
(get (or (get symbol 'custom-get) 'default-value))
values)
(when (default-boundp symbol)
(push (funcall get symbol) values)
(push (eval (car (get symbol 'standard-value)) t) values))
(if (boundp symbol)
(push (symbol-value symbol) values))
;; That does not work.
;; (push (widget-get conv :value) values)
;; Check the values
(mapc (lambda (value)
(unless (widget-apply conv :match value)
(let ((err (list symbol :type-error value type)))
(unless (member err cus-test-errors)
(push err cus-test-errors)))))
values)
;; Store symbols with a custom-get property.
(when (get symbol 'custom-get)
(add-to-list 'cus-test-vars-with-custom-get symbol))
;; Changed outside the customize buffer?
;; This routine is not very much tested.
(let ((c-value
(or (get symbol 'customized-value)
(get symbol 'saved-value)
(get symbol 'standard-value))))
(and (consp c-value)
(boundp symbol)
(not (equal (eval (car c-value) t) (symbol-value symbol)))
(add-to-list 'cus-test-vars-with-changed-state symbol))))
(error
(let ((err (list symbol :other-error alpha)))
(unless (member err cus-test-errors)
(push err cus-test-errors)))
(message "Error for %s: %s" symbol alpha))))
(cus-test-get-options regexp))
(message "%s options tested"
(length cus-test-tested-variables))
(cus-test-errors-display))
(defun cus-test-cus-load-groups (&optional cus-load)
"Return a list of current custom groups.
If CUS-LOAD is non-nil, include groups from cus-load.el."
(append (mapcar #'cdr custom-current-group-alist)
(if cus-load
(with-temp-buffer
(insert-file-contents (locate-library "cus-load.el"))
(search-forward "(put '")
(beginning-of-line)
(let (res)
(while (and (looking-at "^(put '\\(\\S-+\\)")
(zerop (forward-line 1)))
(push (intern (match-string 1)) res))
res)))))
(defun cus-test-get-options (regexp &optional group)
"Return a list of custom options matching REGEXP.
If GROUP is non-nil, return groups rather than options.
If GROUP is `cus-load', include groups listed in cus-loads as well as
currently defined groups."
(let ((groups (if group (cus-test-cus-load-groups (eq group 'cus-load))))
found)
(mapatoms
(lambda (symbol)
(and
(if group
(memq symbol groups)
(or
;; (custom-variable-p symbol)
(get symbol 'standard-value)
;; (get symbol 'saved-value)
(get symbol 'custom-type)))
(string-match regexp (symbol-name symbol))
(not (member symbol cus-test-skip-list))
(push symbol found))))
found))
(defun cus-test-errors-display ()
"Report about the errors found by cus-test."
(with-output-to-temp-buffer "*cus-test-errors*"
(set-buffer standard-output)
(insert (format "Cus Test tested %s variables.\
See `cus-test-tested-variables'.\n\n"
(length cus-test-tested-variables)))
(if (not cus-test-errors)
(insert "No errors found by cus-test.")
(insert "The following variables seem to have problems:\n\n")
(dolist (e cus-test-errors)
(insert (cus-test--format-error e) "\n")))))
(defun cus-test-load-custom-loads ()
"Call `custom-load-symbol' on all atoms."
(interactive)
(if noninteractive (let (noninteractive) (require 'dunnet)))
(mapatoms #'custom-load-symbol)
(run-hooks 'cus-test-after-load-libs-hook))
(defmacro cus-test-load-1 (&rest body)
`(progn
(setq cus-test-libs-errors nil
cus-test-libs-loaded nil)
,@body
(message "%s libraries loaded successfully"
(length cus-test-libs-loaded))
(if (not cus-test-libs-errors)
(message "No load problems encountered")
(message "The following load problems appeared:")
(cus-test-message cus-test-libs-errors))
(run-hooks 'cus-test-after-load-libs-hook)))
;; This is just cus-test-libs, but loading in the current Emacs process.
(defun cus-test-load-libs (&optional more)
"Load the libraries with autoloads.
Don't load libraries in `cus-test-libs-noloads'.
If optional argument MORE is \"defcustom\", load all files with defcustoms.
If it is \"all\", load all Lisp files."
(interactive)
(cus-test-load-1
(let ((lispdir (file-name-directory (locate-library "loaddefs"))))
(mapc
(lambda (file)
(condition-case alpha
(unless (member file cus-test-libs-noloads)
(load (file-name-sans-extension (expand-file-name file lispdir))
nil t)
(push file cus-test-libs-loaded))
(error
(push (cons file alpha) cus-test-libs-errors)
(message "Error for %s: %s" file alpha))))
(if more
(cus-test-get-lisp-files (equal more "all"))
(cus-test-get-autoload-deps))))))
(defun cus-test-get-autoload-deps ()
"Return the list of files with autoloads."
(with-temp-buffer
(insert-file-contents (locate-library "loaddefs"))
(let (files)
(while (search-forward "\n;;; Generated autoloads from " nil t)
(push (buffer-substring (match-end 0) (line-end-position)) files))
files)))
(defun cus-test-get-lisp-files (&optional all)
"Return list of all Lisp files with defcustoms.
Optional argument ALL non-nil means list all (non-obsolete) Lisp files."
(let ((default-directory (expand-file-name "lisp/" source-directory))
(msg "Finding files..."))
(message "%s" msg)
(prog1
;; Hack to remove leading "./".
(mapcar (lambda (e) (substring e 2))
(apply #'process-lines find-program
"." "-name" "obsolete" "-prune" "-o"
"-name" "ldefs-boot.el" "-prune" "-o"
"-name" "*loaddefs.el" "-prune" "-o"
"-name" "[^.]*.el" ; ignore .dir-locals.el
(if all
'("-print")
(list "-exec" grep-program
"-l" "^[ \t]*(defcustom" "{}" "+"))))
(message "%sdone" msg))))
(defun cus-test-message (list)
"Print the members of LIST line by line."
(dolist (m list) (message "%s" m)))
;;; The routines for batch mode:
(defun cus-test-opts (&optional all)
"Test custom options.
This function is suitable for batch mode. E.g., invoke
src/emacs -batch -l admin/cus-test.el -f cus-test-opts
in the Emacs source directory.
Normally only tests options belonging to files in loaddefs.el.
If optional argument ALL is non-nil, test all files with defcustoms.
Returns a list of variables with suspicious types."
(interactive)
(and noninteractive
command-line-args-left
(setq all (pop command-line-args-left)))
(message "Running %s" 'cus-test-load-libs)
(cus-test-load-libs (if all "defcustom"))
(message "Running %s" 'cus-test-load-custom-loads)
(cus-test-load-custom-loads)
(message "Running %s" 'cus-test-apropos)
(cus-test-apropos "")
(if (not cus-test-errors)
(progn
(message "No problems found")
nil)
(message "The following options might have problems:")
(cus-test-message (mapcar #'cus-test--format-error cus-test-errors))
cus-test-errors))
(defun cus-test-deps ()
"Run a verbose version of `custom-load-symbol' on all atoms.
This function is suitable for batch mode. E.g., invoke
src/emacs -batch -l admin/cus-test.el -f cus-test-deps
in the Emacs source directory."
(interactive)
(setq cus-test-deps-errors nil)
(setq cus-test-deps-required nil)
(setq cus-test-deps-loaded nil)
(mapatoms
;; This code is mainly from `custom-load-symbol'.
(lambda (symbol)
(let ((custom-load-recursion t)
(load-path
(cons
(expand-file-name
"quail" (file-name-directory (locate-library leim-list-file-name)))
load-path)))
(dolist (load (get symbol 'custom-loads))
(cond
((symbolp load)
;; (condition-case nil (require load) (error nil))
(condition-case alpha
(unless (or (featurep load)
(and noninteractive (eq load 'dunnet)))
(require load)
(push (list symbol load) cus-test-deps-required))
(error
(push (list symbol load alpha) cus-test-deps-errors)
(message "Require problem: %s %s %s" symbol load alpha))))
((equal load "loaddefs")
(push
(message "Symbol %s has loaddefs as custom dependency" symbol)
cus-test-deps-errors))
;; This is subsumed by the test below, but it's much
;; faster.
((assoc load load-history))
;; This was just
;; (assoc (locate-library load) load-history)
;; but has been optimized not to load locate-library
;; if not necessary.
((let ((regexp (concat "\\(\\`\\|/\\)" (regexp-quote load)
"\\(\\'\\|\\.\\)"))
(found nil))
(dolist (loaded load-history)
(and (stringp (car loaded))
(string-match regexp (car loaded))
(setq found t)))
found))
;; Without this, we would load cus-edit recursively.
;; We are still loading it when we call this,
;; and it is not in load-history yet.
((equal load "cus-edit"))
;; This would ignore load problems with files in
;; lisp/term/
;; ((locate-library (concat term-file-prefix load)))
(t
;; (condition-case nil (load load) (error nil))
(condition-case alpha
(progn
(load load)
(push (list symbol load) cus-test-deps-loaded))
(error
(push (list symbol load alpha) cus-test-deps-errors)
(message "Load Problem: %s %s %s" symbol load alpha))))
)))))
(message "%s features required"
(length cus-test-deps-required))
(message "%s files loaded"
(length cus-test-deps-loaded))
(if (not cus-test-deps-errors)
(message "No load problems encountered")
(message "The following load problems appeared:")
(cus-test-message cus-test-deps-errors))
(run-hooks 'cus-test-after-load-libs-hook))
(defun cus-test-libs (&optional more)
"Load the libraries with autoloads in separate processes.
This function is useful to detect load problems of libraries.
It is suitable for batch mode. E.g., invoke
./src/emacs -batch -l admin/cus-test.el -f cus-test-libs
in the Emacs source directory.
If optional argument MORE is \"defcustom\", load all files with defcustoms.
If it is \"all\", load all Lisp files."
(interactive)
(and noninteractive
command-line-args-left
(setq more (pop command-line-args-left)))
(cus-test-load-1
(let* ((default-directory source-directory)
(emacs (expand-file-name "src/emacs"))
skipped)
(or (file-executable-p emacs)
(error "No such executable `%s'" emacs))
(mapc
(lambda (file)
(if (member file cus-test-libs-noloads)
(push file skipped)
(condition-case alpha
(let* ((fn (expand-file-name file "lisp/"))
(elc (concat fn "c"))
status)
(if (file-readable-p elc) ; load compiled if present (faster)
(setq fn elc)
(or (file-readable-p fn)
(error "Library %s not found" file)))
(if (equal 0 (setq status (call-process emacs nil nil nil
"-batch" "-l" fn)))
(message "%s" file)
(error "%s" status))
(push file cus-test-libs-loaded))
(error
(push (cons file alpha) cus-test-libs-errors)
(message "Error for %s: %s" file alpha)))))
(if more
(cus-test-get-lisp-files (equal more "all"))
(cus-test-get-autoload-deps)))
(message "Default directory: %s" default-directory)
(when skipped
(message "The following libraries were skipped:")
(cus-test-message skipped)))))
(defun cus-test-noloads ()
"Find custom options not loaded by `custom-load-symbol'.
Calling this function after `cus-test-load-libs' is not meaningful.
It is suitable for batch mode. E.g., invoke
src/emacs -batch -l admin/cus-test.el -f cus-test-noloads
in the Emacs source directory."
(interactive)
(let ((groups-loaded (cus-test-get-options "" 'cus-load))
cus-loaded groups-not-loaded)
(message "Running %s" 'cus-test-load-custom-loads)
(cus-test-load-custom-loads)
(setq cus-loaded (cus-test-get-options ""))
(message "Running %s" 'cus-test-load-libs)
(cus-test-load-libs "all")
(setq cus-test-vars-not-cus-loaded (cus-test-get-options "")
groups-not-loaded (cus-test-get-options "" t))
(dolist (o cus-loaded)
(setq cus-test-vars-not-cus-loaded
(delete o cus-test-vars-not-cus-loaded)))
(if (not cus-test-vars-not-cus-loaded)
(message "No options not loaded by custom-load-symbol found")
(message "The following options were not loaded by custom-load-symbol:")
(cus-test-message
(sort cus-test-vars-not-cus-loaded #'string<)))
(dolist (o groups-loaded)
(setq groups-not-loaded (delete o groups-not-loaded)))
(if (not groups-not-loaded)
(message "No groups not in cus-load.el found")
(message "The following groups are not in cus-load.el:")
(cus-test-message (sort groups-not-loaded #'string<)))))
(provide 'cus-test)
;;; cus-test.el ends here