code.delx.au - gnu-emacs-elpa/blob - test-simple.el

   1 ;;; test-simple.el --- Simple Unit Test Framework for Emacs Lisp
   2 ;; adapted from Phil Hagelberg's behave.el by rocky
   3 ;; See also Christian Ohler's ert http://github.com/ohler/ert
   4
   5 ;; Copyright (C) 2010, 2012 Rocky Bernstein
   6
   7 ;; Author: Rocky Bernstein
   8 ;; URL: http://github.com/rocky/emacs-test-simple
   9 ;; Keywords: unit-test specification specs
  10
  11 ;; This file is NOT part of GNU Emacs.
  12
  13 ;; This is free software; you can redistribute it and/or modify it under
  14 ;; the terms of the GNU General Public License as published by the Free
  15 ;; Software Foundation; either version 3, or (at your option) any later
  16 ;; version.
  17
  18 ;; This file is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with Emacs; see the file COPYING, or type `C-h C-c'. If not,
  25 ;; write to the Free Software Foundation at this address:
  26
  27 ;;   Free Software Foundation
  28 ;;   51 Franklin Street, Fifth Floor
  29 ;;   Boston, MA 02110-1301
  30 ;;   USA
  31
  32 ;;; Commentary:
  33
  34 ;; test-simple.el allows you to write tests for your Emacs Lisp
  35 ;; code. Executable specifications allow you to check that your code
  36 ;; is working correctly in an automated fashion that you can use to
  37 ;; drive the focus of your development. (It's related to Test-Driven
  38 ;; Development.) You can read up on it at http://behaviour-driven.org.
  39
  40 ;; Assertions may have docstrings so that when the specifications
  41 ;; aren't met it is easy to see what caused the failure.
  42
  43 ;; When "note" is used subsequent tests are grouped assumed to be
  44 ;; related to that not.
  45
  46 ;; When you want to run the specs, evaluate the buffer. Or evaluate
  47 ;; individual assertions. Results are save in the
  48 ;; *test-simple* buffer.
  49
  50 ;;; Implementation
  51
  52 ;; Contexts are stored in the *test-simple-contexts* list as structs. Each
  53 ;; context has a "specs" slot that contains a list of its specs, which
  54 ;; are stored as closures. The expect form ensures that expectations
  55 ;; are met and signals test-simple-spec-failed if they are not.
  56
  57 ;; Warning: the variable CONTEXT is used within macros
  58 ;; in such a way that they could shadow variables of the same name in
  59 ;; the code being tested. Future versions will use gensyms to solve
  60 ;; this issue, but in the mean time avoid relying upon variables with
  61 ;; those names.
  62
  63 ;;; To do:
  64
  65 ;; Main issues: more expect predicates
  66
  67 ;;; Usage:
  68
  69 (make-variable-buffer-local (defvar spec-count))
  70 (make-variable-buffer-local (defvar spec-desc))
  71 (make-variable-buffer-local (defvar test-simple-failures nil))
  72
  73 (eval-when-compile
  74   (byte-compile-disable-warning 'cl-functions)
  75   ;; Somehow disabling cl-functions causes the erroneous message:
  76   ;;   Warning: the function `reduce' might not be defined at runtime.
  77   ;; FIXME: isolate, fix and/or report back to Emacs developers a bug
  78   (byte-compile-disable-warning 'unresolved)
  79   (require 'cl)
  80   )
  81 (require 'cl)
  82
  83 (make-variable-buffer-local
  84  (defvar *test-simple-contexts* '()
  85    "A list of contexts and their specs."))
  86
  87 (make-variable-buffer-local
  88  (defvar *test-simple-default-tags* "all"))
  89
  90 (defvar test-simple-debug-on-error nil
  91   "If non-nil raise an error on the first failure")
  92
  93 (make-variable-buffer-local
  94  (defvar *test-simple-total-assertions* 0
  95   "Count of number of assertions seen since the last `test-simple-clear-contexts'"
  96   ))
  97
  98 (defstruct context
  99   description
 100   tags
 101   (specs '()) ;; list of its specifications stored as closures.
 102   refreshing-vars)
 103
 104 (put 'test-simple-spec-failed 'error-conditions '(failure))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;; Core Macros
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109
 110 (defun note (description)
 111   "Defines a context for specifications to run in."
 112   (setf (context-description context) description)
 113   (add-to-list '*test-simple-contexts* context))
 114
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116 ;; Assertion tests
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118
 119 (defmacro assert-raises (error-condition body &optional opt-fail-message)
 120   (let ((fail-message (or opt-fail-message
 121                           (format "assert-raises did not get expected %s"
 122                                   error-condition))))
 123     (list 'condition-case nil
 124           (list 'progn body
 125                 (list 'assert-t nil fail-message))
 126           (list error-condition '(assert-t t)))))
 127
 128 (defun assert-equal (expected actual &optional opt-fail-message)
 129   "expectation is that ACTUAL should be equal to EXPECTED."
 130   (if (boundp '*test-simple-total-assertions*)
 131       (incf *test-simple-total-assertions*))
 132   (if (not (equal actual expected))
 133       (let* ((fail-message
 134               (if opt-fail-message
 135                   (format "\n\tMessage: %s" opt-fail-message)
 136                 ""))
 137              (context-mess
 138               (if (boundp 'context)
 139                   (context-description context)
 140                 "unset")))
 141         (signal 'test-simple-spec-failed
 142                 (format
 143                  "Context: %s%s\n\n\tExpected: %s\n\tGot:      %s"
 144                  context-mess
 145                  fail-message expected actual))))
 146   t)
 147
 148 (defun assert-t (actual &optional opt-fail-message)
 149   "expectation is that ACTUAL is not nil."
 150   (assert-nil (not actual) opt-fail-message))
 151
 152 (defun assert-nil (actual &optional opt-fail-message)
 153   "expectation is that ACTUAL is nil."
 154   (incf *test-simple-total-assertions*)
 155   (if actual
 156       (let* ((fail-message
 157               (if opt-fail-message
 158                   (format "\n\tMessage: %s" opt-fail-message)
 159                 ""))
 160              (context-mess
 161               (if (boundp 'context)
 162                   (context-description context)
 163                 "unset")))
 164         (add-failure "assert-nil" context-mess fail-message))
 165     t))
 166
 167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 168 ;; Context-management
 169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 170
 171 (defun test-simple-clear-contexts ()
 172   (interactive)
 173   (setq *test-simple-contexts* '())
 174   (setq *test-simple-total-assertions* 0)
 175   (make-variable-buffer-local (defvar context (make-context)))
 176   (setf (context-description context) "no description set")
 177   (setf (context-specs context) '())
 178   (with-current-buffer (get-buffer-create "*test-simple*")
 179     (let ((old-read-only inhibit-read-only))
 180       (setq inhibit-read-only 't)
 181       (delete-region (point-min) (point-max))
 182       (setq inhibit-read-only old-read-only)))
 183   (message "Test-Simple: contexts cleared"))
 184
 185 (defun add-failure(type context-msg fail-msg)
 186   (let ((failure-line
 187          (format "Context: %s, type %s %s" context-msg type fail-msg))
 188         (old-read-only inhibit-read-only)
 189         )
 190     (save-excursion
 191       (princ "F")
 192       (switch-to-buffer "*test-simple*")
 193       (setq inhibit-read-only 't)
 194       (insert (concat failure-line "\n"))
 195       (overlay-put (make-overlay (point) (- (point) 1))
 196                    'face '(foreground-color . "red"))
 197       (add-to-list 'test-simple-failures failure-line)
 198       (setq inhibit-read-only old-read-only)
 199       (switch-to-buffer nil))
 200     (unless noninteractive
 201       (if test-simple-debug-on-error
 202           (signal 'test-simple-assert-failed failure-line)
 203         (message failure-line)
 204         ))))
 205
 206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 207 ;; Execution
 208 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 209
 210 (defun test-simple (&optional tags)
 211   "Execute all contexts that match given tags"
 212   (interactive)
 213   (let ((tags-string (or tags (read-string (concat "Execute specs matching these tags (default " *test-simple-default-tags* "): ")
 214                                            nil nil *test-simple-default-tags*)))
 215         (start-time (cadr (current-time)))
 216         (failures nil)
 217         (spec-count 0))
 218     (setq *test-simple-default-tags* tags-string) ; update default for next time
 219     (with-output-to-temp-buffer "*test-simple*"
 220       (princ (concat "Running specs tagged \"" tags-string "\":\n\n"))
 221       (dolist (context (context-find-by-tags (mapcar 'intern (split-string tags-string " "))))
 222         (execute-context context))
 223       (test-simple-describe-failures test-simple-failures start-time))
 224     (if noninteractive
 225         (progn
 226           (switch-to-buffer "*test-simple*")
 227           (message "%s" (buffer-substring (point-min) (point-max)))))
 228     (length test-simple-failures)))
 229
 230 (defun execute-context (context)
 231   (condition-case failure
 232       (mapcar #'execute-spec (reverse (context-specs context)))
 233     (error (princ "E")
 234            (switch-to-buffer "*test-simple*")
 235            (overlay-put (make-overlay (point) (- (point) 1)) 'face '(foreground-color . "red"))
 236            (switch-to-buffer nil)
 237            (add-to-list 'failures (list "Error:" failure) t))
 238     (failure (princ "F")
 239              (switch-to-buffer "*test-simple*")
 240              (overlay-put (make-overlay (point) (- (point) 1)) 'face '(foreground-color . "red"))
 241              (switch-to-buffer nil)
 242              (add-to-list 'failures (cdr failure) t))))
 243
 244 (defun execute-spec (spec)
 245   (incf spec-count)
 246   (funcall spec)
 247   (princ "."))
 248
 249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 250 ;; Reporting
 251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 252
 253 (defun test-simple-describe-failures (failures start-time)
 254   (princ (concat "\n\n" (number-to-string (length failures)) " problem"
 255                  (unless (= 1 (length failures)) "s") " in "
 256                  (number-to-string spec-count)
 257                  " specification" (unless (= 1 spec-count) "s")
 258                  " using " (number-to-string *test-simple-total-assertions*) " assertions. "
 259                  "(" (number-to-string (- (cadr (current-time)) start-time)) " seconds)\n\n"))
 260   (dolist (failure failures)
 261     (test-simple-report-result failure)))
 262
 263 (defun test-simple-report-result (failure)
 264   (princ failure)
 265   (princ "\n\n"))
 266
 267 (provide 'test-simple)
 268 ;;; test-simple.el ends here