Fetching contributors…
Cannot retrieve contributors at this time
456 lines (402 sloc) 15.4 KB
;;; test.el --- Unit test framework for Emacs lisp program
;; Copyright (C) 2008 by Wang Liang
;; Author: Wang Liang <>
;; test.el is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; test.el is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Download
;; Latest version is at
;; You can check out with subversion.
;; $ svn co
;;; Screenshot
;;; Usage
;; Overview
;; This unit test framework is developed for testing operations on a buffer.
;; But it definitely can be used to test operations unrelated to buffers.
;; For example, I write `my-buffer-substring'. I also have a file and if it
;; is loaded into a buffer and run (my-buffer-substring 10 22) on that buffer,
;; it must return "hello, world". To test it, I can write a test case with
;; this framework,
;; (defun my-buffer-substring-setup ()
;; (insert-file-contents "my-file"))
;; (defcase my-buffer-substring-test nil 'my-buffer-substring-setup
;; (test-assert-string-equal (my-buffer-substring 10 22) "hello, world"))
;; And then run it by invoking
;; `M-x test-run-one-case MY-BUFFER-SUBSTRING-TEST'.
;; is an example of usage.
;; To use this framework, add the following lines to your .emacs file
;; (add-to-list 'load-path "/path/to/test/")
;; (require 'test)
;; Write test cases
;; Test case is written with `defcase' macro. For example,
;; (defcase my-code-test nil nil
;; (test-assert-ok (my-fun)))
;; This test case includes one assertion but no tags and no setup code.
;; It checks return value of `my-fun'. If it's `nil', case fails.
;; Otherwise, case passes. You can add more assertions into one case.
;; Besides `test-assert-ok', `test-assert-key' is used to assert that a key
;; is bound to a function in a mode-map. For example,
;; (test-assert-key example-mode-map (kbd "C-c C-c") 'example-function)
;; Assertion for binary comparison or prediction is much more flexible.
;; You can use `test-assert-CMP' if `CMP', either provided by Emacs or
;; written by you, accepts more than two parameters. All those assertions
;; fallback to `test-assert-binary-relation' function so that I do not need
;; to write them as many as possible. Since `test-assert-binary-relation'
;; only considers first two parameters, others are ignored.
;; You can develop your own assertions by using "test-assert-extended-" as
;; function name prefix. For example You develop `test-assert-extended->'
;; to compare many numbers since `test-assert->' only compares two. Inside
;; your own assertion function, you should use `assert' from `cl' package to
;; do real job.
;; Test cases can be grouped with tags so that you can run them with one
;; command. To add tags to the previous test case,
;; (defcase my-code-test (my-lib-suite my-lib-sublib-suite) nil
;; (test-assert-ok (my-fun)))
;; All test cases are run in a temporary buffer. You can setup buffer
;; content by providing `setup' code. For example,
;; (defun my-lib-setup ()
;; (insert-file-contents "my-input-filename")
;; (my-mode))
;; (defcase my-code-test (my-lib my-lib-sublib) 'my-lib-setup
;; (test-assert-ok (my-fun)))
;; You probably want to add a common tag to all your test case for a specific
;; package, and add a common setup code too. So you can write your own macro
;; to make it easy to develop test cases. For example,
;; (defmacro defmylibcase (case-name tags &rest body)
;; `(defcase ,case-name ,(append '(my-lib-suite) tags) 'my-lib-setup
;; ,@body))
;; And then,
;; (defmylibcase my-code-test-2 (my-lib-sublib-suite)
;; (test-assert-ok (my-fun)))
;; Run test cases
;; `M-x test-run-one-case CASE' runs one test case.
;; `M-x test-run-all-cases' runs all test cases stored in `test-cases'.
;; `M-x test-run-one-tag TAG' runs all test cases grouped by TAG.
;; `(test-run-tags TAGS)' runs all test cases grouped by one of TAGS.
;; Test result, including detail error message and summary, is shown in
;; buffer `*test-result*'.
;; Every test case has a summary line to show how many cases pass and how
;; many cases fail. There are also a summary line to show total number of
;; pass and failure for all commands except `test-run-one-case'.
;; Error message is helpful. If assertion fails, `test-assert-ok' prints
;; evaluated form, `test-assert-binary-relation' prints what is got and why
;; it failed.
;;; Code
(require 'cl)
(defconst test-version "0.9"
"test version")
(defun test-version ()
"Show test version."
(message "test version %s" test-version))
(defvar test-cases (make-hash-table)
"All case in all tags")
(defvar test-tags (make-hash-table)
"All tags from all test cases")
(defvar test-special-assertion-functions '(test-assert-ok test-assert-key)
"Assertion functions must not fallback to `test-assert-binary-relation'.")
(defun test-completing-read (prompt choices dummy require-match)
"Use iswitchb completion functionality."
(let ((iswitchb-make-buflist-hook
(lambda ()
(setq iswitchb-temp-buflist choices))))
(iswitchb-read-buffer prompt nil require-match)))
(defvar test-completing-read-function
(if (fboundp 'iswitchb-read-buffer) 'test-completing-read 'completing-read))
(defvar test-assert-method-prefix "test-assert-"
"Prefix of test-assert methods.")
(defvar test-assert-extended-prefix "test-assert-extended-"
"Prefix of user-extended test-assert methods.")
(defun test-assert-p (test)
"Return non-nil if TEST is an assertion."
(let ((method-name (symbol-name (car test))))
(string-equal test-assert-method-prefix
(substring method-name
(min (length test-assert-method-prefix)
(length method-name))))))
(defun test-special-assert-p (test)
"Return non-nil if TEST is `test-assert-ok' or user-extended assertion."
(or (memq (car test) test-special-assertion-functions)
(let ((method-name (symbol-name (car test))))
(string-equal test-assert-extended-prefix
(substring method-name
(min (length test-assert-extended-prefix)
(length method-name)))))))
(defun test-report-error (test error)
"Print form TEST and error message from ERROR."
(princ "# ")
(prin1 test)
(princ "\n")
(let* ((msg (error-message-string error))
(from-here (string-equal
"# " (substring msg 0 5))))
(unless from-here
(princ "# "))
(princ msg)
(unless from-here)
(princ "\n"))
(princ "# \n"))
(defun test-gensym (&optional prefix)
"Generate uninterned symbol.
If PREFIX is non-nil, use it as prefix. Otherwise, use \"--test--\"."
(gensym (or prefix "--test--")))
(defun test-transform-body (body fail succ err &optional not-toplevel)
"This function transforms the BODY, which is a body of defcase,
recursively to alternate `test-assert-*' to apropriate
(if (not (listp body))
(lambda (arg)
(cond ((not (listp arg))
((not (test-assert-p arg))
(let ((arg (cond
((listp arg)
(test-transform-body arg fail succ err t))
(t arg))))
(if not-toplevel
`(condition-case ,err
;; do not count as success
(error (incf ,fail) ; but count as failure
(test-report-error ',arg ,err))))))
((test-special-assert-p arg)
`(condition-case ,err
(incf ,succ))
(error (incf ,fail)
(test-report-error ',arg ,err))))
`(condition-case ,err
;; function to test binary relation
(symbol-name (car arg))
(length test-assert-method-prefix)))
;; parameters to above function
,@(cdr arg))
(incf ,succ))
(error (incf ,fail)
(test-report-error ',arg ,err))))))
(defmacro defcase (case-name tags setup &rest body)
"Define test case which includes one or multiple assertions."
(let ((tag (test-gensym))
(tag-cases (test-gensym))
(fail (test-gensym))
(succ (test-gensym))
(err (test-gensym)))
(assert (and (listp ',tags)
(or (null ',tags)
(every 'symbolp ',tags)))
;; `show-args' can not be `t' since `assert' will
;; evaluate EVERY parameter of `and'. This breaks
;; short-circuit effect of `and'.
"Tags must be nil or a list of symbols.")
;; Associate case with every tag, and push tags into hash table.
(dolist (,tag ',tags)
(when ,tag
(let ((,tag-cases (gethash ,tag test-tags '())))
(add-to-list ',tag-cases ',case-name)
(puthash ,tag ,tag-cases test-tags))))
;; Push function, which runs test case and returns `(pass-count
;; fail-count)', into hash table.
(puthash ',case-name
(lambda ()
(let ((,fail 0)
(,succ 0))
(when ,setup
(funcall ,setup))
;; transform `body' of macro during expansion time.
,@(test-transform-body body fail succ err)
;; summarize
(princ (format "%s: %d pass, %d fail."
(symbol-name ',case-name)
,succ ,fail))
(princ "\n"))
;; return value
(list ,succ ,fail)))
(defun test-princ-current-time ()
"Print start time to run test cases."
(princ "# ")
(princ (current-time-string))
(princ "\n"))
(defmacro test-report (&rest body)
"Show test report in buffer `*test-result*'."
(with-output-to-temp-buffer "*test-result*"
(with-current-buffer "*test-result*"
(defun test-run (cases)
"Run test cases in CASES."
(dolist (case-name (test-args-to-list cases))
(funcall (gethash case-name test-cases))))
(defvar test-last-summary nil)
(defun test-run-and-summarize (cases)
"Run test cases in CASES and print summary."
(let ((total-succ 0)
(total-fail 0))
(dolist (case-name (test-args-to-list cases))
(let ((summary (funcall (gethash case-name test-cases))))
(incf total-succ (car summary))
(incf total-fail (cadr summary))))
(setq test-last-summary
`((succ . ,total-succ) (fail . ,total-fail)))
(princ "# ")
(princ (format "Total: %d pass, %d fail." total-succ total-fail))))
(defun test-args-to-list (args)
"Make sure ARGS is a list."
(if (listp args)
(list args)))
(defun test-find-all-cases (tags)
"Return all test cases grouped by TAGS.
This function guarantees that no duplicated cases in return value."
(let ((tag-list (test-args-to-list tags))
(cases '()))
(dolist (tag tag-list)
(dolist (test-case (gethash tag test-tags))
(add-to-list 'cases test-case)))
(defun test-maphashkey (fn hashtable)
"Call FN on each key of hash table HASHTABLE and return a list of result."
(let ((keys '()))
(maphash (lambda (key value)
(add-to-list 'keys (funcall fn key)))
(defun test-find-all-case-names (&optional tag)
"Return all case names, or name of cases grouped by TAG if TAG is non-nil, as a list."
(if tag
(mapcar 'symbol-name (test-find-all-cases tag))
(test-maphashkey 'symbol-name test-cases)))
(defun test-find-all-tag-names ()
"Return all tag names as a list."
(test-maphashkey 'symbol-name test-tags))
(defun test-completing-read-one (prompt choice)
"Read a string and return a symbol whose name is the string being read."
;; Better to read a tag symbol directly.
(intern (funcall test-completing-read-function prompt choice nil t)))
(defun test-completing-read-one-tag ()
"Read a tag name and return corresponding tag symbol."
(test-completing-read-one "Tag: " (test-find-all-tag-names)))
(defun test-completing-read-one-case (&optional tag)
"Read a case name and return corresponding case symbol. If TAG is non-nil, only cases grouped by it is allowed."
(test-completing-read-one "Case name: " (test-find-all-case-names tag)))
(defun test-run-one-tag (tag-name)
"Run test cases grouped by tag TAG-NAME."
(interactive (list (test-completing-read-one-tag)))
(test-report (princ "# Tag: ") (princ tag-name) (princ "\n")
(test-run-and-summarize (test-find-all-cases tag-name))))
(defun test-run-tags (&rest tags)
"Run all test cases grouped by TAGS."
(test-report (princ "# Tags: ")
(princ (mapconcat 'symbol-name tags " "))
(princ "\n")
(test-run-and-summarize (test-find-all-cases tags))))
(defun test-run-one-case (case-name)
"Run one test case whose name is CASE-NAME."
(interactive (list (test-completing-read-one-case)))
(test-report (test-run case-name)))
(defun test-run-all-cases ()
"Run all test cases saved in TEST-CASES."
(test-report (test-run-and-summarize (test-maphashkey 'identity test-cases))))
(defmacro test-motion-target (&rest body)
"Return position after motion."
;;; Special assertions
(defun test-assert-ok (form)
"Assert that FORM returns non-nil."
(assert form nil
(princ "# not ok: ")
(prin1 form))))
(defun test-assert-key (mode-map kbd function)
"Assert that KBD is binding to FUNCTION in MODE-MAP."
(let ((got (lookup-key mode-map kbd)))
(assert (eq got function)
(princ "# got: ")
(prin1 got)
(princ "\n")
(princ "# not bound to: ")
(prin1 function)))))
;;; Assertion for binary comparison or prediction.
(defun test-assert-binary-relation (fn got expected)
"Fallback function to assert all binary relation between GOT and EXPECTED with FN."
(assert (funcall fn got expected)
(princ "# got: ")
(prin1 got)
(princ "\n")
(princ "# not ")
(prin1 fn)
(princ ": ")
(prin1 expected))))
;;; `test-result-mode'
(defvar test-result-font-lock-keywords
`(("^\\(# got: \\)\\(.*\\)$"
(1 font-lock-preprocessor-face) (2 font-lock-warning-face))
("^\\(# not ok: \\)\\(.*\\)$"
(1 font-lock-preprocessor-face) (2 font-lock-warning-face))
("^\\(# .*?: \\)\\(.*\\)$"
(1 font-lock-preprocessor-face) (2 font-lock-type-face))
;; be careful about the order
("^# .*$" . font-lock-preprocessor-face)
("^\\(.*\\): \\([0-9]+\\) pass, \\([0-9]+\\) fail.$"
(1 font-lock-function-name-face) (2 font-lock-type-face) (3 font-lock-warning-face)))
"Font lock for `test-result-mode'.")
(defconst test-result-font-lock-defaults
'(test-result-font-lock-keywords t nil nil nil (font-lock-multiline . nil)))
(define-derived-mode test-result-mode nil "Test-Result"
(set (make-local-variable 'font-lock-defaults) test-result-font-lock-defaults))
(provide 'test)