admin/cus-test.el

   1 ;;; cus-test.el --- tests for custom types and load problems
   2
   3 ;; Copyright (C) 1998, 2000, 2002-2013 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          (let* ((type (custom-variable-type symbol))
 191                 (conv (widget-convert type))
 192                 (get (or (get symbol 'custom-get) 'default-value))
 193                 values
 194                 mismatch)
 195            (when (default-boundp symbol)
 196              (push (funcall get symbol) values)
 197              (push (eval (car (get symbol 'standard-value))) values))
 198            (if (boundp symbol)
 199                (push (symbol-value symbol) values))
 200            ;; That does not work.
 201            ;; (push (widget-get conv :value) values)
 202
 203            ;; Check the values
 204            (mapc (lambda (value)
 205                    (unless (widget-apply conv :match value)
 206                      (setq mismatch 'mismatch)))
 207                  values)
 208
 209            ;; Store symbols with a custom-get property.
 210            (when (get symbol 'custom-get)
 211              (add-to-list 'cus-test-vars-with-custom-get symbol))
 212
 213            ;; Changed outside the customize buffer?
 214            ;; This routine is not very much tested.
 215            (let ((c-value
 216                   (or (get symbol 'customized-value)
 217                       (get symbol 'saved-value)
 218                       (get symbol 'standard-value))))
 219              (and (consp c-value)
 220                   (boundp symbol)
 221                   (not (equal (eval (car c-value)) (symbol-value symbol)))
 222                   (add-to-list 'cus-test-vars-with-changed-state symbol)))
 223
 224            (if mismatch
 225                (push symbol cus-test-errors)))
 226
 227        (error
 228         (push symbol cus-test-errors)
 229         (message "Error for %s: %s" symbol alpha))))
 230    (cus-test-get-options regexp))
 231   (message "%s options tested"
 232            (length cus-test-tested-variables))
 233   (cus-test-errors-display))
 234
 235 (defun cus-test-cus-load-groups (&optional cus-load)
 236   "Return a list of current custom groups.
 237 If CUS-LOAD is non-nil, include groups from cus-load.el."
 238   (append (mapcar 'cdr custom-current-group-alist)
 239           (if cus-load
 240               (with-temp-buffer
 241                 (insert-file-contents (locate-library "cus-load.el"))
 242                 (search-forward "(put '")
 243                 (beginning-of-line)
 244                 (let (res)
 245                   (while (and (looking-at "^(put '\\(\\S-+\\)")
 246                               (zerop (forward-line 1)))
 247                     (push (intern (match-string 1)) res))
 248                   res)))))
 249
 250 (defun cus-test-get-options (regexp &optional group)
 251   "Return a list of custom options matching REGEXP.
 252 If GROUP is non-nil, return groups rather than options.
 253 If GROUP is `cus-load', include groups listed in cus-loads as well as
 254 currently defined groups."
 255   (let ((groups (if group (cus-test-cus-load-groups (eq group 'cus-load))))
 256         found)
 257     (mapatoms
 258      (lambda (symbol)
 259        (and
 260         (if group
 261             (memq symbol groups)
 262           (or
 263            ;; (user-variable-p symbol)
 264            (get symbol 'standard-value)
 265            ;; (get symbol 'saved-value)
 266            (get symbol 'custom-type)))
 267         (string-match regexp (symbol-name symbol))
 268         (not (member symbol cus-test-skip-list))
 269         (push symbol found))))
 270     found))
 271
 272 (defun cus-test-errors-display ()
 273   "Report about the errors found by cus-test."
 274   (with-output-to-temp-buffer "*cus-test-errors*"
 275     (set-buffer standard-output)
 276     (insert (format "Cus Test tested %s variables.\
 277   See `cus-test-tested-variables'.\n\n"
 278                     (length cus-test-tested-variables)))
 279     (if (not cus-test-errors)
 280         (insert "No errors found by cus-test.")
 281       (insert "The following variables seem to have problems:\n\n")
 282       (dolist (e cus-test-errors)
 283         (insert (symbol-name e) "\n")))))
 284
 285 (defun cus-test-load-custom-loads ()
 286   "Call `custom-load-symbol' on all atoms."
 287   (interactive)
 288   (if noninteractive (let (noninteractive) (require 'dunnet)))
 289   (mapatoms 'custom-load-symbol)
 290   (run-hooks 'cus-test-after-load-libs-hook))
 291
 292 (defmacro cus-test-load-1 (&rest body)
 293   `(progn
 294      (setq cus-test-libs-errors nil
 295            cus-test-libs-loaded nil)
 296      ,@body
 297      (message "%s libraries loaded successfully"
 298               (length cus-test-libs-loaded))
 299      (if (not cus-test-libs-errors)
 300          (message "No load problems encountered")
 301        (message "The following load problems appeared:")
 302        (cus-test-message cus-test-libs-errors))
 303      (run-hooks 'cus-test-after-load-libs-hook)))
 304
 305 ;; This is just cus-test-libs, but loading in the current Emacs process.
 306 (defun cus-test-load-libs (&optional more)
 307   "Load the libraries with autoloads.
 308 Don't load libraries in `cus-test-libs-noloads'.
 309 If optional argument MORE is \"defcustom\", load all files with defcustoms.
 310 If it is \"all\", load all Lisp files."
 311   (interactive)
 312   (cus-test-load-1
 313    (let ((lispdir (file-name-directory (locate-library "loaddefs"))))
 314      (mapc
 315       (lambda (file)
 316         (condition-case alpha
 317             (unless (member file cus-test-libs-noloads)
 318               (load (file-name-sans-extension (expand-file-name file lispdir)))
 319               (push file cus-test-libs-loaded))
 320           (error
 321            (push (cons file alpha) cus-test-libs-errors)
 322            (message "Error for %s: %s" file alpha))))
 323       (if more
 324           (cus-test-get-lisp-files (equal more "all"))
 325         (cus-test-get-autoload-deps))))))
 326
 327 (defun cus-test-get-autoload-deps ()
 328   "Return the list of files with autoloads."
 329   (with-temp-buffer
 330     (insert-file-contents (locate-library "loaddefs"))
 331     (let (files)
 332       (while (search-forward "\n;;; Generated autoloads from " nil t)
 333         (push (buffer-substring (match-end 0) (line-end-position)) files))
 334       files)))
 335
 336 (defun cus-test-get-lisp-files (&optional all)
 337   "Return list of all Lisp files with defcustoms.
 338 Optional argument ALL non-nil means list all (non-obsolete) Lisp files."
 339   (let ((default-directory (expand-file-name "lisp/" source-directory))
 340         (msg "Finding files..."))
 341     (message "%s" msg)
 342     (prog1
 343         ;; Hack to remove leading "./".
 344         (mapcar (lambda (e) (substring e 2))
 345                 (apply 'process-lines find-program
 346                        "-name" "obsolete" "-prune" "-o"
 347                        "-name" "[^.]*.el" ; ignore .dir-locals.el
 348                        (if all
 349                            '("-print")
 350                          (list "-exec" grep-program
 351                                "-l" "^[ \t]*(defcustom" "{}" "+"))))
 352       (message "%sdone" msg))))
 353
 354 (defun cus-test-message (list)
 355   "Print the members of LIST line by line."
 356   (dolist (m list) (message "%s" m)))
 357
 358 \f
 359 ;;; The routines for batch mode:
 360
 361 (defun cus-test-opts (&optional all)
 362   "Test custom options.
 363 This function is suitable for batch mode.  E.g., invoke
 364
 365   src/emacs -batch -l admin/cus-test.el -f cus-test-opts
 366
 367 in the Emacs source directory.
 368 Normally only tests options belonging to files in loaddefs.el.
 369 If optional argument ALL is non-nil, test all files with defcustoms."
 370   (interactive)
 371   (and noninteractive
 372        command-line-args-left
 373        (setq all (pop command-line-args-left)))
 374   (message "Running %s" 'cus-test-load-libs)
 375   (cus-test-load-libs (if all "defcustom"))
 376   (message "Running %s" 'cus-test-load-custom-loads)
 377   (cus-test-load-custom-loads)
 378   (message "Running %s" 'cus-test-apropos)
 379   (cus-test-apropos "")
 380   (if (not cus-test-errors)
 381       (message "No problems found")
 382     (message "The following options might have problems:")
 383     (cus-test-message cus-test-errors)))
 384
 385 (defun cus-test-deps ()
 386   "Run a verbose version of `custom-load-symbol' on all atoms.
 387 This function is suitable for batch mode.  E.g., invoke
 388
 389   src/emacs -batch -l admin/cus-test.el -f cus-test-deps
 390
 391 in the Emacs source directory."
 392   (interactive)
 393   (setq cus-test-deps-errors nil)
 394   (setq cus-test-deps-required nil)
 395   (setq cus-test-deps-loaded nil)
 396   (mapatoms
 397    ;; This code is mainly from `custom-load-symbol'.
 398    (lambda (symbol)
 399      (let ((custom-load-recursion t))
 400        (dolist (load (get symbol 'custom-loads))
 401          (cond
 402           ((symbolp load)
 403            ;; (condition-case nil (require load) (error nil))
 404            (condition-case alpha
 405                (unless (or (featurep load)
 406                            (and noninteractive (eq load 'dunnet)))
 407                  (require load)
 408                  (push (list symbol load) cus-test-deps-required))
 409              (error
 410               (push (list symbol load alpha) cus-test-deps-errors)
 411               (message "Require problem: %s %s %s" symbol load alpha))))
 412           ((equal load "loaddefs")
 413            (push
 414             (message "Symbol %s has loaddefs as custom dependency" symbol)
 415             cus-test-deps-errors))
 416           ;; This is subsumed by the test below, but it's much
 417           ;; faster.
 418           ((assoc load load-history))
 419           ;; This was just
 420           ;; (assoc (locate-library load) load-history)
 421           ;; but has been optimized not to load locate-library
 422           ;; if not necessary.
 423           ((let ((regexp (concat "\\(\\`\\|/\\)" (regexp-quote load)
 424                                  "\\(\\'\\|\\.\\)"))
 425                  (found nil))
 426              (dolist (loaded load-history)
 427                (and (stringp (car loaded))
 428                     (string-match regexp (car loaded))
 429                     (setq found t)))
 430              found))
 431           ;; Without this, we would load cus-edit recursively.
 432           ;; We are still loading it when we call this,
 433           ;; and it is not in load-history yet.
 434           ((equal load "cus-edit"))
 435           ;; This would ignore load problems with files in
 436           ;; lisp/term/
 437           ;; ((locate-library (concat term-file-prefix load)))
 438           (t
 439            ;; (condition-case nil (load load) (error nil))
 440            (condition-case alpha
 441                (progn
 442                  (load load)
 443                  (push (list symbol load) cus-test-deps-loaded))
 444              (error
 445               (push (list symbol load alpha) cus-test-deps-errors)
 446               (message "Load Problem: %s %s %s" symbol load alpha))))
 447           )))))
 448   (message "%s features required"
 449            (length cus-test-deps-required))
 450   (message "%s files loaded"
 451            (length cus-test-deps-loaded))
 452   (if (not cus-test-deps-errors)
 453       (message "No load problems encountered")
 454     (message "The following load problems appeared:")
 455     (cus-test-message cus-test-deps-errors))
 456   (run-hooks 'cus-test-after-load-libs-hook))
 457
 458 (defun cus-test-libs (&optional more)
 459   "Load the libraries with autoloads in separate processes.
 460 This function is useful to detect load problems of libraries.
 461 It is suitable for batch mode.  E.g., invoke
 462
 463   ./src/emacs -batch -l admin/cus-test.el -f cus-test-libs
 464
 465 in the Emacs source directory.
 466
 467 If optional argument MORE is \"defcustom\", load all files with defcustoms.
 468 If it is \"all\", load all Lisp files."
 469   (interactive)
 470   (and noninteractive
 471        command-line-args-left
 472        (setq more (pop command-line-args-left)))
 473   (cus-test-load-1
 474    (let* ((default-directory source-directory)
 475           (emacs (expand-file-name "src/emacs"))
 476           skipped)
 477      (or (file-executable-p emacs)
 478          (error "No such executable `%s'" emacs))
 479      (mapc
 480       (lambda (file)
 481         (if (member file cus-test-libs-noloads)
 482             (push file skipped)
 483           (condition-case alpha
 484               (let* ((fn (expand-file-name file "lisp/"))
 485                      (elc (concat fn "c"))
 486                      status)
 487                 (if (file-readable-p elc) ; load compiled if present (faster)
 488                     (setq fn elc)
 489                   (or (file-readable-p fn)
 490                       (error "Library %s not found" file)))
 491                 (if (equal 0 (setq status (call-process emacs nil nil nil
 492                                                         "-batch" "-l" fn)))
 493                     (message "%s" file)
 494                   (error "%s" status))
 495                 (push file cus-test-libs-loaded))
 496             (error
 497              (push (cons file alpha) cus-test-libs-errors)
 498              (message "Error for %s: %s" file alpha)))))
 499       (if more
 500           (cus-test-get-lisp-files (equal more "all"))
 501         (cus-test-get-autoload-deps)))
 502      (message "Default directory: %s" default-directory)
 503      (when skipped
 504        (message "The following libraries were skipped:")
 505        (cus-test-message skipped)))))
 506
 507 (defun cus-test-noloads ()
 508   "Find custom options not loaded by `custom-load-symbol'.
 509 Calling this function after `cus-test-load-libs' is not meaningful.
 510 It is suitable for batch mode.  E.g., invoke
 511
 512   src/emacs -batch -l admin/cus-test.el -f cus-test-noloads
 513
 514 in the Emacs source directory."
 515   (interactive)
 516   (let ((groups-loaded (cus-test-get-options "" 'cus-load))
 517         cus-loaded groups-not-loaded)
 518
 519     (message "Running %s" 'cus-test-load-custom-loads)
 520     (cus-test-load-custom-loads)
 521     (setq cus-loaded (cus-test-get-options ""))
 522
 523     (message "Running %s" 'cus-test-load-libs)
 524     (cus-test-load-libs "all")
 525     (setq cus-test-vars-not-cus-loaded (cus-test-get-options "")
 526           groups-not-loaded (cus-test-get-options "" t))
 527
 528     (dolist (o cus-loaded)
 529       (setq cus-test-vars-not-cus-loaded
 530             (delete o cus-test-vars-not-cus-loaded)))
 531
 532     (if (not cus-test-vars-not-cus-loaded)
 533         (message "No options not loaded by custom-load-symbol found")
 534       (message "The following options were not loaded by custom-load-symbol:")
 535       (cus-test-message
 536        (sort cus-test-vars-not-cus-loaded 'string<)))
 537
 538     (dolist (o groups-loaded)
 539       (setq groups-not-loaded (delete o groups-not-loaded)))
 540
 541     (if (not groups-not-loaded)
 542         (message "No groups not in cus-load.el found")
 543       (message "The following groups are not in cus-load.el:")
 544       (cus-test-message (sort groups-not-loaded 'string<)))))
 545
 546 (provide 'cus-test)
 547
 548 ;;; cus-test.el ends here