Skip to content
This repository
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 456 lines (402 sloc) 15.755 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
;;; test.el --- Unit test framework for Emacs lisp program
;; Copyright (C) 2008 by Wang Liang

;; Author: Wang Liang <netcasper@gmail.com>

;; 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; 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 http://www.wanglianghome.org/svn/test/test.el
;; You can check out with subversion.
;; $ svn co http://www.wanglianghome.org/svn/test/

;;; Screenshot
;; http://www.wanglianghome.org/images/test.png

;;; 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'.
;;
;; http://www.wanglianghome.org/svn/test/example.el 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."
  (interactive)
  (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
0
(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
0
(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
expressions"
  (if (not (listp body))
      body
    (mapcar
     (lambda (arg)
       (cond ((not (listp arg))
arg)
((not (test-assert-p arg))
(let ((arg (cond
((listp arg)
(test-transform-body arg fail succ err t))
(t arg))))
(if not-toplevel
arg
`(condition-case ,err
;; do not count as success
,arg
(error (incf ,fail) ; but count as failure
(test-report-error ',arg ,err))))))
((test-special-assert-p arg)
`(condition-case ,err
(progn
,arg
(incf ,succ))
(error (incf ,fail)
(test-report-error ',arg ,err))))
(t
`(condition-case ,err
(progn
(test-assert-binary-relation
;; function to test binary relation
',(intern
(substring
(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))))))
     body)))

(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)))
    `(progn
       (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'.
nil
"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))
(with-temp-buffer
(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)))
test-cases))))

(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*'."
  `(progn
     (with-output-to-temp-buffer "*test-result*"
       (test-princ-current-time)
       ,@body)
     (with-current-buffer "*test-result*"
       (test-result-mode))))

(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)
      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)))
    cases))

(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)))
hashtable)
    keys))

(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."
  (interactive)
  (test-report (test-run-and-summarize (test-maphashkey 'identity test-cases))))

(defmacro test-motion-target (&rest body)
  "Return position after motion."
  `(progn
     ,@body
    (point)))

;;; Special assertions
(defun test-assert-ok (form)
  "Assert that FORM returns non-nil."
  (assert form nil
(with-output-to-string
(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)
t
(with-output-to-string
(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)
t
(with-output-to-string
(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)
Something went wrong with that request. Please try again.