git.chise.org Git - chise/xemacs-chise.git-/blob - tests/automated/test-harness.el

   1 ;; test-harness.el --- Run Emacs Lisp test suites.
   2
   3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc.
   4 ;;; Copyright (C) 2002 Ben Wing.
   5
   6 ;; Author: Martin Buchholz
   7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org>
   8 ;; Keywords: testing
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;;; A test suite harness for testing XEmacs.
  32 ;;; The actual tests are in other files in this directory.
  33 ;;; Basically you just create files of emacs-lisp, and use the
  34 ;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions
  35 ;;; to create tests.  See `test-harness-from-buffer' below.
  36 ;;; Don't suppress tests just because they're due to known bugs not yet
  37 ;;; fixed -- use the Known-Bug-Expect-Failure and
  38 ;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them.
  39 ;;; A lot of the tests we run push limits; suppress Ebola message with the
  40 ;;; Ignore-Ebola wrapper macro.
  41 ;;;
  42 ;;; You run the tests using M-x test-emacs-test-file,
  43 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ...
  44 ;;; which is run for you by the `make check' target in the top-level Makefile.
  45
  46 (require 'bytecomp)
  47
  48 (defvar test-harness-test-compiled nil
  49   "Non-nil means the test code was compiled before execution.")
  50
  51 (defvar test-harness-verbose
  52   (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
  53   "*Non-nil means print messages describing progress of emacs-tester.")
  54
  55 (defvar test-harness-file-results-alist nil
  56   "Each element is a list (FILE SUCCESSES TESTS).
  57 The order is the reverse of the order in which tests are run.
  58
  59 FILE is a string naming the test file.
  60 SUCCESSES is a non-negative integer, the number of successes.
  61 TESTS is a non-negative integer, the number of tests run.")
  62
  63 (defvar test-harness-risk-infloops nil
  64   "*Non-nil to run tests that may loop infinitely in buggy implementations.")
  65
  66 (defvar test-harness-current-file nil)
  67
  68 (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'")
  69   "*Regexp which matches Emacs Lisp source files.")
  70
  71 (defconst test-harness-file-summary-template
  72   (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)."
  73           (length "byte-compiler-tests.el:") ; use the longest file name
  74           5
  75           5)
  76   "Format for summary lines printed after each file is run.")
  77
  78 (defconst test-harness-null-summary-template
  79   (format "%%-%ds             No tests run."
  80           (length "byte-compiler-tests.el:")) ; use the longest file name
  81   "Format for \"No tests\" lines printed after a file is run.")
  82
  83 ;;;###autoload
  84 (defun test-emacs-test-file (filename)
  85   "Test a file of Lisp code named FILENAME.
  86 The output file's name is made by appending `c' to the end of FILENAME."
  87   (interactive
  88    (let ((file buffer-file-name)
  89          (file-name nil)
  90          (file-dir nil))
  91      (and file
  92           (eq (cdr (assq 'major-mode (buffer-local-variables)))
  93               'emacs-lisp-mode)
  94           (setq file-name (file-name-nondirectory file)
  95                 file-dir (file-name-directory file)))
  96      (list (read-file-name "Test file: " file-dir nil nil file-name))))
  97   ;; Expand now so we get the current buffer's defaults
  98   (setq filename (expand-file-name filename))
  99
 100   ;; If we're testing a file that's in a buffer and is modified, offer
 101   ;; to save it first.
 102   (or noninteractive
 103       (let ((b (get-file-buffer (expand-file-name filename))))
 104         (if (and b (buffer-modified-p b)
 105                  (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
 106             (save-excursion (set-buffer b) (save-buffer)))))
 107
 108   (if (or noninteractive test-harness-verbose)
 109       (message "Testing %s..." filename))
 110   (let ((test-harness-current-file filename)
 111         input-buffer)
 112     (save-excursion
 113       (setq input-buffer (get-buffer-create " *Test Input*"))
 114       (set-buffer input-buffer)
 115       (erase-buffer)
 116       (insert-file-contents filename)
 117       ;; Run hooks including the uncompression hook.
 118       ;; If they change the file name, then change it for the output also.
 119       (let ((buffer-file-name filename)
 120             (default-major-mode 'emacs-lisp-mode)
 121             (enable-local-eval nil))
 122         (normal-mode)
 123         (setq filename buffer-file-name)))
 124     (test-harness-from-buffer input-buffer filename)
 125     (kill-buffer input-buffer)
 126     ))
 127
 128 (defun test-harness-read-from-buffer (buffer)
 129   "Read forms from BUFFER, and turn it into a lambda test form."
 130   (let ((body nil))
 131     (goto-char (point-min) buffer)
 132     (condition-case error-info
 133         (while t
 134           (setq body (cons (read buffer) body)))
 135       (end-of-file nil)
 136       (error
 137        (princ (format "Unexpected error %S reading forms from buffer\n"
 138                       error-info))))
 139     `(lambda ()
 140        (defvar passes)
 141        (defvar assertion-failures)
 142        (defvar no-error-failures)
 143        (defvar wrong-error-failures)
 144        (defvar missing-message-failures)
 145        (defvar other-failures)
 146
 147        (defvar unexpected-test-suite-failure)
 148        (defvar trick-optimizer)
 149
 150        ,@(nreverse body))))
 151
 152 (defun test-harness-from-buffer (inbuffer filename)
 153   "Run tests in buffer INBUFFER, visiting FILENAME."
 154   (defvar trick-optimizer)
 155   (let ((passes 0)
 156         (assertion-failures 0)
 157         (no-error-failures 0)
 158         (wrong-error-failures 0)
 159         (missing-message-failures 0)
 160         (other-failures 0)
 161
 162         ;; #### perhaps this should be a defvar, and output at the very end
 163         ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
 164         ;; what stuff is needed, and ways to avoid using them
 165         (skipped-test-reasons (make-hash-table :test 'equal))
 166
 167         (trick-optimizer nil)
 168         (unexpected-test-suite-failure nil)
 169         (debug-on-error t)
 170         (pass-stream nil))
 171     (with-output-to-temp-buffer "*Test-Log*"
 172       (princ (format "Testing %s...\n\n" filename))
 173
 174       (defconst test-harness-failure-tag "FAIL")
 175       (defconst test-harness-success-tag "PASS")
 176
 177       (defmacro Known-Bug-Expect-Failure (&rest body)
 178         `(let ((test-harness-failure-tag "KNOWN BUG")
 179                (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
 180           ,@body))
 181
 182       (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
 183         `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
 184                (test-harness-success-tag "PASS (FAILURE EXPECTED)"))
 185           ,@body))
 186
 187       (defun Print-Failure (fmt &rest args)
 188         (setq fmt (format "%s: %s" test-harness-failure-tag fmt))
 189         (if (noninteractive) (apply #'message fmt args))
 190         (princ (concat (apply #'format fmt args) "\n")))
 191
 192       (defun Print-Pass (fmt &rest args)
 193         (setq fmt (format "%s: %s" test-harness-success-tag fmt))
 194         (and test-harness-verbose
 195              (princ (concat (apply #'format fmt args) "\n"))))
 196
 197       (defun Print-Skip (test reason &optional fmt &rest args)
 198         (setq fmt (concat "SKIP: %S BECAUSE %S" fmt))
 199         (princ (concat (apply #'format fmt test reason args) "\n")))
 200
 201       (defmacro Skip-Test-Unless (condition reason description &rest body)
 202         "Unless CONDITION is satisfied, skip test BODY.
 203 REASON is a description of the condition failure, and must be unique (it
 204 is used as a hash key).  DESCRIPTION describes the tests that were skipped.
 205 BODY is a sequence of expressions and may contain several tests."
 206         `(if (not ,condition)
 207              (let ((count (gethash ,reason skipped-test-reasons)))
 208                (puthash ,reason (if (null count) 1 (1+ count))
 209                         skipped-test-reasons)
 210                (Print-Skip ,description ,reason))
 211            ,@body))
 212
 213       (defmacro Assert (assertion)
 214         `(condition-case error-info
 215              (progn
 216                (assert ,assertion)
 217                (Print-Pass "%S" (quote ,assertion))
 218                (incf passes))
 219            (cl-assertion-failed
 220             (Print-Failure "Assertion failed: %S" (quote ,assertion))
 221             (incf assertion-failures))
 222            (t (Print-Failure "%S ==> error: %S" (quote ,assertion) error-info)
 223               (incf other-failures)
 224               )))
 225
 226       (defmacro Check-Error (expected-error &rest body)
 227         (let ((quoted-body (if (= 1 (length body))
 228                                `(quote ,(car body)) `(quote (progn ,@body)))))
 229           `(condition-case error-info
 230                (progn
 231                  (setq trick-optimizer (progn ,@body))
 232                  (Print-Failure "%S executed successfully, but expected error %S"
 233                                 ,quoted-body
 234                                 ',expected-error)
 235                  (incf no-error-failures))
 236              (,expected-error
 237               (Print-Pass "%S ==> error %S, as expected"
 238                           ,quoted-body ',expected-error)
 239               (incf passes))
 240              (error
 241               (Print-Failure "%S ==> expected error %S, got error %S instead"
 242                              ,quoted-body ',expected-error error-info)
 243               (incf wrong-error-failures)))))
 244
 245       (defmacro Check-Error-Message (expected-error expected-error-regexp
 246                                                     &rest body)
 247         (let ((quoted-body (if (= 1 (length body))
 248                                `(quote ,(car body)) `(quote (progn ,@body)))))
 249           `(condition-case error-info
 250                (progn
 251                  (setq trick-optimizer (progn ,@body))
 252                  (Print-Failure "%S executed successfully, but expected error %S"
 253                                 ,quoted-body ',expected-error)
 254                  (incf no-error-failures))
 255              (,expected-error
 256               (let ((error-message (second error-info)))
 257                 (if (string-match ,expected-error-regexp error-message)
 258                     (progn
 259                       (Print-Pass "%S ==> error %S %S, as expected"
 260                                   ,quoted-body error-message ',expected-error)
 261                       (incf passes))
 262                   (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S"
 263                                  ,quoted-body ',expected-error error-message ,expected-error-regexp)
 264                   (incf wrong-error-failures))))
 265              (error
 266               (Print-Failure "%S ==> expected error %S, got error %S instead"
 267                              ,quoted-body ',expected-error error-info)
 268               (incf wrong-error-failures)))))
 269
 270
 271       (defmacro Check-Message (expected-message-regexp &rest body)
 272         (Skip-Test-Unless (fboundp 'defadvice)
 273                           "can't defadvice"
 274                           expected-message-regexp
 275           (let ((quoted-body (if (= 1 (length body))
 276                                  `(quote ,(car body))
 277                                `(quote (progn ,@body)))))
 278             `(let ((messages ""))
 279                (defadvice message (around collect activate)
 280                  (defvar messages)
 281                  (let ((msg-string (apply 'format (ad-get-args 0))))
 282                    (setq messages (concat messages msg-string))
 283                    msg-string))
 284                (condition-case error-info
 285                    (progn
 286                      (setq trick-optimizer (progn ,@body))
 287                      (if (string-match ,expected-message-regexp messages)
 288                          (progn
 289                            (Print-Pass "%S ==> value %S, message %S, matching %S, as expected"
 290                                        ,quoted-body trick-optimizer messages ',expected-message-regexp)
 291                            (incf passes))
 292                        (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S"
 293                                       ,quoted-body  trick-optimizer messages
 294                                       ',expected-message-regexp)
 295                        (incf missing-message-failures)))
 296                  (error
 297                   (Print-Failure "%S ==> unexpected error %S"
 298                                  ,quoted-body error-info)
 299                   (incf other-failures)))
 300                (ad-unadvise 'message)))))
 301
 302       (defmacro Ignore-Ebola (&rest body)
 303         `(let ((debug-issue-ebola-notices -42)) ,@body))
 304
 305       (defun Int-to-Marker (pos)
 306         (save-excursion
 307           (set-buffer standard-output)
 308           (save-excursion
 309             (goto-char pos)
 310             (point-marker))))
 311
 312       (princ "Testing Interpreted Lisp\n\n")
 313       (condition-case error-info
 314           (funcall (test-harness-read-from-buffer inbuffer))
 315         (error
 316          (setq unexpected-test-suite-failure t)
 317          (princ (format "Unexpected error %S while executing interpreted code\n"
 318                 error-info))
 319          (message "Unexpected error %S while executing interpreted code." error-info)
 320          (message "Test suite execution aborted." error-info)
 321          ))
 322       (princ "\nTesting Compiled Lisp\n\n")
 323       (let (code
 324             (test-harness-test-compiled t))
 325         (condition-case error-info
 326             (setq code
 327                   ;; our lisp code is often intentionally dubious,
 328                   ;; so throw away _all_ the byte compiler warnings.
 329                   (letf (((symbol-function 'byte-compile-warn) 'ignore))
 330                     (byte-compile (test-harness-read-from-buffer inbuffer))))
 331           (error
 332            (princ (format "Unexpected error %S while byte-compiling code\n"
 333                           error-info))))
 334         (condition-case error-info
 335             (if code (funcall code))
 336           (error
 337            (princ (format "Unexpected error %S while executing byte-compiled code\n"
 338                           error-info))
 339            (message "Unexpected error %S while executing byte-compiled code." error-info)
 340            (message "Test suite execution aborted." error-info)
 341            )))
 342       (princ (format "\nSUMMARY for %s:\n" filename))
 343       (princ (format "\t%5d passes\n" passes))
 344       (princ (format "\t%5d assertion failures\n" assertion-failures))
 345       (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
 346       (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
 347       (princ (format "\t%5d missing-message failures\n" missing-message-failures))
 348       (princ (format "\t%5d other failures\n" other-failures))
 349       (let* ((total (+ passes
 350                        assertion-failures
 351                        no-error-failures
 352                        wrong-error-failures
 353                        missing-message-failures
 354                        other-failures))
 355              (basename (file-name-nondirectory filename))
 356              (summary-msg
 357               (if (> total 0)
 358                   (format test-harness-file-summary-template
 359                           (concat basename ":")
 360                           passes total (/ (* 100 passes) total))
 361                 (format test-harness-null-summary-template
 362                         (concat basename ":"))))
 363              (reasons ""))
 364         (maphash (lambda (key value)
 365                    (setq reasons
 366                          (concat reasons
 367                                  (format "\n    %d tests skipped because %s."
 368                                          value key))))
 369                  skipped-test-reasons)
 370         (when (> (length reasons) 1)
 371           (setq summary-msg (concat summary-msg reasons "
 372     Probably XEmacs cannot find your installed packages.  Set EMACSPACKAGEPATH
 373     to the package hierarchy root or configure with --package-path to enable
 374     the skipped tests.")))
 375         (setq test-harness-file-results-alist
 376               (cons (list filename passes total)
 377                     test-harness-file-results-alist))
 378         (message "%s" summary-msg))
 379       (when unexpected-test-suite-failure
 380         (message "Test suite execution failed unexpectedly."))
 381       (fmakunbound 'Assert)
 382       (fmakunbound 'Check-Error)
 383       (fmakunbound 'Check-Message)
 384       (fmakunbound 'Check-Error-Message)
 385       (fmakunbound 'Ignore-Ebola)
 386       (fmakunbound 'Int-to-Marker)
 387       (and noninteractive
 388            (message "%s" (buffer-substring-no-properties
 389                           nil nil "*Test-Log*")))
 390       )))
 391
 392 (defvar test-harness-results-point-max nil)
 393 (defmacro displaying-emacs-test-results (&rest body)
 394   `(let ((test-harness-results-point-max test-harness-results-point-max))
 395      ;; Log the file name.
 396      (test-harness-log-file)
 397      ;; Record how much is logged now.
 398      ;; We will display the log buffer if anything more is logged
 399      ;; before the end of BODY.
 400      (or test-harness-results-point-max
 401          (save-excursion
 402            (set-buffer (get-buffer-create "*Test-Log*"))
 403            (setq test-harness-results-point-max (point-max))))
 404      (unwind-protect
 405          (condition-case error-info
 406              (progn ,@body)
 407            (error
 408             (test-harness-report-error error-info)))
 409        (save-excursion
 410          ;; If there were compilation warnings, display them.
 411          (set-buffer "*Test-Log*")
 412          (if (= test-harness-results-point-max (point-max))
 413              nil
 414            (if temp-buffer-show-function
 415                (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
 416                  (save-excursion
 417                    (set-buffer show-buffer)
 418                    (setq buffer-read-only nil)
 419                    (erase-buffer))
 420                  (copy-to-buffer show-buffer
 421                                  (save-excursion
 422                                    (goto-char test-harness-results-point-max)
 423                                    (forward-line -1)
 424                                    (point))
 425                                  (point-max))
 426                  (funcall temp-buffer-show-function show-buffer))
 427               (select-window
 428                (prog1 (selected-window)
 429                  (select-window (display-buffer (current-buffer)))
 430                  (goto-char test-harness-results-point-max)
 431                  (recenter 1)))))))))
 432
 433 (defun batch-test-emacs-1 (file)
 434   (condition-case error-info
 435       (progn (test-emacs-test-file file) t)
 436     (error
 437      (princ ">>Error occurred processing ")
 438      (princ file)
 439      (princ ": ")
 440      (display-error error-info nil)
 441      (terpri)
 442      nil)))
 443
 444 (defun batch-test-emacs ()
 445   "Run `test-harness' on the files remaining on the command line.
 446 Use this from the command line, with `-batch';
 447 it won't work in an interactive Emacs.
 448 Each file is processed even if an error occurred previously.
 449 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\""
 450   ;; command-line-args-left is what is left of the command line (from
 451   ;; startup.el)
 452   (defvar command-line-args-left)       ;Avoid 'free variable' warning
 453   (defvar debug-issue-ebola-notices)
 454   (if (not noninteractive)
 455       (error "`batch-test-emacs' is to be used only with -batch"))
 456   (let ((error nil))
 457     (dolist (file command-line-args-left)
 458       (if (file-directory-p file)
 459           (dolist (file-in-dir (directory-files file t))
 460             (when (and (string-match emacs-lisp-file-regexp file-in-dir)
 461                        (not (or (auto-save-file-name-p file-in-dir)
 462                                 (backup-file-name-p file-in-dir)
 463                                 (equal (file-name-nondirectory file-in-dir)
 464                                        "test-harness.el"))))
 465               (or (batch-test-emacs-1 file-in-dir)
 466                   (setq error t))))
 467         (or (batch-test-emacs-1 file)
 468             (setq error t))))
 469     (let ((namelen 0)
 470           (succlen 0)
 471           (testlen 0)
 472           (results test-harness-file-results-alist))
 473       ;; compute maximum lengths of variable components of report
 474       ;; probably should just use (length "byte-compiler-tests.el")
 475       ;; and 5-place sizes -- this will also work for the file-by-file
 476       ;; printing when Adrian's kludge gets reverted
 477       (flet ((print-width (i)
 478                (let ((x 10) (y 1))
 479                  (while (>= i x)
 480                    (setq x (* 10 x) y (1+ y)))
 481                  y)))
 482         (while results
 483           (let* ((head (car results))
 484                  (nn (length (file-name-nondirectory (first head))))
 485                  (ss (print-width (second head)))
 486                  (tt (print-width (third head))))
 487             (when (> nn namelen) (setq namelen nn))
 488             (when (> ss succlen) (setq succlen ss))
 489             (when (> tt testlen) (setq testlen tt)))
 490           (setq results (cdr results))))
 491       ;; create format and print
 492       (let ((results (reverse test-harness-file-results-alist)))
 493         (while results
 494           (let* ((head (car results))
 495                  (basename (file-name-nondirectory (first head)))
 496                  (nsucc (second head))
 497                  (ntest (third head)))
 498             (if (> ntest 0)
 499                 (message test-harness-file-summary-template
 500                          (concat basename ":")
 501                          nsucc
 502                          ntest
 503                          (/ (* 100 nsucc) ntest))
 504               (message test-harness-null-summary-template
 505                        (concat basename ":")))
 506             (setq results (cdr results))))))
 507     (message "\nDone")
 508     (kill-emacs (if error 1 0))))
 509
 510 (provide 'test-harness)
 511
 512 ;;; test-harness.el ends here