blob: 6342f33e4de9ff01a893ecf201df68a3cf3a2eba (
plain)
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
|
#!/usr/bin/guile \
--debug -s
!#
;;; Commentary:
;; Not a test, but a script that runs tests.
;; Assumes that all other .scm files in this directory are test files,
;; and should thereby follow the test-file syntax.
;; Note that the --debug flag in the (extended) shebang is REQUIRED,
;; otherwise the coverage tests do nothing.
;; TODO document the testfile syntax.
;;; Code:
(eval-when (compile load)
(define here (dirname (current-filename))))
(format #t "current filename = ~a~%" here)
(add-to-load-path (format #f "~a/module"
(dirname here)))
(use-modules (ice-9 ftw)
(ice-9 sandbox)
(ice-9 getopt-long)
(srfi srfi-64) ; test suite
(srfi srfi-88) ; suffix keywords
(system vm coverage)
((calp util) :select (for awhen))
;; datetime introduces the reader extensions for datetimes,
;; which leaks into the sandboxes below.
(datetime))
(define files
(scandir here
(lambda (name)
(and (< 2 (string-length name))
(not (string=? name (basename (current-filename))))
(string=? "scm" (string-take-right name 3))))))
;; Load tests
(define (read-multiple)
(let loop ((done '()))
(let ((sexp (read)))
(if (eof-object? sexp)
(reverse done)
(loop (cons sexp done))))))
(define options
'((skip (value #t))
(only (value #t))))
(define opts (getopt-long (command-line) options))
(define to-skip (call-with-input-string (option-ref opts 'skip "")
read))
(define only (option-ref opts 'only #f))
(when only (set! files (list only)))
(when (list? to-skip)
(for skip in to-skip
(test-skip skip)))
;; NOTE test-group fails if called before any test begin, since
;; (test-runner-current) needs to be a test-runner (dead or not),
;; but is initially bound to #f.
(test-begin "tests")
;; Forces all warnings to be explicitly handled by tests
((@ (calp util exceptions) warnings-are-errors) #t)
(define (run-with-coverage)
(with-code-coverage
(lambda ()
(for fname in files
(format (current-error-port) "Running test ~a~%" fname)
(test-group
fname
(with-throw-handler #t
(lambda ()
(with-input-from-file (string-append here "/" fname)
(lambda ()
(let ((modules (read))
(forms (read-multiple)))
(eval-in-sandbox
`(begin ,@forms)
#:time-limit 60 ; larger than should be needed
#:allocation-limit #e10e8
#:module (make-sandbox-module
(append modules
'(((srfi srfi-64) test-assert
test-equal test-error
test-eqv)
((ice-9 ports) call-with-input-string)
((guile) make-struct/no-tail)
)
all-pure-bindings)))
(list fname modules forms)))))
(lambda (err . args)
(case err
((misc-error)
(display-error #f (current-error-port)
(car args)
(cadr args)
(caddr args)
#f))
(else
(format (current-error-port)
"Test unexpectedly crashed: ~a~%" args))) )))))))
(call-with-values run-with-coverage
(lambda (data _)
(call-with-output-file "lcov.info"
(lambda (port) (coverage-data->lcov data port)))))
(test-end "tests")
|
