/usr/share/scsh-0.6/scsh/test-base.scm is in scsh-common-0.6 0.6.7-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | ;;; Basic functions for the scsh-test-suite
;;; Author: 2001 David Frese
;; --- The list to store the tests ---
(define *test-list* '())
;; --- add-test! ------------------------------------------------
;; This is the main function to add a test to the test-suite
;; name - a symbol naming the test uniquely
;; group - a symbol for the group of this test
;; proc - the function that does the test
;; args - the arguments for proc
;; add-test deletes all previously added tests that have the same
;; name (group is ignored)!
;; proc should return #f or signal an error, if the test failed.
;; Every other value means, that the test succeeded.
(define (add-test! name group proc . args)
(let ((test (make-testdt name group proc args)))
(let ((other (filter (lambda (test)
(equal? (testdt-name test)
name))
*test-list*)))
(for-each (lambda (test)
(set! *test-list* (delete! test *test-list*)))
other))
(set! *test-list* (cons test *test-list*))))
(define (find-test name)
(find (lambda (test)
(eq? (testdt-name test) name))
*test-list*))
;; --- add-test-multiple! ----------------------------------------
;; This function calls add-test! multiple times, with the same proc,
;; but different arguments.
;; name, group, proc see add-test! above
;; input-lists - each additional parameter has to be a list, specifying
;; alternative operands for proc.
;; Now add-test! is called for each permutation of input-lists.
;; If there's more than 1 permutation, the name is appended with
;; "-1"..."-n" respectively.
;; Example:
;; (add-test-multiple! 'test 'general proc '(a b) '(1 2))
;; results in 4 tests, that could have been generated with
;; (add-test 'test-1 'general proc 'a 1)
;; (add-test 'test-2 'general proc 'b 1)
;; (add-test 'test-3 'general proc 'a 2)
;; (add-test 'test-4 'general proc 'b 2)
;; Note: In future versions, these tests will run simultanously
;; with multi-threading.
(define (add-test-multiple! name group proc . input-lists)
(let* ((permutations (permute-lists input-lists))
(single? (and (not (null? permutations))
(null? (cdr permutations)))))
(let loop ((i 0)
(permutations permutations))
(if (not (null? permutations))
(let ((input-params (car permutations))
(new-name (if single?
name
(string->symbol (string-append
(symbol->string name)
"-"
(number->string i))))))
(apply add-test!
new-name
group
proc
input-params)
(loop (+ i 1) (cdr permutations)))))))
(define (permute-lists lists)
(cond
((null? lists) lists)
((null? (cdr lists)) (map list (car lists)))
(else
(let ((first-list (car lists))
(rest-perm (permute-lists (cdr lists))))
(fold-right (lambda (elem result)
(append
(map (lambda (new-param)
(cons new-param elem))
first-list)
result))
'()
rest-perm)))))
;; --- Functions for the test-datatype ---
(define-record-type testdt :testdt
(make-testdt name group proc args)
testdt?
(name testdt-name)
(group testdt-group)
(proc testdt-proc)
(args testdt-args))
;; --- Basic function to make a test ---
(define (run-test test . rest)
(let ((silent (if (null? rest) #f (car rest)))
(name (testdt-name test))
(group (testdt-group test))
(proc (testdt-proc test))
(args (testdt-args test)))
(let ((display-start (lambda ()
(display "Testing ")
(display group)
(display ":")
(display name)
(display " ... "))))
(if (not silent)
(display-start))
(call-with-current-continuation
(lambda (k)
(if (with-handler
(lambda (cond more)
(display "Error: ")
(display cond)
(newline)
(k #f))
(lambda ()
(apply proc args)))
(begin
(if silent
(display ".")
(display "OK\n"))
#t)
(begin
(if silent
(begin (newline)
(display-start)))
(display "Error! Input was ")
(display args)
(newline)
#f)))))))
;; --- Exported functions to make a test -------------------------------
;; The following 3 functions start the testing. They all have an
;; optional parameter >silent< with default #f. if silent is #t,
;; only those tests that signaled an error are printed on the screen.
;; test-single - runs the test with that name, returns the result of proc.
;; test-group - runs all tests that are part of that group. the result
;; is unspecified.
;; test-all - runs all tests in the test-suite.
(define (test-single name . rest)
(let ((test (find-test name)))
(if test
(apply run-test test rest)
(begin
(display "Test ") (display name)
(display " not found")
(newline)))))
(define (test-single/args name . args)
(let* ((test (find-test name))
(group (testdt-group test))
(proc (testdt-proc test)))
(run-test (apply make-testdt name group proc args))))
(define (test-group group . rest)
(let ((tests (filter (lambda (test)
(eq? (testdt-group test)
group))
*test-list*)))
(if (null? tests)
(begin
(display "Group ") (display group)
(display " doesn't contain any tests")
(newline))
(for-each (lambda (test)
(apply run-test
test rest))
tests))))
(define (test-all . rest)
(for-each (lambda (test)
(apply run-test
test rest))
*test-list*))
;; --- Summary functions -------------------------------------------
;; test-summary displays all registered tests in the test-suite, if
;; called with no arguments. Calling it with the additional parameter
;; group, displays only those tests that belong to that group.
(define (test-summary . rest)
(let ((group (if (null? rest) #f (car rest))))
(if group
(begin
(display "Listing group: ") (display group) (newline)
(for-each (lambda (test)
(if (eq? (testdt-group test) group)
(begin
(display (testdt-name test))
(newline))))
*test-list*))
(begin
(display "Listing all tests in format: group:name") (newline)
(for-each (lambda (test)
(display (testdt-group test))
(display ":")
(display (testdt-name test))
(newline))
*test-list*)))))
|