| ︙ | | |
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
|
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
|
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
|
(vector header res)))
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
;; Awful. Please FIXME
(define *env-vars-by-run-id* (make-hash-table))
(define *current-run-name* #f)
(define (set-megatest-env-vars db run-id)
(let ((keys (db:get-keys db)))
(for-each (lambda (key)
(sqlite3:for-each-row
(lambda (val)
(let ((keys (db:get-keys db))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)))
;; get the info from the db and put it in the cache
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
(sqlite3:for-each-row
(lambda (val)
(debug:print 2 "setenv " (key:get-fieldname key) " " val)
(setenv (key:get-fieldname key) val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
run-id))
keys)
(sqlite3:for-each-row
(lambda (runname)
(setenv "MT_RUNNAME" runname))
db
"SELECT runname FROM runs WHERE id=?;"
run-id)
|
| ︙ | | |
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
-
+
|
(if (eq? *passnum* 0)
(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")
(rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
;; from here on out the db will be opened and closed on every call runs:run-tests-queue
(sqlite3:finalize! db)
;; now add non-directly referenced dependencies (i.e. waiton)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
|
| ︙ | | |
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
|
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
|
-
+
|
((or (null? prereqs-not-met) ;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
(and (eq? testmode 'toplevel)
(null? non-completed)))
(let ((test-name (tests:testqueue-get-testname test-record)))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(open-run-close-measure set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
(open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(tests:testqueue-set-items! test-record items-list)
(loop hed tal reruns))
(begin
(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
|
| ︙ | | |
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
|
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
|
-
+
|
)
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(set! item-path (item-list->path itemdat))
(debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(open-run-close-measure set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
(if (not (hash-table-ref/default *test-meta-updated* test-name #f))
(begin
(hash-table-set! *test-meta-updated* test-name #t)
|
| ︙ | | |