admin/cus-test.el

   1 ;;; cus-test.el --- tests for custom types and load problems
   2
   3 ;; Copyright (C) 1998, 2000, 2002-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Markus Rost <markus.rost@mathematik.uni-regensburg.de>
   6 ;; Maintainer: Markus Rost <rost@math.ohio-state.edu>
   7 ;; Created: 13 Sep 1998
   8 ;; Keywords: maint
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This file provides simple tests to detect custom options with
  28 ;; incorrect customization types and load problems for custom and
  29 ;; autoload dependencies.
  30 ;;
  31 ;; The basic tests can be run in batch mode.  Invoke them with
  32 ;;
  33 ;;   src/emacs -batch -l admin/cus-test.el -f cus-test-opts [all]
  34 ;;
  35 ;;   src/emacs -batch -l admin/cus-test.el -f cus-test-deps
  36 ;;
  37 ;;   src/emacs -batch -l admin/cus-test.el -f cus-test-libs [all]
  38 ;;
  39 ;;   src/emacs -batch -l admin/cus-test.el -f cus-test-noloads
  40 ;;
  41 ;; in the emacs source directory.
  42 ;;
  43 ;; For interactive use: Load this file.  Then
  44 ;;
  45 ;;    M-x cus-test-apropos REGEXP RET
  46 ;;
  47 ;; checks the options matching REGEXP.  In particular
  48 ;;
  49 ;;    M-x cus-test-apropos RET
  50 ;;
  51 ;; checks all options.  The detected options are stored in the
  52 ;; variable `cus-test-errors'.
  53 ;;
  54 ;; Only those options are checked which have been already loaded.
  55 ;; Therefore `cus-test-apropos' is more efficient after loading many
  56 ;; libraries.
  57 ;;
  58 ;;    M-x cus-test-load-custom-loads
  59 ;;
  60 ;; loads all (!) custom dependencies and
  61 ;;
  62 ;;    M-x cus-test-load-libs
  63 ;;
  64 ;; loads all (!) libraries with autoloads.
  65 ;;
  66 ;; Options with a custom-get property, usually defined by a :get
  67 ;; declaration, are stored in the variable
  68 ;;
  69 ;; `cus-test-vars-with-custom-get'
  70 ;;
  71 ;; Options with a state of 'changed ("changed outside the customize
  72 ;; buffer") are stored in the variable
  73 ;;
  74 ;; `cus-test-vars-with-changed-state'
  75 ;;
  76 ;; These lists are prepared just in case one wants to investigate
  77 ;; those options further.
  78 ;;
  79 ;; The command `cus-test-opts' tests many (all?) custom options.
  80 ;;
  81 ;; The command `cus-test-deps' is like `cus-test-load-custom-loads'
  82 ;; but reports about load errors.
  83 ;;
  84 ;; The command `cus-test-libs' runs for all libraries with autoloads
  85 ;; separate emacs processes of the form "emacs -batch -l LIB".
  86 ;;
  87 ;; The command `cus-test-noloads' returns a list of variables which
  88 ;; are somewhere declared as custom options, but not loaded by
  89 ;; `custom-load-symbol'.
  90
  91 \f
  92 ;;; Code:
  93
  94 ;;; Workarounds.  For a smooth run and to avoid some side effects.
  95
  96 (defvar cus-test-after-load-libs-hook nil
  97   "Used to switch off undesired side effects of loading libraries.")
  98
  99 (defvar cus-test-skip-list nil
 100   "List of variables to disregard by `cus-test-apropos'.")
 101
 102 (defvar cus-test-libs-noloads
 103   ;; Loading dunnet in batch mode leads to a Dead end.
 104   ;; blessmail writes a file.
 105   ;; characters cannot be loaded twice ("Category `a' is already defined").
 106   '("play/dunnet.el" "emulation/edt-mapper.el"
 107     "loadup.el" "mail/blessmail.el" "international/characters.el"
 108     "cedet/ede/loaddefs.el" "cedet/semantic/loaddefs.el"
 109     "net/tramp-loaddefs.el")
 110   "List of files not to load by `cus-test-load-libs'.
 111 Names should be as they appear in loaddefs.el.")
 112
 113 ;; This avoids a hang of `cus-test-apropos' in 21.2.
 114 ;; (add-to-list 'cus-test-skip-list 'sh-alias-alist)
 115
 116 (or noninteractive
 117     ;; Never Viperize.
 118     (setq viper-mode nil))
 119
 120 ;; Don't create a file `save-place-file'.
 121 (eval-after-load "saveplace"
 122   '(remove-hook 'kill-emacs-hook 'save-place-kill-emacs-hook))
 123
 124 ;; Don't create a file `abbrev-file-name'.
 125 (setq save-abbrevs nil)
 126
 127 ;; Avoid compile logs from adviced functions.
 128 (eval-after-load "bytecomp"
 129   '(setq ad-default-compilation-action 'never))
 130
 131 \f
 132 ;;; Main code:
 133
 134 ;; We want to log all messages.
 135 (setq message-log-max t)
 136
 137 (require 'cus-edit)
 138 (require 'cus-load)
 139
 140 (defvar cus-test-errors nil
 141   "List of problematic variables found by `cus-test-apropos'.")
 142
 143 (defvar cus-test-tested-variables nil
 144   "List of options tested by last call of `cus-test-apropos'.")
 145
 146 ;; I haven't understood this :get stuff.  The symbols with a
 147 ;; custom-get property are stored here.
 148 (defvar cus-test-vars-with-custom-get nil
 149   "Set by `cus-test-apropos' to a list of options with :get property.")
 150
 151 (defvar cus-test-vars-with-changed-state nil
 152   "Set by `cus-test-apropos' to a list of options with state 'changed.")
 153
 154 (defvar cus-test-deps-errors nil
 155   "List of require/load problems found by `cus-test-deps'.")
 156
 157 (defvar cus-test-deps-required nil
 158   "List of dependencies required by `cus-test-deps'.
 159 Only unloaded features will be require'd.")
 160
 161 (defvar cus-test-deps-loaded nil
 162   "List of dependencies loaded by `cus-test-deps'.")
 163
 164 (defvar cus-test-libs-errors nil
 165   "List of load problems found by `cus-test-load-libs' or `cus-test-libs'.")
 166
 167 (defvar cus-test-libs-loaded nil
 168   "List of files loaded by `cus-test-load-libs' or `cus-test-libs'.")
 169
 170 (defvar cus-test-vars-not-cus-loaded nil
 171   "A list of options not loaded by `custom-load-symbol'.
 172 Set by `cus-test-noloads'.")
 173
 174 ;; (defvar cus-test-vars-cus-loaded nil
 175 ;;   "A list of options loaded by `custom-load-symbol'.")
 176
 177 (defun cus-test-apropos (regexp)
 178   "Check the options matching REGEXP.
 179 The detected problematic options are stored in `cus-test-errors'."
 180   (interactive "sVariable regexp: ")
 181   (setq cus-test-errors nil)
 182   (setq cus-test-tested-variables nil)
 183   (mapc
 184    (lambda (symbol)
 185      (push symbol cus-test-tested-variables)
 186      ;; Be verbose in case we hang.
 187      (message "Cus Test running...%s %s"
 188               (length cus-test-tested-variables) symbol)
 189      (condition-case alpha
 190          ;; FIXME This defaults to 'sexp if no type was specified.
 191          ;; Always report such instances as a type mismatch.
 192          ;; Currently abusing cusver-scan to do that.
 193          (let* ((type (custom-variable-type symbol))
 194                 (conv (widget-convert type))
 195                 (get (or (get symbol 'custom-get) 'default-value))
 196                 values
 197                 mismatch)
 198            (when (default-boundp symbol)
 199              (push (funcall get symbol) values)
 200              (push (eval (car (get symbol 'standard-value))) values))
 201            (if (boundp symbol)
 202                (push (symbol-value symbol) values))
 203            ;; That does not work.
 204            ;; (push (widget-get conv :value) values)
 205
 206            ;; Check the values
 207            (mapc (lambda (value)
 208                    ;; TODO for booleans, check for values that can be
 209                    ;; evaluated and are not t or nil.  Usually a bug.
 210                    (unless (widget-apply conv :match value)
 211                      (setq mismatch 'mismatch)))
 212                  values)
 213
 214            ;; Store symbols with a custom-get property.
 215            (when (get symbol 'custom-get)
 216              (add-to-list 'cus-test-vars-with-custom-get symbol))
 217
 218            ;; Changed outside the customize buffer?
 219            ;; This routine is not very much tested.
 220            (let ((c-value
 221                   (or (get symbol 'customized-value)
 222                       (get symbol 'saved-value)
 223                       (get symbol 'standard-value))))
 224              (and (consp c-value)
 225                   (boundp symbol)
 226                   (not (equal (eval (car c-value)) (symbol-value symbol)))
 227                   (add-to-list 'cus-test-vars-with-changed-state symbol)))
 228
 229            (if mismatch
 230                (push symbol cus-test-errors)))
 231
 232        (error
 233         (push symbol cus-test-errors)
 234         (message "Error for %s: %s" symbol alpha))))
 235    (cus-test-get-options regexp))
 236   (message "%s options tested"
 237            (length cus-test-tested-variables))
 238   (cus-test-errors-display))
 239
 240 (defun cus-test-cus-load-groups (&optional cus-load)
 241   "Return a list of current custom groups.
 242 If CUS-LOAD is non-nil, include groups from cus-load.el."
 243   (append (mapcar 'cdr custom-current-group-alist)
 244           (if cus-load
 245               (with-temp-buffer
 246                 (insert-file-contents (locate-library "cus-load.el"))
 247                 (search-forward "(put '")
 248                 (beginning-of-line)
 249                 (let (res)
 250                   (while (and (looking-at "^(put '\\(\\S-+\\)")
 251                               (zerop (forward-line 1)))
 252                     (push (intern (match-string 1)) res))
 253                   res)))))
 254
 255 (defun cus-test-get-options (regexp &optional group)
 256   "Return a list of custom options matching REGEXP.
 257 If GROUP is non-nil, return groups rather than options.
 258 If GROUP is `cus-load', include groups listed in cus-loads as well as
 259 currently defined groups."
 260   (let ((groups (if group (cus-test-cus-load-groups (eq group 'cus-load))))
 261         found)
 262     (mapatoms
 263      (lambda (symbol)
 264        (and
 265         (if group
 266             (memq symbol groups)
 267           (or
 268            ;; (user-variable-p symbol)
 269            (get symbol 'standard-value)
 270            ;; (get symbol 'saved-value)
 271            (get symbol 'custom-type)))
 272         (string-match regexp (symbol-name symbol))
 273         (not (member symbol cus-test-skip-list))
 274         (push symbol found))))
 275     found))
 276
 277 (defun cus-test-errors-display ()
 278   "Report about the errors found by cus-test."
 279   (with-output-to-temp-buffer "*cus-test-errors*"
 280     (set-buffer standard-output)
 281     (insert (format "Cus Test tested %s variables.\
 282   See `cus-test-tested-variables'.\n\n"
 283                     (length cus-test-tested-variables)))
 284     (if (not cus-test-errors)
 285         (insert "No errors found by cus-test.")
 286       (insert "The following variables seem to have problems:\n\n")
 287       (dolist (e cus-test-errors)
 288         (insert (symbol-name e) "\n")))))
 289
 290 (defun cus-test-load-custom-loads ()
 291   "Call `custom-load-symbol' on all atoms."
 292   (interactive)
 293   (if noninteractive (let (noninteractive) (require 'dunnet)))
 294   (mapatoms 'custom-load-symbol)
 295   (run-hooks 'cus-test-after-load-libs-hook))
 296
 297 (defmacro cus-test-load-1 (&rest body)
 298   `(progn
 299      (setq cus-test-libs-errors nil
 300            cus-test-libs-loaded nil)
 301      ,@body
 302      (message "%s libraries loaded successfully"
 303               (length cus-test-libs-loaded))
 304      (if (not cus-test-libs-errors)
 305          (message "No load problems encountered")
 306        (message "The following load problems appeared:")
 307        (cus-test-message cus-test-libs-errors))
 308      (run-hooks 'cus-test-after-load-libs-hook)))
 309
 310 ;; This is just cus-test-libs, but loading in the current Emacs process.
 311 (defun cus-test-load-libs (&optional more)
 312   "Load the libraries with autoloads.
 313 Don't load libraries in `cus-test-libs-noloads'.
 314 If optional argument MORE is \"defcustom\", load all files with defcustoms.
 315 If it is \"all\", load all Lisp files."
 316   (interactive)
 317   (cus-test-load-1
 318    (let ((lispdir (file-name-directory (locate-library "loaddefs"))))
 319      (mapc
 320       (lambda (file)
 321         (condition-case alpha
 322             (unless (member file cus-test-libs-noloads)
 323               (load (file-name-sans-extension (expand-file-name file lispdir)))
 324               (push file cus-test-libs-loaded))
 325           (error
 326            (push (cons file alpha) cus-test-libs-errors)
 327            (message "Error for %s: %s" file alpha))))
 328       (if more
 329           (cus-test-get-lisp-files (equal more "all"))
 330         (cus-test-get-autoload-deps))))))
 331
 332 (defun cus-test-get-autoload-deps ()
 333   "Return the list of files with autoloads."
 334   (with-temp-buffer
 335     (insert-file-contents (locate-library "loaddefs"))
 336     (let (files)
 337       (while (search-forward "\n;;; Generated autoloads from " nil t)
 338         (push (buffer-substring (match-end 0) (line-end-position)) files))
 339       files)))
 340
 341 (defun cus-test-get-lisp-files (&optional all)
 342   "Return list of all Lisp files with defcustoms.
 343 Optional argument ALL non-nil means list all (non-obsolete) Lisp files."
 344   (let ((default-directory (expand-file-name "lisp/" source-directory))
 345         (msg "Finding files..."))
 346     (message "%s" msg)
 347     (prog1
 348         ;; Hack to remove leading "./".
 349         (mapcar (lambda (e) (substring e 2))
 350                 (apply 'process-lines find-program
 351                        "-name" "obsolete" "-prune" "-o"
 352                        "-name" "[^.]*.el" ; ignore .dir-locals.el
 353                        (if all
 354                            '("-print")
 355                          (list "-exec" grep-program
 356                                "-l" "^[ \t]*(defcustom" "{}" "+"))))
 357       (message "%sdone" msg))))
 358
 359 (defun cus-test-message (list)
 360   "Print the members of LIST line by line."
 361   (dolist (m list) (message "%s" m)))
 362
 363 \f
 364 ;;; The routines for batch mode:
 365
 366 (defun cus-test-opts (&optional all)
 367   "Test custom options.
 368 This function is suitable for batch mode.  E.g., invoke
 369
 370   src/emacs -batch -l admin/cus-test.el -f cus-test-opts
 371
 372 in the Emacs source directory.
 373 Normally only tests options belonging to files in loaddefs.el.
 374 If optional argument ALL is non-nil, test all files with defcustoms."
 375   (interactive)
 376   (and noninteractive
 377        command-line-args-left
 378        (setq all (pop command-line-args-left)))
 379   (message "Running %s" 'cus-test-load-libs)
 380   (cus-test-load-libs (if all "defcustom"))
 381   (message "Running %s" 'cus-test-load-custom-loads)
 382   (cus-test-load-custom-loads)
 383   (message "Running %s" 'cus-test-apropos)
 384   (cus-test-apropos "")
 385   (if (not cus-test-errors)
 386       (message "No problems found")
 387     (message "The following options might have problems:")
 388     (cus-test-message cus-test-errors)))
 389
 390 (defun cus-test-deps ()
 391   "Run a verbose version of `custom-load-symbol' on all atoms.
 392 This function is suitable for batch mode.  E.g., invoke
 393
 394   src/emacs -batch -l admin/cus-test.el -f cus-test-deps
 395
 396 in the Emacs source directory."
 397   (interactive)
 398   (setq cus-test-deps-errors nil)
 399   (setq cus-test-deps-required nil)
 400   (setq cus-test-deps-loaded nil)
 401   (mapatoms
 402    ;; This code is mainly from `custom-load-symbol'.
 403    (lambda (symbol)
 404      (let ((custom-load-recursion t))
 405        (dolist (load (get symbol 'custom-loads))
 406          (cond
 407           ((symbolp load)
 408            ;; (condition-case nil (require load) (error nil))
 409            (condition-case alpha
 410                (unless (or (featurep load)
 411                            (and noninteractive (eq load 'dunnet)))
 412                  (require load)
 413                  (push (list symbol load) cus-test-deps-required))
 414              (error
 415               (push (list symbol load alpha) cus-test-deps-errors)
 416               (message "Require problem: %s %s %s" symbol load alpha))))
 417           ((equal load "loaddefs")
 418            (push
 419             (message "Symbol %s has loaddefs as custom dependency" symbol)
 420             cus-test-deps-errors))
 421           ;; This is subsumed by the test below, but it's much
 422           ;; faster.
 423           ((assoc load load-history))
 424           ;; This was just
 425           ;; (assoc (locate-library load) load-history)
 426           ;; but has been optimized not to load locate-library
 427           ;; if not necessary.
 428           ((let ((regexp (concat "\\(\\`\\|/\\)" (regexp-quote load)
 429                                  "\\(\\'\\|\\.\\)"))
 430                  (found nil))
 431              (dolist (loaded load-history)
 432                (and (stringp (car loaded))
 433                     (string-match regexp (car loaded))
 434                     (setq found t)))
 435              found))
 436           ;; Without this, we would load cus-edit recursively.
 437           ;; We are still loading it when we call this,
 438           ;; and it is not in load-history yet.
 439           ((equal load "cus-edit"))
 440           ;; This would ignore load problems with files in
 441           ;; lisp/term/
 442           ;; ((locate-library (concat term-file-prefix load)))
 443           (t
 444            ;; (condition-case nil (load load) (error nil))
 445            (condition-case alpha
 446                (progn
 447                  (load load)
 448                  (push (list symbol load) cus-test-deps-loaded))
 449              (error
 450               (push (list symbol load alpha) cus-test-deps-errors)
 451               (message "Load Problem: %s %s %s" symbol load alpha))))
 452           )))))
 453   (message "%s features required"
 454            (length cus-test-deps-required))
 455   (message "%s files loaded"
 456            (length cus-test-deps-loaded))
 457   (if (not cus-test-deps-errors)
 458       (message "No load problems encountered")
 459     (message "The following load problems appeared:")
 460     (cus-test-message cus-test-deps-errors))
 461   (run-hooks 'cus-test-after-load-libs-hook))
 462
 463 (defun cus-test-libs (&optional more)
 464   "Load the libraries with autoloads in separate processes.
 465 This function is useful to detect load problems of libraries.
 466 It is suitable for batch mode.  E.g., invoke
 467
 468   ./src/emacs -batch -l admin/cus-test.el -f cus-test-libs
 469
 470 in the Emacs source directory.
 471
 472 If optional argument MORE is \"defcustom\", load all files with defcustoms.
 473 If it is \"all\", load all Lisp files."
 474   (interactive)
 475   (and noninteractive
 476        command-line-args-left
 477        (setq more (pop command-line-args-left)))
 478   (cus-test-load-1
 479    (let* ((default-directory source-directory)
 480           (emacs (expand-file-name "src/emacs"))
 481           skipped)
 482      (or (file-executable-p emacs)
 483          (error "No such executable `%s'" emacs))
 484      (mapc
 485       (lambda (file)
 486         (if (member file cus-test-libs-noloads)
 487             (push file skipped)
 488           (condition-case alpha
 489               (let* ((fn (expand-file-name file "lisp/"))
 490                      (elc (concat fn "c"))
 491                      status)
 492                 (if (file-readable-p elc) ; load compiled if present (faster)
 493                     (setq fn elc)
 494                   (or (file-readable-p fn)
 495                       (error "Library %s not found" file)))
 496                 (if (equal 0 (setq status (call-process emacs nil nil nil
 497                                                         "-batch" "-l" fn)))
 498                     (message "%s" file)
 499                   (error "%s" status))
 500                 (push file cus-test-libs-loaded))
 501             (error
 502              (push (cons file alpha) cus-test-libs-errors)
 503              (message "Error for %s: %s" file alpha)))))
 504       (if more
 505           (cus-test-get-lisp-files (equal more "all"))
 506         (cus-test-get-autoload-deps)))
 507      (message "Default directory: %s" default-directory)
 508      (when skipped
 509        (message "The following libraries were skipped:")
 510        (cus-test-message skipped)))))
 511
 512 (defun cus-test-noloads ()
 513   "Find custom options not loaded by `custom-load-symbol'.
 514 Calling this function after `cus-test-load-libs' is not meaningful.
 515 It is suitable for batch mode.  E.g., invoke
 516
 517   src/emacs -batch -l admin/cus-test.el -f cus-test-noloads
 518
 519 in the Emacs source directory."
 520   (interactive)
 521   (let ((groups-loaded (cus-test-get-options "" 'cus-load))
 522         cus-loaded groups-not-loaded)
 523
 524     (message "Running %s" 'cus-test-load-custom-loads)
 525     (cus-test-load-custom-loads)
 526     (setq cus-loaded (cus-test-get-options ""))
 527
 528     (message "Running %s" 'cus-test-load-libs)
 529     (cus-test-load-libs "all")
 530     (setq cus-test-vars-not-cus-loaded (cus-test-get-options "")
 531           groups-not-loaded (cus-test-get-options "" t))
 532
 533     (dolist (o cus-loaded)
 534       (setq cus-test-vars-not-cus-loaded
 535             (delete o cus-test-vars-not-cus-loaded)))
 536
 537     (if (not cus-test-vars-not-cus-loaded)
 538         (message "No options not loaded by custom-load-symbol found")
 539       (message "The following options were not loaded by custom-load-symbol:")
 540       (cus-test-message
 541        (sort cus-test-vars-not-cus-loaded 'string<)))
 542
 543     (dolist (o groups-loaded)
 544       (setq groups-not-loaded (delete o groups-not-loaded)))
 545
 546     (if (not groups-not-loaded)
 547         (message "No groups not in cus-load.el found")
 548       (message "The following groups are not in cus-load.el:")
 549       (cus-test-message (sort groups-not-loaded 'string<)))))
 550
 551 (provide 'cus-test)
 552
 553 ;;; cus-test.el ends here