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
|
;;;
;;; based on euslib/jsk/unittest.l by R.Ueda
;;;
(load "lib/llib/time.l")
(defmethod interval-time
(:elapsed (tint)
(let ((sub (send self :subtract tint)))
(+ (float (send sub :second)) (* 0.000001 (send sub :micro))))))
(defvar *unit-test* nil)
(defun escape-xml-string (str1)
(let* ((str2 (make-string (+ (length str1)
(* (count #\< str1) 3)
(* (count #\> str1) 3)
(* (count #\& str1) 4)))))
(do ((i1 0 (1+ i1))
(i2 0 (1+ i2)))
((>= i1 (length str1)))
(cond ((eq (elt str1 i1) #\<)
(setf (elt str2 i2) #\&) (incf i2)
(setf (elt str2 i2) #\l) (incf i2)
(setf (elt str2 i2) #\t) (incf i2)
(setf (elt str2 i2) #\;))
((eq (elt str1 i1) #\>)
(setf (elt str2 i2) #\&) (incf i2)
(setf (elt str2 i2) #\g) (incf i2)
(setf (elt str2 i2) #\t) (incf i2)
(setf (elt str2 i2) #\;))
((eq (elt str1 i1) #\&)
(setf (elt str2 i2) #\&) (incf i2)
(setf (elt str2 i2) #\a) (incf i2)
(setf (elt str2 i2) #\m) (incf i2)
(setf (elt str2 i2) #\p) (incf i2)
(setf (elt str2 i2) #\;))
((eq (elt str1 i1) 27)
(setf (elt str2 i2) #\^))
(t
(setf (elt str2 i2) (elt str1 i1))))
)
str2))
(defun unittest-error (code msg1 form &optional (msg2))
(format *error-output* "~C[1;3~Cm~A unittest-error: ~A"
#x1b (+ 1 48) *program-name* msg1)
(if msg2 (format *error-output* " ~A" msg2))
(if form (format *error-output* " in ~s" form))
(format *error-output* ", exitting...~C[0m~%" #x1b)
(when (*unit-test* . result) ;; force put error code into all-test
(push 'all-test (unit-test-result-tests (car (last (*unit-test* . result)))))
(push (list form msg1 code) (unit-test-result-failures (car (last (*unit-test* . result))))))
(when code
(format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 form)
(format *error-output* " ... (~A ~A)" msg1 code)
(format *error-output* ".~C[0m~%" #x1b))
(send *unit-test* :print-result :if-exists :overwrite)
(if lisp::*exit-on-fatal-error* (exit 1)))
(defun unittest-sigint-handler (sig code)
(format *error-output* "unittest-sigint-handler ~A~%" sig)
(when (*unit-test* . result) ;; force put error code into all-test
(push 'all-test (unit-test-result-tests (car (last (*unit-test* . result)))))
(push (list "" (format nil "signal-handler ~A" sig) code) (unit-test-result-failures (car (last (*unit-test* . result))))))
(send *unit-test* :print-result :if-exists :overwrite)
(if lisp::*exit-on-fatal-error* (exit 1)))
(defclass unit-test-result
:super propertied-object
:slots (name tests failures time))
(defmethod unit-test-result
(:init (n) (setq name n tests nil failures nil time 0))
(:tests () tests)
(:num-tests () (length tests))
(:num-failures () (if failures 1 0))
(:num-successes () (- (send self :num-tests) (send self :num-failures)))
(:time () time)
(:prin1
(strm)
(format strm "RESULT: ~A~%" name)
(format strm " TEST-NUM: ~A~%" (send self :num-tests))
(format strm " PASSED: ~A~%" (send self :num-successes))
(if (> (send self :num-failures) 0)
(format strm "~C[3~Cm" #x1b 49))
(format strm " FAILURE: ~A" (send self :num-failures))
(if (> (send self :num-failures) 0)
(format strm "~C[0m~%" #x1b)
(format strm "~%"))
)
(:prin1-xml
(strm)
(format strm " <testcase name=\"~s\" status=~s time=\"~d\" classname=\"~s\">~%" name "run" time name)
(dolist (ret failures)
(let ((test (elt ret 0))
(msg (elt ret 1))
(trace (elt ret 2)))
(when trace
(format strm " <failure message=~s type=\"AssertionError\">~%" (escape-xml-string msg))
(format strm "Test:~A~%" (escape-xml-string (prin1-to-string test)))
(format strm "Trace:~A~%" (escape-xml-string (prin1-to-string trace)))
(format strm "Message:~A~%" (escape-xml-string (prin1-to-string msg)))
(format strm " </failure>~%"))))
(format strm " </testcase>~%")
)
)
(defclass unit-test-container
:super propertied-object
:slots (result functions log-fname output-mode))
(defmethod unit-test-container
(:init
(&key ((:log-fname fname)))
(setq result nil)
(setq functions nil)
(setq log-fname fname)
(when log-fname
(warning-message 3 "output to ~A~%" log-fname)
(setq output-mode :xml))
self)
(:functions () (reverse functions))
(:result () result)
;;
(:add-function (name) (push name functions))
(:increment-test
(test)
(if result (push test (unit-test-result-tests (car result)))))
(:increment-failure
(test msg trace)
(if result (push (list test msg trace) (unit-test-result-failures (car result))))
(when trace
(format *error-output* "~C[3~Cm[ERROR] test ~A failed" #x1b 49 test)
(format *error-output* " ... (~A ~A)" msg trace)
(format *error-output* ".~C[0m~%" #x1b)))
(:set-time-to-current-result
(time) ;; msec
(if result (setf (unit-test-result-time (car result)) (round time))))
(:init-result
(func-sym)
(push (instance unit-test-result :init func-sym) result))
(:clear-result ()
(setq result nil)
(send self :init-result 'all-test)
;(send self :increment-test 'all-test)
)
;;
(:print-xml-result
(&optional (strm t))
(let ((all-tests (apply #'+ (send-all result :num-tests)))
(all-failures (apply #'+ (send-all result :num-failures)))
(all-times (apply #'+ (send-all result :time))))
(format strm "<testsuite tests=\"~d\" failures=\"~d\" disabled=\"~d\" errors=\"~d\" time=\"~d\" name=\"AllTests\">~%" all-tests all-failures 0 0 all-times)
(dolist (r (reverse result)) (send r :prin1-xml strm))
(format strm "</testsuite>~%")
))
(:print-normal-result
(&optional (strm t))
(let ((all-tests (apply #'+ (send-all result :num-tests)))
(all-successes (apply #'+ (send-all result :num-successes)))
(all-failures (apply #'+ (send-all result :num-failures))))
(format strm "ALL RESULTS:~%")
(format strm " TEST-NUM: ~A~%" all-tests)
(format strm " PASSED: ~A~%" all-successes)
(if (> all-failures 0)
(format strm "~C[3~Cm" #x1b 49))
(format strm " FAILURE: ~A~%" all-failures)
(if (> all-failures 0)
(format strm "~C[0m" #x1b))
(dolist (r (reverse result)) (prin1 r strm))
))
(:print-result
(&key (if-exists :append))
(send self :print-normal-result)
(when (and result (eq output-mode :xml))
(let ((strm (open log-fname :direction :output
:if-exists if-exists
:if-does-not-exist :create)))
(send self :print-xml-result strm)
(close strm))))
)
(defmacro deftest (name &rest body)
`(progn
;; its not cool...
(defun ,name ()
(warning-message 2 "start testing [~A]~%" ',name)
,@body)
(send *unit-test* :add-function ',name)
',name))
(defun run-test (func-sym)
(let ((func (symbol-function func-sym)) tm)
;; initilize result
(send *unit-test* :init-result func-sym)
(format t "TEST-NAME: ~A~%" func-sym)
(format t " now testing...~%")
(send *unit-test* :increment-test func-sym)
(setq tm (now))
(funcall func)
(send *unit-test* :set-time-to-current-result (send (now) :elapsed tm))))
(defun run-all-tests ()
;; initalize *unit-test-result*
(send *unit-test* :clear-result)
(dolist (u (send *unit-test* :functions))
(run-test u))
(send *unit-test* :print-result)
;; exit with error status (1), if there are any failure in tests.
(dolist (r (send *unit-test* :result))
(if (/= (send r :num-failures) 0)
(exit 1)))
t)
(defun init-unit-test (&key log-fname trace)
(let* ((p "--gtest_output=xml:")
(s (find-if #'(lambda (tmpx) (substringp p tmpx)) lisp::*eustop-argument*))
(xml-fname (if s (string-left-trim p s))))
(if xml-fname (setq log-fname xml-fname))
(setq lisp::*exit-on-fatal-error* t)
(lisp::install-error-handler 'unittest-error)
(unix:signal unix::sigint 'unittest-sigint-handler)
(unix:signal unix::sighup 'unittest-sigint-handler)
(setq *unit-test* (instance unit-test-container :init :log-fname log-fname))
(when trace
(setf (symbol-function 'defun-org) (symbol-function 'defun))
(defmacro defun (name args &rest body)
`(prog1
(defun-org ,name ,args ,@body)
(trace ,name))))
(defmacro assert (pred &optional (message "") &rest args)
`(let (failure (ret ,pred))
;; lisp::step could not work with macros..
;; (if (and (listp ',pred) (functionp (car ',pred)))
;; (setq ret (lisp::step ,pred))
;; (setq ret ,pred))
;;
(if (not ret)
;; escape <> for xml
(send *unit-test* :increment-failure ',pred (format nil ,message ,@args)
(escape-xml-string (subseq (send *error-output* :buffer) 0 (or (position 0 (send *error-output* :buffer)) (length (send *error-output* :buffer)))))))
))
t))
(provide :unittest)
|
