git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 (format "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         ;; #### perhaps this should be a defvar, and output at the very end
 127         ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
 128         ;; what stuff is needed, and ways to avoid using them
 129         (skipped-test-reasons (make-hash-table :test 'equal))
 130
 131         (trick-optimizer nil)
 132         (unexpected-test-suite-failure nil)
 133         (debug-on-error t))
 134     (with-output-to-temp-buffer "*Test-Log*"
 135
 136       (defmacro Assert (assertion)
 137         `(condition-case error-info
 138              (progn
 139                (assert ,assertion)
 140                (princ (format "PASS: %S" (quote ,assertion)))
 141                (terpri)
 142                (incf passes))
 143            (cl-assertion-failed
 144             (princ (format "FAIL: Assertion failed: %S\n" (quote ,assertion)))
 145             (incf assertion-failures))
 146            (t (princ (format "FAIL: %S ==> error: %S\n" (quote ,assertion) error-info))
 147               (incf other-failures)
 148               )))
 149
 150       (defmacro Check-Error (expected-error &rest body)
 151         (let ((quoted-body (if (= 1 (length body))
 152                                `(quote ,(car body)) `(quote (progn ,@body)))))
 153           `(condition-case error-info
 154                (progn
 155                  (setq trick-optimizer (progn ,@body))
 156                  (princ (format "FAIL: %S executed successfully, but expected error %S\n"
 157                                 ,quoted-body
 158                                 ',expected-error))
 159                  (incf no-error-failures))
 160              (,expected-error
 161               (princ (format "PASS: %S ==> error %S, as expected\n"
 162                              ,quoted-body ',expected-error))
 163               (incf passes))
 164              (error
 165               (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n"
 166                              ,quoted-body ',expected-error error-info))
 167               (incf wrong-error-failures)))))
 168
 169       (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body)
 170         (let ((quoted-body (if (= 1 (length body))
 171                                `(quote ,(car body)) `(quote (progn ,@body)))))
 172           `(condition-case error-info
 173                (progn
 174                  (setq trick-optimizer (progn ,@body))
 175                  (princ (format "FAIL: %S executed successfully, but expected error %S\n"
 176                                 ,quoted-body
 177                                 ',expected-error))
 178                  (incf no-error-failures))
 179              (,expected-error
 180               (let ((error-message (second error-info)))
 181                 (if (string-match ,expected-error-regexp error-message)
 182                     (progn
 183                       (princ (format "PASS: %S ==> error %S %S, as expected\n"
 184                                      ,quoted-body error-message ',expected-error))
 185                       (incf passes))
 186                   (princ (format "FAIL: %S ==> got error %S as expected, but error message %S did not match regexp %S\n"
 187                                  ,quoted-body ',expected-error error-message ,expected-error-regexp))
 188                   (incf wrong-error-failures))))
 189              (error
 190               (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n"
 191                              ,quoted-body ',expected-error error-info))
 192               (incf wrong-error-failures)))))
 193
 194       (defun Print-Skip (test reason &optional fmt &rest args)
 195         (setq fmt (concat "SKIP: %S.  REASON: %S" fmt))
 196         (princ (concat (apply #'format fmt test reason args) "\n")))
 197
 198
 199       (defmacro Check-Message (expected-message-regexp &rest body)
 200         (if (not (fboundp 'defadvice))
 201             ;; #### This whole thing should go inside a macro Skip-Test
 202             (let* ((reason "advice unavailable")
 203                    (count (gethash reason skipped-test-reasons)))
 204               ;(message "%S: %S" reason count)
 205               (puthash reason (if (null count) 1 (1+ count))
 206                        skipped-test-reasons)
 207               `(Print-Skip ,expected-message-regexp ,reason))
 208           (let ((quoted-body (if (= 1 (length body))
 209                                  `(quote ,(car body)) `(quote (progn ,@body)))))
 210             `(let ((messages ""))
 211                (defadvice message (around collect activate)
 212                  (defvar messages)
 213                  (let ((msg-string (apply 'format (ad-get-args 0))))
 214                    (setq messages (concat messages msg-string))
 215                    msg-string))
 216                (condition-case error-info
 217                    (progn
 218                      (setq trick-optimizer (progn ,@body))
 219                      (if (string-match ,expected-message-regexp messages)
 220                          (progn
 221                            (princ (format "PASS: %S ==> value %S, message %S, matching %S, as expected\n"
 222                                           ,quoted-body trick-optimizer messages ',expected-message-regexp))
 223                            (incf passes))
 224                        (princ (format "FAIL: %S ==> value %S, message %S, NOT matching expected %S\n"
 225                                       ,quoted-body  trick-optimizer messages ',expected-message-regexp))
 226                        (incf missing-message-failures)))
 227                  (error
 228                   (princ (format "FAIL: %S ==> unexpected error %S\n"
 229                                  ,quoted-body error-info))
 230                   (incf other-failures)))
 231                (ad-unadvise 'message)))))
 232
 233       (defmacro Ignore-Ebola (&rest body)
 234         `(let ((debug-issue-ebola-notices -42)) ,@body))
 235
 236       (defun Int-to-Marker (pos)
 237         (save-excursion
 238           (set-buffer standard-output)
 239           (save-excursion
 240             (goto-char pos)
 241             (point-marker))))
 242
 243       (princ "Testing Interpreted Lisp\n\n")
 244       (condition-case error-info
 245           (funcall (test-harness-read-from-buffer inbuffer))
 246         (error
 247          (setq unexpected-test-suite-failure t)
 248          (princ (format "Unexpected error %S while executing interpreted code\n"
 249                 error-info))
 250          (message "Unexpected error %S while executing interpreted code." error-info)
 251          (message "Test suite execution aborted." error-info)
 252          ))
 253       (princ "\nTesting Compiled Lisp\n\n")
 254       (let (code)
 255         (condition-case error-info
 256             (setq code
 257                   ;; our lisp code is often intentionally dubious,
 258                   ;; so throw away _all_ the byte compiler warnings.
 259                   (letf (((symbol-function 'byte-compile-warn) 'ignore))
 260                     (byte-compile (test-harness-read-from-buffer inbuffer))))
 261           (error
 262            (princ (format "Unexpected error %S while byte-compiling code\n"
 263                           error-info))))
 264         (condition-case error-info
 265             (if code (funcall code))
 266           (error
 267            (princ (format "Unexpected error %S while executing byte-compiled code\n"
 268                           error-info))
 269            (message "Unexpected error %S while executing byte-compiled code." error-info)
 270            (message "Test suite execution aborted." error-info)
 271            )))
 272       (princ "\nSUMMARY:\n")
 273       (princ (format "\t%5d passes\n" passes))
 274       (princ (format "\t%5d assertion failures\n" assertion-failures))
 275       (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
 276       (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
 277       (princ (format "\t%5d missing-message failures\n" missing-message-failures))
 278       (princ (format "\t%5d other failures\n" other-failures))
 279       (let* ((total (+ passes
 280                        assertion-failures
 281                        no-error-failures
 282                        wrong-error-failures
 283                        missing-message-failures
 284                        other-failures))
 285              (basename (file-name-nondirectory filename))
 286              (summary-msg
 287               (if (> total 0)
 288                   (format "%s: %d of %d (%d%%) tests successful."
 289                           basename passes total (/ (* 100 passes) total))
 290                 (format "%s: No tests run" basename)))
 291              (reasons ""))
 292         (maphash (lambda (key value)
 293                    (setq reasons
 294                          (concat reasons
 295                                  (format "\n    %d tests skipped because %s"
 296                                          value key))))
 297                  skipped-test-reasons)
 298         (when (> (length reasons) 1)
 299           (setq summary-msg (concat summary-msg reasons "
 300     Probably XEmacs cannot find your installed packages.  Set EMACSPACKAGEPATH
 301     to the package hierarchy root or configure with --package-path to enable
 302     the skipped tests.")))
 303         (message "%s" summary-msg))
 304       (when unexpected-test-suite-failure
 305         (message "Test suite execution failed unexpectedly."))
 306       (fmakunbound 'Assert)
 307       (fmakunbound 'Check-Error)
 308       (fmakunbound 'Check-Message)
 309       (fmakunbound 'Check-Error-Message)
 310       (fmakunbound 'Ignore-Ebola)
 311       (fmakunbound 'Int-to-Marker)
 312       )))
 313
 314 (defvar test-harness-results-point-max nil)
 315 (defmacro displaying-emacs-test-results (&rest body)
 316   `(let ((test-harness-results-point-max test-harness-results-point-max))
 317      ;; Log the file name.
 318      (test-harness-log-file)
 319      ;; Record how much is logged now.
 320      ;; We will display the log buffer if anything more is logged
 321      ;; before the end of BODY.
 322      (or test-harness-results-point-max
 323          (save-excursion
 324            (set-buffer (get-buffer-create "*Test-Log*"))
 325            (setq test-harness-results-point-max (point-max))))
 326      (unwind-protect
 327          (condition-case error-info
 328              (progn ,@body)
 329            (error
 330             (test-harness-report-error error-info)))
 331        (save-excursion
 332          ;; If there were compilation warnings, display them.
 333          (set-buffer "*Test-Log*")
 334          (if (= test-harness-results-point-max (point-max))
 335              nil
 336            (if temp-buffer-show-function
 337                (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
 338                  (save-excursion
 339                    (set-buffer show-buffer)
 340                    (setq buffer-read-only nil)
 341                    (erase-buffer))
 342                  (copy-to-buffer show-buffer
 343                                  (save-excursion
 344                                    (goto-char test-harness-results-point-max)
 345                                    (forward-line -1)
 346                                    (point))
 347                                  (point-max))
 348                  (funcall temp-buffer-show-function show-buffer))
 349               (select-window
 350                (prog1 (selected-window)
 351                  (select-window (display-buffer (current-buffer)))
 352                  (goto-char test-harness-results-point-max)
 353                  (recenter 1)))))))))
 354
 355 (defun batch-test-emacs-1 (file)
 356   (condition-case error-info
 357       (progn (test-emacs-test-file file) t)
 358     (error
 359      (princ ">>Error occurred processing ")
 360      (princ file)
 361      (princ ": ")
 362      (display-error error-info nil)
 363      (terpri)
 364      nil)))
 365
 366 (defun batch-test-emacs ()
 367   "Run `test-harness' on the files remaining on the command line.
 368 Use this from the command line, with `-batch';
 369 it won't work in an interactive Emacs.
 370 Each file is processed even if an error occurred previously.
 371 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\""
 372   ;; command-line-args-left is what is left of the command line (from
 373   ;; startup.el)
 374   (defvar command-line-args-left)       ;Avoid 'free variable' warning
 375   (defvar debug-issue-ebola-notices)
 376   (if (not noninteractive)
 377       (error "`batch-test-emacs' is to be used only with -batch"))
 378   (let ((error nil))
 379     (dolist (file command-line-args-left)
 380       (if (file-directory-p file)
 381           (dolist (file-in-dir (directory-files file t))
 382             (when (and (string-match emacs-lisp-file-regexp file-in-dir)
 383                        (not (or (auto-save-file-name-p file-in-dir)
 384                                 (backup-file-name-p file-in-dir)
 385                                 (equal (file-name-nondirectory file-in-dir)
 386                                        "test-harness.el"))))
 387               (or (batch-test-emacs-1 file-in-dir)
 388                   (setq error t))))
 389         (or (batch-test-emacs-1 file)
 390             (setq error t))))
 391     ;;(message "%s" (buffer-string nil nil "*Test-Log*"))
 392     (message "Done")
 393     (kill-emacs (if error 1 0))))
 394
 395 (provide 'test-harness)
 396
 397 ;;; test-harness.el ends here