git.chise.org Git - chise/xemacs-chise.git.1/blob - tests/test-emacs.el

   1 ;; test-emacs.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 (defvar test-emacs-verbose
  28   (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
  29   "*Non-nil means print messages describing progress of emacs-tester.")
  30
  31 (defvar test-emacs-current-file nil)
  32
  33 (defvar emacs-lisp-file-regexp (purecopy "\\.el$")
  34   "*Regexp which matches Emacs Lisp source files.")
  35
  36 (defun test-emacs-test-file (filename)
  37   "Test a file of Lisp code named FILENAME.
  38 The output file's name is made by appending `c' to the end of FILENAME."
  39   ;;  (interactive "fTest file: ")
  40   (interactive
  41    (let ((file buffer-file-name)
  42          (file-name nil)
  43          (file-dir nil))
  44      (and file
  45           (eq (cdr (assq 'major-mode (buffer-local-variables)))
  46               'emacs-lisp-mode)
  47           (setq file-name (file-name-nondirectory file)
  48                 file-dir (file-name-directory file)))
  49      (list (read-file-name "Test file: " file-dir nil nil file-name))))
  50   ;; Expand now so we get the current buffer's defaults
  51   (setq filename (expand-file-name filename))
  52
  53   ;; If we're testing a file that's in a buffer and is modified, offer
  54   ;; to save it first.
  55   (or noninteractive
  56       (let ((b (get-file-buffer (expand-file-name filename))))
  57         (if (and b (buffer-modified-p b)
  58                  (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
  59             (save-excursion (set-buffer b) (save-buffer)))))
  60
  61   (if (or noninteractive test-emacs-verbose)
  62       (message "Testing %s..." filename))
  63   (let ((test-emacs-current-file filename)
  64         input-buffer)
  65     (save-excursion
  66       (setq input-buffer (get-buffer-create " *Test Input*"))
  67       (set-buffer input-buffer)
  68       (erase-buffer)
  69       (insert-file-contents filename)
  70       ;; Run hooks including the uncompression hook.
  71       ;; If they change the file name, then change it for the output also.
  72       (let ((buffer-file-name filename)
  73             (default-major-mode 'emacs-lisp-mode)
  74             (enable-local-eval nil))
  75         (normal-mode)
  76         (setq filename buffer-file-name)))
  77     (test-emacs-from-buffer input-buffer filename)
  78     (kill-buffer input-buffer)
  79     ))
  80
  81 (defun test-emacs-read-from-buffer (buffer)
  82   "Read forms from BUFFER, and turn it into a lambda test form."
  83   (let ((body nil))
  84     (goto-char (point-min) buffer)
  85     (condition-case nil
  86         (while t
  87           (setq body (cons (read inbuffer) body)))
  88       (error nil))
  89     `(lambda ()
  90        (defvar passes)
  91        (defvar assertion-failures)
  92        (defvar other-failures)
  93        ,@(nreverse body))))
  94
  95 (defun test-emacs-from-buffer (inbuffer filename)
  96   "Run tests in buffer INBUFFER, visiting FILENAME."
  97   (let ((passes 0)
  98         (assertion-failures 0)
  99         (other-failures 0))
 100     (with-output-to-temp-buffer "*Test-Log*"
 101       (defmacro Assert (assertion)
 102         `(condition-case error
 103              (progn
 104                (assert ,assertion)
 105                (princ (format "PASS: %S" (quote ,assertion)))
 106                (terpri)
 107                (incf passes))
 108            (cl-assertion-failed
 109             (princ (format "Assertion failed: %S" (quote ,assertion)))
 110             (terpri)
 111             (incf assertion-failures))
 112            (t (princ "Error during test execution:\n\t")
 113               (display-error error nil)
 114               (terpri)
 115               (incf other-failures)
 116               )))
 117
 118       (princ "Testing Interpreted Lisp\n\n")
 119       (funcall (test-emacs-read-from-buffer inbuffer))
 120       (princ "\nTesting Compiled Lisp\n\n")
 121       (funcall (byte-compile (test-emacs-read-from-buffer inbuffer)))
 122       (princ (format
 123               "\nSUMMARY: %d passes, %d assertion failures, %d other failures\n"
 124               passes
 125               assertion-failures
 126               other-failures))
 127       (let* ((total (+ passes assertion-failures other-failures))
 128              (basename (file-name-nondirectory filename))
 129              (summary-msg
 130               (if (> total 0)
 131                   (format "%s: %d of %d (%d%%) tests successful."
 132                           basename passes total (/ (* 100 passes) total))
 133                 (format "%s: No tests run" basename))))
 134         (message "%s" summary-msg))
 135       (fmakunbound 'Assert))))
 136
 137 (defvar test-emacs-results-point-max nil)
 138 (defmacro displaying-emacs-test-results (&rest body)
 139   `(let ((test-emacs-results-point-max test-emacs-results-point-max))
 140      ;; Log the file name.
 141      (test-emacs-log-file)
 142      ;; Record how much is logged now.
 143      ;; We will display the log buffer if anything more is logged
 144      ;; before the end of BODY.
 145      (or test-emacs-results-point-max
 146          (save-excursion
 147            (set-buffer (get-buffer-create "*Test-Log*"))
 148            (setq test-emacs-results-point-max (point-max))))
 149      (unwind-protect
 150          (condition-case error-info
 151              (progn ,@body)
 152            (error
 153             (test-emacs-report-error error-info)))
 154        (save-excursion
 155          ;; If there were compilation warnings, display them.
 156          (set-buffer "*Test-Log*")
 157          (if (= test-emacs-results-point-max (point-max))
 158              nil
 159            (if temp-buffer-show-function
 160                (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
 161                  (save-excursion
 162                    (set-buffer show-buffer)
 163                    (setq buffer-read-only nil)
 164                    (erase-buffer))
 165                  (copy-to-buffer show-buffer
 166                                  (save-excursion
 167                                    (goto-char test-emacs-results-point-max)
 168                                    (forward-line -1)
 169                                    (point))
 170                                  (point-max))
 171                  (funcall temp-buffer-show-function show-buffer))
 172               (select-window
 173                (prog1 (selected-window)
 174                  (select-window (display-buffer (current-buffer)))
 175                  (goto-char test-emacs-results-point-max)
 176                  (recenter 1)))))))))
 177
 178 (defun batch-test-emacs-1 (file)
 179   (condition-case err
 180       (progn (test-emacs-test-file file) t)
 181     (error
 182      (princ ">>Error occurred processing ")
 183      (princ file)
 184      (princ ": ")
 185      (display-error err nil)
 186      (terpri)
 187      nil)))
 188
 189 (defun batch-test-emacs ()
 190   "Run `test-emacs' on the files remaining on the command line.
 191 Use this from the command line, with `-batch';
 192 it won't work in an interactive Emacs.
 193 Each file is processed even if an error occurred previously.
 194 For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\""
 195   ;; command-line-args-left is what is left of the command line (from
 196   ;; startup.el)
 197   (defvar command-line-args-left)       ;Avoid 'free variable' warning
 198   (if (not noninteractive)
 199       (error "`batch-test-emacs' is to be used only with -batch"))
 200   (let ((error nil)
 201         (debug-issue-ebola-notices 0))
 202     (loop for file in command-line-args-left
 203       do
 204       (if (file-directory-p (expand-file-name file))
 205           (let ((files (directory-files file))
 206                 source)
 207             (while files
 208               (if (and (string-match emacs-lisp-file-regexp (car files))
 209                        (not (auto-save-file-name-p (car files)))
 210                        (setq source (expand-file-name
 211                                      (car files)
 212                                      file))
 213                        (if (null (batch-test-emacs-1 source))
 214                            (setq error t)))
 215                   (setq files (cdr files)))))
 216         (if (null (batch-test-emacs-1 file))
 217             (setq error t))))
 218     (message "Done")
 219     (kill-emacs (if error 1 0))))