tests/automated/test-harness.el

   1 ;; test-harness.el --- Run Emacs Lisp test suites.
   2
   3 ;;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Martin Buchholz
   6 ;; Keywords: testing
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF.
  26
  27 ;;; Commentary:
  28
  29 ;;; A test suite harness for testing XEmacs.
  30 ;;; The actual tests are in other files in this directory.
  31 ;;; Basically you just create files of emacs-lisp, and use the
  32 ;;; Assert, Check-Error, and Check-Message functions to create tests.
  33 ;;; You run the tests using M-x test-emacs-test-file,
  34 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ...
  35 ;;; which is run for you by the `make check' target in the top-level Makefile.
  36
  37 (require 'bytecomp)
  38
  39 (defvar test-harness-verbose
  40   (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
  41   "*Non-nil means print messages describing progress of emacs-tester.")
  42
  43 (defvar test-harness-current-file nil)
  44
  45 (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'")
  46   "*Regexp which matches Emacs Lisp source files.")
  47
  48 ;;;###autoload
  49 (defun test-emacs-test-file (filename)
  50   "Test a file of Lisp code named FILENAME.
  51 The output file's name is made by appending `c' to the end of FILENAME."
  52   (interactive
  53    (let ((file buffer-file-name)
  54          (file-name nil)
  55          (file-dir nil))
  56      (and file
  57           (eq (cdr (assq 'major-mode (buffer-local-variables)))
  58               'emacs-lisp-mode)
  59           (setq file-name (file-name-nondirectory file)
  60                 file-dir (file-name-directory file)))
  61      (list (read-file-name "Test file: " file-dir nil nil file-name))))
  62   ;; Expand now so we get the current buffer's defaults
  63   (setq filename (expand-file-name filename))
  64
  65   ;; If we're testing a file that's in a buffer and is modified, offer
  66   ;; to save it first.
  67   (or noninteractive
  68       (let ((b (get-file-buffer (expand-file-name filename))))
  69         (if (and b (buffer-modified-p b)
  70                  (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
  71             (save-excursion (set-buffer b) (save-buffer)))))
  72
  73   (if (or noninteractive test-harness-verbose)
  74       (message "Testing %s..." filename))
  75   (let ((test-harness-current-file filename)
  76         input-buffer)
  77     (save-excursion
  78       (setq input-buffer (get-buffer-create " *Test Input*"))
  79       (set-buffer input-buffer)
  80       (erase-buffer)
  81       (insert-file-contents filename)
  82       ;; Run hooks including the uncompression hook.
  83       ;; If they change the file name, then change it for the output also.
  84       (let ((buffer-file-name filename)
  85             (default-major-mode 'emacs-lisp-mode)
  86             (enable-local-eval nil))
  87         (normal-mode)
  88         (setq filename buffer-file-name)))
  89     (test-harness-from-buffer input-buffer filename)
  90     (kill-buffer input-buffer)
  91     ))
  92
  93 (defun test-harness-read-from-buffer (buffer)
  94   "Read forms from BUFFER, and turn it into a lambda test form."
  95   (let ((body nil))
  96     (goto-char (point-min) buffer)
  97     (condition-case error-info
  98         (while t
  99           (setq body (cons (read buffer) body)))
 100       (end-of-file nil)
 101       (error
 102        (princ "Unexpected error %S reading forms from buffer\n" error-info)))
 103     `(lambda ()
 104        (defvar passes)
 105        (defvar assertion-failures)
 106        (defvar no-error-failures)
 107        (defvar wrong-error-failures)
 108        (defvar missing-message-failures)
 109        (defvar other-failures)
 110
 111        (defvar unexpected-test-suite-failure)
 112        (defvar trick-optimizer)
 113
 114        ,@(nreverse body))))
 115
 116 (defun test-harness-from-buffer (inbuffer filename)
 117   "Run tests in buffer INBUFFER, visiting FILENAME."
 118   (defvar trick-optimizer)
 119   (let ((passes 0)
 120         (assertion-failures 0)
 121         (no-error-failures 0)
 122         (wrong-error-failures 0)
 123         (missing-message-failures 0)
 124         (other-failures 0)
 125
 126         (trick-optimizer nil)
 127         (unexpected-test-suite-failure nil)
 128         (debug-on-error t))
 129     (with-output-to-temp-buffer "*Test-Log*"
 130
 131       (defmacro Assert (assertion)
 132         `(condition-case error-info
 133              (progn
 134                (assert ,assertion)
 135                (princ (format "PASS: %S" (quote ,assertion)))
 136                (terpri)
 137                (incf passes))
 138            (cl-assertion-failed
 139             (princ (format "FAIL: Assertion failed: %S\n" (quote ,assertion)))
 140             (incf assertion-failures))
 141            (t (princ (format "FAIL: %S ==> error: %S\n" (quote ,assertion) error-info))
 142               (incf other-failures)
 143               )))
 144
 145       (defmacro Check-Error (expected-error &rest body)
 146         (let ((quoted-body (if (= 1 (length body))
 147                                `(quote ,(car body)) `(quote (progn ,@body)))))
 148           `(condition-case error-info
 149                (progn
 150                  (setq trick-optimizer (progn ,@body))
 151                  (princ (format "FAIL: %S executed successfully, but expected error %S\n"
 152                                 ,quoted-body
 153                                 ',expected-error))
 154                  (incf no-error-failures))
 155              (,expected-error
 156               (princ (format "PASS: %S ==> error %S, as expected\n"
 157                              ,quoted-body ',expected-error))
 158               (incf passes))
 159              (error
 160               (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n"
 161                              ,quoted-body ',expected-error error-info))
 162               (incf wrong-error-failures)))))
 163
 164       (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body)
 165         (let ((quoted-body (if (= 1 (length body))
 166                                `(quote ,(car body)) `(quote (progn ,@body)))))
 167           `(condition-case error-info
 168                (progn
 169                  (setq trick-optimizer (progn ,@body))
 170                  (princ (format "FAIL: %S executed successfully, but expected error %S\n"
 171                                 ,quoted-body
 172                                 ',expected-error))
 173                  (incf no-error-failures))
 174              (,expected-error
 175               (let ((error-message (second error-info)))
 176                 (if (string-match ,expected-error-regexp error-message)
 177                     (progn
 178                       (princ (format "PASS: %S ==> error %S %S, as expected\n"
 179                                      ,quoted-body error-message ',expected-error))
 180                       (incf passes))
 181                   (princ (format "FAIL: %S ==> got error %S as expected, but error message %S did not match regexp %S\n"
 182                                  ,quoted-body ',expected-error error-message ,expected-error-regexp))
 183                   (incf wrong-error-failures))))
 184              (error
 185               (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n"
 186                              ,quoted-body ',expected-error error-info))
 187               (incf wrong-error-failures)))))
 188
 189
 190       (defmacro Check-Message (expected-message-regexp &rest body)
 191         (let ((quoted-body (if (= 1 (length body))
 192                                `(quote ,(car body)) `(quote (progn ,@body)))))
 193           `(let ((messages ""))
 194              (defadvice message (around collect activate)
 195                (defvar messages)
 196                (let ((msg-string (apply 'format (ad-get-args 0))))
 197                  (setq messages (concat messages msg-string))
 198                  msg-string))
 199              (condition-case error-info
 200                  (progn
 201                    (setq trick-optimizer (progn ,@body))
 202                    (if (string-match ,expected-message-regexp messages)
 203                        (progn
 204                          (princ (format "PASS: %S ==> value %S, message %S, matching %S, as expected\n"
 205                                         ,quoted-body trick-optimizer messages ',expected-message-regexp))
 206                          (incf passes))
 207                      (princ (format "FAIL: %S ==> value %S, message %S, NOT matching expected %S\n"
 208                                     ,quoted-body  trick-optimizer messages ',expected-message-regexp))
 209                      (incf missing-message-failures)))
 210                (error
 211                 (princ (format "FAIL: %S ==> unexpected error %S\n"
 212                                ,quoted-body error-info))
 213                 (incf other-failures)))
 214              (ad-unadvise 'message))))
 215
 216       (defmacro Ignore-Ebola (&rest body)
 217         `(let ((debug-issue-ebola-notices -42)) ,@body))
 218
 219       (defun Int-to-Marker (pos)
 220         (save-excursion
 221           (set-buffer standard-output)
 222           (save-excursion
 223             (goto-char pos)
 224             (point-marker))))
 225
 226       (princ "Testing Interpreted Lisp\n\n")
 227       (condition-case error-info
 228           (funcall (test-harness-read-from-buffer inbuffer))
 229         (error
 230          (setq unexpected-test-suite-failure t)
 231          (princ (format "Unexpected error %S while executing interpreted code\n"
 232                 error-info))
 233          (message "Unexpected error %S while executing interpreted code." error-info)
 234          (message "Test suite execution aborted." error-info)
 235          ))
 236       (princ "\nTesting Compiled Lisp\n\n")
 237       (let (code)
 238         (condition-case error-info
 239             (setq code (let ((byte-compile-warnings nil))
 240                          (byte-compile (test-harness-read-from-buffer inbuffer))))
 241           (error
 242            (princ (format "Unexpected error %S while byte-compiling code\n"
 243                           error-info))))
 244         (condition-case error-info
 245             (if code (funcall code))
 246           (error
 247            (princ (format "Unexpected error %S while executing byte-compiled code\n"
 248                           error-info))
 249            (message "Unexpected error %S while executing byte-compiled code." error-info)
 250            (message "Test suite execution aborted." error-info)
 251            )))
 252       (princ "\nSUMMARY:\n")
 253       (princ (format "\t%5d passes\n" passes))
 254       (princ (format "\t%5d assertion failures\n" assertion-failures))
 255       (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
 256       (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
 257       (princ (format "\t%5d missing-message failures\n" missing-message-failures))
 258       (princ (format "\t%5d other failures\n" other-failures))
 259       (let* ((total (+ passes
 260                        assertion-failures
 261                        no-error-failures
 262                        wrong-error-failures
 263                        missing-message-failures
 264                        other-failures))
 265              (basename (file-name-nondirectory filename))
 266              (summary-msg
 267               (if (> total 0)
 268                   (format "%s: %d of %d (%d%%) tests successful."
 269                           basename passes total (/ (* 100 passes) total))
 270                 (format "%s: No tests run" basename))))
 271         (message "%s" summary-msg))
 272       (when unexpected-test-suite-failure
 273         (message "Test suite execution failed unexpectedly."))
 274       (fmakunbound 'Assert)
 275       (fmakunbound 'Check-Error)
 276       (fmakunbound 'Ignore-Ebola)
 277       (fmakunbound 'Int-to-Marker)
 278       )))
 279
 280 (defvar test-harness-results-point-max nil)
 281 (defmacro displaying-emacs-test-results (&rest body)
 282   `(let ((test-harness-results-point-max test-harness-results-point-max))
 283      ;; Log the file name.
 284      (test-harness-log-file)
 285      ;; Record how much is logged now.
 286      ;; We will display the log buffer if anything more is logged
 287      ;; before the end of BODY.
 288      (or test-harness-results-point-max
 289          (save-excursion
 290            (set-buffer (get-buffer-create "*Test-Log*"))
 291            (setq test-harness-results-point-max (point-max))))
 292      (unwind-protect
 293          (condition-case error-info
 294              (progn ,@body)
 295            (error
 296             (test-harness-report-error error-info)))
 297        (save-excursion
 298          ;; If there were compilation warnings, display them.
 299          (set-buffer "*Test-Log*")
 300          (if (= test-harness-results-point-max (point-max))
 301              nil
 302            (if temp-buffer-show-function
 303                (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
 304                  (save-excursion
 305                    (set-buffer show-buffer)
 306                    (setq buffer-read-only nil)
 307                    (erase-buffer))
 308                  (copy-to-buffer show-buffer
 309                                  (save-excursion
 310                                    (goto-char test-harness-results-point-max)
 311                                    (forward-line -1)
 312                                    (point))
 313                                  (point-max))
 314                  (funcall temp-buffer-show-function show-buffer))
 315               (select-window
 316                (prog1 (selected-window)
 317                  (select-window (display-buffer (current-buffer)))
 318                  (goto-char test-harness-results-point-max)
 319                  (recenter 1)))))))))
 320
 321 (defun batch-test-emacs-1 (file)
 322   (condition-case error-info
 323       (progn (test-emacs-test-file file) t)
 324     (error
 325      (princ ">>Error occurred processing ")
 326      (princ file)
 327      (princ ": ")
 328      (display-error error-info nil)
 329      (terpri)
 330      nil)))
 331
 332 (defun batch-test-emacs ()
 333   "Run `test-harness' on the files remaining on the command line.
 334 Use this from the command line, with `-batch';
 335 it won't work in an interactive Emacs.
 336 Each file is processed even if an error occurred previously.
 337 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\""
 338   ;; command-line-args-left is what is left of the command line (from
 339   ;; startup.el)
 340   (defvar command-line-args-left)       ;Avoid 'free variable' warning
 341   (defvar debug-issue-ebola-notices)
 342   (if (not noninteractive)
 343       (error "`batch-test-emacs' is to be used only with -batch"))
 344   (let ((error nil))
 345     (dolist (file command-line-args-left)
 346       (if (file-directory-p file)
 347           (dolist (file-in-dir (directory-files file t))
 348             (when (and (string-match emacs-lisp-file-regexp file-in-dir)
 349                        (not (or (auto-save-file-name-p file-in-dir)
 350                                 (backup-file-name-p file-in-dir)
 351                                 (equal (file-name-nondirectory file-in-dir)
 352                                        "test-harness.el"))))
 353               (or (batch-test-emacs-1 file-in-dir)
 354                   (setq error t))))
 355         (or (batch-test-emacs-1 file)
 356             (setq error t))))
 357     ;;(message "%s" (buffer-string nil nil "*Test-Log*"))
 358     (message "Done")
 359     (kill-emacs (if error 1 0))))
 360
 361 (provide 'test-harness)
 362
 363 ;;; test-harness.el ends here