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