62 lines
1.7 KiB
Common Lisp
62 lines
1.7 KiB
Common Lisp
;;;; cl-scopes/testing
|
|
|
|
;;;; simple testing library
|
|
|
|
(defpackage :scopes/testing
|
|
(:use :common-lisp)
|
|
(:export #:*test-suite*
|
|
#:test-suite #:deftest #:show-result
|
|
#:failure #:test #:== #:has-prefix
|
|
#:test-path #:*current-system*))
|
|
|
|
(in-package :scopes/testing)
|
|
|
|
(defvar *test-suite* nil)
|
|
(defparameter *current-system* :scopes)
|
|
|
|
(defclass test-suite ()
|
|
((name :reader name :initform "test" :initarg :name)
|
|
(errors :accessor errors :initform nil)
|
|
(result :accessor result :initform nil)))
|
|
|
|
(defun test-suite (&optional (name "test"))
|
|
(make-instance 'test-suite :name name))
|
|
|
|
(defun show-result ()
|
|
(let ((suite *test-suite*))
|
|
(format t "~%=== ~a Tests ===~%" (name suite) )
|
|
(dolist (res (reverse (result suite)))
|
|
(let ((tst (reverse res)))
|
|
(format t "~a: ~a~%" (car tst) (cdr tst))))
|
|
(if (errors suite)
|
|
(format t "*** errors: ~a~%" (reverse (errors suite)))))
|
|
(values))
|
|
|
|
(defun failure (fmt &rest vals)
|
|
(push (apply #'format nil fmt vals) (errors *test-suite*)))
|
|
|
|
(defun == (have wanted)
|
|
(let ((suite *test-suite*)
|
|
(is-ok (equalp have wanted)))
|
|
(push is-ok (car (result suite)))
|
|
(unless is-ok
|
|
(failure "~s!=~s" have wanted))))
|
|
|
|
(defun has-prefix (have wanted)
|
|
(let ((suite *test-suite*)
|
|
(is-ok (string= (str:prefix (list have wanted)) wanted)))
|
|
(push is-ok (car (result suite)))
|
|
(unless is-ok
|
|
(failure "~s has not prefix ~s" have wanted))))
|
|
|
|
(defmacro deftest (name args &body body)
|
|
`(defun ,name ,args
|
|
(push '(,name) (result *test-suite*))
|
|
,@body))
|
|
|
|
;;;; utilities
|
|
|
|
(defun test-path (name &rest dirs)
|
|
(apply #'scopes/util:system-path *current-system* name "test" dirs))
|
|
|
|
|