1;;  Filename : unittest.scm
2;;  About    : Simple unit test library
3;;
4;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
5;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
6;;
7;;  All rights reserved.
8;;
9;;  Redistribution and use in source and binary forms, with or without
10;;  modification, are permitted provided that the following conditions
11;;  are met:
12;;
13;;  1. Redistributions of source code must retain the above copyright
14;;     notice, this list of conditions and the following disclaimer.
15;;  2. Redistributions in binary form must reproduce the above copyright
16;;     notice, this list of conditions and the following disclaimer in the
17;;     documentation and/or other materials provided with the distribution.
18;;  3. Neither the name of authors nor the names of its contributors
19;;     may be used to endorse or promote products derived from this software
20;;     without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
23;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
24;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
25;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
26;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
27;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
28;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33
34;; This unit-testing library should be replaced with standard SRFI-64 once the
35;; hygienic-macros are well-implemented. To write new tests, use the SRFI-64
36;; compatible assertions contained at the bottom of this file.
37;;   -- YamaKen 2007-09-01
38
39(cond-expand
40 (sigscheme
41  ;; To allow --disable-srfi55, don't use require-extension here.
42  (%%require-module "srfi-6")
43  (%%require-module "srfi-23")
44  (%%require-module "srfi-34"))
45 (else))
46
47(define *test-track-progress* #f)  ;; for locating SEGV point
48(define *total-testsuites* 1)  ;; TODO: introduce test suites and defaults to 0
49(define *total-testcases* 1)   ;; TODO: introduce testcase and defaults to 0
50(define *total-tests* 1)       ;; TODO: introduce test group and defaults to 0
51(define *total-failures*  0)
52(define *total-assertions* 0)
53(define *total-errors* 0) ;; TODO: recover unintended error and increment this
54(define test-filename "unspecified")
55
56(define test-display-result
57  (lambda ()
58    (let ((header (if (zero? *total-failures*)
59                      "OK: "
60                      "FAILED: "))
61          (total-successes (- *total-assertions* *total-failures*)))
62      (for-each display
63                (list
64                 header
65                 *total-tests*      " tests, "
66                 *total-assertions* " assertions, "
67                 total-successes    " successes, "
68                 *total-failures*   " failures, "
69                 *total-errors*     " errors"))
70      (newline))))
71
72(define test-report-result
73  (lambda ()
74    (test-display-result)
75    (let ((EX_OK       0)
76          (EX_SOFTWARE 70))
77      (exit (if (positive? *total-failures*)
78                EX_SOFTWARE
79                EX_OK)))))
80
81;; Backward compatibility
82(define total-report test-report-result)
83
84(define report-error
85  (lambda (err-msg)
86    (begin
87      (display "failed: ")
88      (display err-msg)
89      (newline))))
90
91(define report-inequality
92  (lambda (expected actual)
93    (display " expected: <")
94    (write expected)
95    (display ">")
96    (newline)
97    (display "   actual: <")
98    (write actual)
99    (display ">")
100    (newline)))
101
102(define assert
103  (let ((+ +))  ;; protect from redefinition
104    (lambda (test-name err-msg exp)
105      (set! *total-assertions* (+ *total-assertions* 1))
106      (if *test-track-progress*
107          (begin
108            (display "done: ")
109            (display test-name)
110            (newline)))
111      (if exp
112          #t
113          (begin
114            (set! *total-failures* (+ *total-failures* 1))
115            (report-error err-msg)
116            #f)))))
117
118(define test-skip
119  (lambda (reason)
120    (display "SKIP: ")
121    (display reason)
122    (newline)
123    (exit 77)))  ;; special code for automake
124
125;;
126;; assertions for test writers
127;;
128
129(define assert-fail
130  (lambda (test-name err-msg)
131    (assert test-name err-msg #f)))
132
133(define assert-true
134  (lambda (test-name exp)
135    (assert test-name test-name exp)))
136
137(define assert-false
138  (lambda (test-name exp)
139    (assert test-name test-name (not exp))))
140
141(define assert-eq?
142  (lambda (test-name expected actual)
143    (or (assert test-name test-name (eq? expected actual))
144        (report-inequality expected actual))))
145
146(define assert-equal?
147  (lambda (test-name expected actual)
148    (or (assert test-name test-name (equal? expected actual))
149        (report-inequality expected actual))))
150
151(define assert-error
152  (lambda (test-name proc)
153    (or (procedure? proc)
154        (error "assert-error: procedure required but got" proc))
155    (let ((errored (guard (err
156                           (else
157                            #t))
158                     (proc)
159                     #f))
160          (err-msg (string-append "no error has occurred in test "
161                                  test-name)))
162      (assert test-name err-msg errored))))
163
164(define assert-parse-error
165  (lambda (test-name str)
166    (assert-error test-name (lambda ()
167                              (string-read str)))))
168
169(define assert-parseable
170  (lambda (test-name str)
171    (assert-true test-name (guard (err
172                                   (else
173                                    #f))
174                             (string-read str)
175                             #t))))
176
177;;
178;; misc
179;;
180
181;; SigScheme and Gauche surely returns #<undef>
182(define undef
183  (lambda ()
184    (for-each values '())))
185
186;; SigScheme and Gauche surely returns #<eof>
187(define eof
188  (lambda ()
189    (string-read "")))
190
191(define obj->literal
192  (lambda (obj)
193    (let ((port (open-output-string)))
194      (write obj port)
195      (get-output-string port))))
196
197(define string-read
198  (lambda (str)
199    (let ((port (open-input-string str)))
200      (read port))))
201
202(define string-eval
203  (lambda (str)
204    (eval (string-read str)
205          (interaction-environment))))
206
207(define test-name
208  (let ((name "anonymous test")
209        (serial 0)
210        (+ +))  ;; protect from redefinition
211    (lambda args
212      (if (null? args)
213          (begin
214            (set! serial (+ serial 1))
215            (string-append name " #" (number->string serial)))
216          (begin
217            (set! name (car args))
218            (set! serial 0)
219            #f)))))
220
221(define print-expected
222  (lambda (expected)
223    (display " expected print: ")
224    (display expected)
225    (newline)
226    (display "   actual print: ")))
227
228
229;;
230;; implementation information
231;;
232
233(define sigscheme? (provided? "sigscheme"))
234
235(define fixnum-bits (and (symbol-bound? 'fixnum-width)
236                         (fixnum-width)))
237
238
239;;
240;; SRFI-64 compatibilities
241;;
242
243;; See test-unittest.scm to understand how to use these.
244
245(cond-expand
246 (sigscheme
247  ;; To allow --disable-srfi55, don't use require-extension here.
248  (%%require-module "sscm-ext"))
249 (else))
250
251(define-macro test-begin
252    (lambda (suite-name . opt-count)
253      (let-optionals* opt-count ((count #f))
254        `(test-name ,suite-name))))
255
256(define-macro test-end
257  (lambda args
258    (let-optionals* args ((suite-name #f))
259      '#f)))
260
261(define-macro test-assert
262  (lambda (first . rest)
263    (let-optionals* (reverse (cons first rest)) ((expr #f)
264                                                 (tname '(test-name)))
265      `(assert-true ,tname ,expr))))
266
267(define-macro test-equal
268  (lambda args
269    `(%test-equal equal? . ,args)))
270
271(define-macro test-eqv
272  (lambda args
273    `(%test-equal eqv? . ,args)))
274
275(define-macro test-eq
276  (lambda args
277    `(%test-equal eq? . ,args)))
278
279(define-macro %test-equal
280  (lambda (= second third . rest)
281    (let-optionals* (if (null? rest)
282                        (list '(test-name) second third)
283                        (cons second (cons third rest)))
284        ((tname #f)
285         (expected #f)
286         (expr #f))
287      `(%test-equal2 ,= ,tname ,expected ,expr))))
288
289(define %test-equal2
290  (lambda (= tname expected actual)
291    (or (assert tname tname (= expected actual))
292        (report-inequality expected actual))))
293
294(define-macro test-error
295  (lambda (first . rest)
296    (let-optionals* (reverse (cons first rest)) ((expr #f)
297                                                 (err-type #t)
298                                                 (tname '(test-name)))
299      `(assert-error ,tname
300                     (lambda ()
301                       (eval ',expr (interaction-environment)))))))
302
303(define test-read-eval-string
304  (lambda (str)
305    (let* ((port (open-input-string str))
306           (expr (read port)))
307      (if (or (eof-object? expr)
308              (guard (err
309                      (else #t))
310                (not (eof-object? (read-char port)))))
311          (error "invalid expression string" str))
312      (eval expr (interaction-environment)))))
313
314
315;;
316;; Non-standard SRFI-64-like assertions
317;;
318
319;; I think that writing (test-assert <exp>) and (test-assert (not <exp>)) is
320;; cumbersome.  -- YamaKen 2007-09-04
321
322(define-macro test-true
323  (lambda args
324    `(test-assert . ,args)))
325
326(define-macro test-false
327  (lambda (first . rest)
328    (let-optionals* (reverse (cons first rest)) ((expr #f)
329                                                 (tname '(test-name)))
330      `(test-assert ,tname (not ,expr)))))
331