Overview
Context
Changes
Modified Makefile
from [ed1fd098c5]
to [b20ff2bde7].
︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
-
+
|
csc $(OFILES) $(GOFILES) -o dboard
# Special dependencies for the includes
db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm
runs.o dashboard.o dashboard-tests.o : run_records.scm
keys.o db.o runs.o launch.o megatest.o : key_records.scm
tasks.o dashboard-tasks.o : task_records.scm
runs.o : old-runs.scm
runs.o : old-runs.scm test_records.scm
$(OFILES) $(GOFILES) : common_records.scm
%.o : %.scm
csc -c $<
$(PREFIX)/bin/megatest : megatest
|
︙ | | |
Modified items.scm
from [24c2262144]
to [b49fc1c23e].
︙ | | |
123
124
125
126
127
128
129
130
131
132
133
134
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
+
+
+
+
+
+
+
+
+
|
(let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
(define (items:get-items-from-config tconfig)
(let* (;; db is always at *toppath*/db/megatest.db
(items (hash-table-ref/default test-conf "items" '()))
(itemstable (hash-table-ref/default test-conf "itemstable" '()))
(allitems (if (or (not (null? items))(not (null? itemstable)))
(append (item-assoc->item-list items)
(item-table->item-list itemstable))
'(()))))
allitems))
;; (pp (item-assoc->item-list itemdat))
|
Modified runs.scm
from [5d46e1bbed]
to [253a55cec5].
︙ | | |
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
+
|
(declare (uses runconfig))
(declare (uses tests))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; stuff to be deprecated then removed
(include "old-runs.scm")
;; runs:get-runs-by-patt
;; get runs by list of criteria
|
︙ | | |
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
-
+
+
|
(let* ((keys (db-get-keys db))
(keyvallst (keys:target->keyval keys target))
(run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '())
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '()))
(required-tests '())
(test-records (make-hash-table)))
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
|
︙ | | |
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
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
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
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
|
tests)))))
(string-split test-patts ","))
;; now remove duplicates
(set! test-names (delete-duplicates test-names))
(debug:print 0 "INFO: test names " test-names)
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (and (eq? *passnum* 0)
keepgoing)
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
(db:delete-tests-in-state db run-id "NOT_STARTED")
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(set! *passnum* (+ *passnum* 1))
;; now add non-directly referenced dependencies (i.e. waiton)
;; could cache all these since they need to be read again ...
;; FIXME SOMEDAY
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names)))
(let* ((config (test:get-testconfig hed #f))
(waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
(if w w "")))))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records hed (vector hed config waitons (config-lookup "requirements" "priority") #f)))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(begin
(set! required-tests (cons waiton required-tests))
(set! test-names (append test-names (list waiton))))))
waitons)
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(loop (car remtests)(cdr remtests)))))))
(if (not (null? required-tests))
(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(if (and (eq? *passnum* 0)
keepgoing)
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
(db:delete-tests-in-state db run-id "NOT_STARTED")
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(set! *passnum* (+ *passnum* 1))
(let loop ((numtimes 0))
(for-each
(lambda (test-name)
(if (runs:can-run-more-tests db)
(lambda (test-record)
;; need to inspect the items field tests:testqueue-get-items
;;
;; if #f then no items for this test, check prereqs and launch
;;
;; else if list, then have items
;;
;; if proc then eval it.
;;
(let ((items (items:get-items-from-config tconfig)))
(if (runs:can-run-more-tests db test-record) ;; now needs to look at the test group
(run:test db run-id runname test-name keyvallst item-patts flags)
))
(tests:sort-by-priority-and-waiton test-names))
(tests:sort-by-priority-and-waiton test-records))
;; (run-waiting-tests db)
(if keepgoing
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (and (> estrem 0)
(eq? *globalexitstatus* 0))
(begin
(debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
|
︙ | | |
Added test_records.scm version [1c9875ade7].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
|
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 5))
(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
(define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3))
(define-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
|
| | | | | | | | | | | |
Modified tests.scm
from [f3725b9582]
to [b7feda25e5].
︙ | | |
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
|
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
-
+
-
-
+
-
-
-
-
-
+
-
-
-
-
+
+
+
+
+
+
-
+
-
+
|
(read-config test-configf #f system-allowed environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-names)
(define (tests:sort-by-priority-and-waiton test-records)
(let ((testdetails (make-hash-table))
(mungepriority (lambda (priority)
(let ((mungepriority (lambda (priority)
(if priority
(let ((tmp (any->number priority)))
(if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0)))
0))))
(for-each (lambda (test-name)
(let ((test-config (test:get-testconfig test-name #f)))
(if test-config (hash-table-set! testdetails test-name test-config))))
test-names)
(sort
(hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at the hash table
(hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table
(lambda (a b)
(let* ((tconf-a (hash-table-ref testdetails a))
(tconf-b (hash-table-ref testdetails b))
(a-waiton (config-lookup tconf-a "requirements" "waiton"))
(b-waiton (config-lookup tconf-b "requirements" "waiton"))
(let* ((a-record (hash-table-ref test-records a))
(b-record (hash-table-ref test-records b))
(a-waitons (tests:testqueue-get-waitons a-record))
(b-waitons (tests:testqueue-get-waitons a-record))
(a-priority (mungepriority (config-lookup tconf-a "requirements" "priority")))
(b-priority (mungepriority (config-lookup tconf-b "requirements" "priority"))))
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
(if (and a-waiton (equal? a-waiton b))
(if (and a-waiton (member? (tests:testqueue-get-testname b) a-waitons))
#f ;; cannot have a which is waiting on b happening before b
(if (and b-waiton (equal? b-waiton a))
(if (and b-waiton (member? (tests:testqueue-get-testname a) b-waitons))
#t ;; this is the correct order, b is waiting on a and b is before a
(if (> a-priority b-priority)
#t ;; if a is a higher priority than b then we are good to go
#f))))))))
;;======================================================================
|
︙ | | |