17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit mtmod))
;; (declare (uses mtargs))
(declare (uses debugprint))
(module mtmod
*
(import scheme
chicken.base
|
>
>
>
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit mtmod))
;; (declare (uses mtargs))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
;; (declare (uses rmtmod))
(module mtmod
*
(import scheme
chicken.base
|
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
chicken.sort
chicken.string
chicken.time
debugprint
;; mtargs
;; pkts
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
format
|
>
>
>
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
chicken.sort
chicken.string
chicken.time
debugprint
;; mtargs
;; pkts
commonmod
dbmod
;; rmtmod
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
format
|
61
62
63
64
65
66
67
68
69
|
srfi-69
stack
typed-records
z3
)
)
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
srfi-69
stack
typed-records
z3
)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
;; (import (prefix sqlite3 sqlite3:))
;;
;; (declare (unit mt))
;; (declare (uses db))
;; (declare (uses common))
;; (declare (uses items))
;; (declare (uses runconfig))
;; (declare (uses tests))
;; (declare (uses server))
;; (declare (uses runs))
;; (declare (uses rmt))
;; ;; (declare (uses filedb))
;;
;; (include "common_records.scm")
;; (include "key_records.scm")
(include "db_records.scm")
;; (include "run_records.scm")
;; (include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
(define (mt:get-run-stats dbstruct run-id)
;; Get run stats from local access, move this ... but where?
(db:get-run-stats dbstruct run-id))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
(if (null? remt)
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
)
|