| ︙ | | |
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
|
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
|
-
-
+
+
|
(if currstate (conc "state='" currstate "' AND ") "")
(if currstatus (conc "status='" currstatus "' AND ") "")
" run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;;(debug:print 0 "QRY: " qry)
(sqlite3:execute db qry run-id newstate newstatus testname testname)))
testnames))
(define (db:delete-tests-in-state db run-id state)
(sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id))
(define (cdb:delete-tests-in-state zmqsocket run-id state)
(cdb:client-call zmqsocket 'delete-tests-in-state #t run-id state))
;; speed up for common cases with a little logic
(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
(cond
((and newstate newstatus newcomment)
(sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id))
((and newstate newstatus)
|
| ︙ | | |
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
|
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
|
+
|
(SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
THEN 'PASS'
ELSE status
END WHERE id=?;")
'(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;")
'(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")
'(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;")
'(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;")
))
;; do not run these as part of the transaction
(define db:special-queries '(rollup-tests-pass-fail
db:roll-up-pass-fail-counts))
;; not used, intended to indicate to run in calling process
|
| ︙ | | |
| ︙ | | |
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
-
+
-
+
|
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
;; Can setup as client for server mode now
(server:client-setup)
(change-directory *toppath*)
(open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
(set-megatest-env-vars run-id) ;; these may be needed by the launching process
(change-directory work-area)
(open-run-close set-run-config-vars #f run-id)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(open-run-close set-megatest-env-vars #f run-id)
(set-megatest-env-vars run-id)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
(open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0)
(tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript (not (file-execute-access? fullrunscript)))
|
| ︙ | | |
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
|
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
|
-
+
|
;; NB - This is not working right - some top tests are not getting the path set!!!
(if (not (hash-table-ref/default *toptest-paths* testname #f))
(let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
(curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(cdb:test-set-rundir! *runremote* run-id testname item-path lnkpath) ;; toptest-path)
(cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
(create-directory toptest-path #t)
(hash-table-set! *toptest-paths* testname toptest-path)))))
|
| ︙ | | |
| ︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
+
+
|
(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 (db:get-run-key-val db run-id key)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
run-id)
res))
(define (db:get-run-name-from-id db run-id)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
db
"SELECT runname FROM runs WHERE id=?;"
run-id)
res))
(define (set-megatest-env-vars db run-id)
(let ((keys (db:get-keys db))
(define (set-megatest-env-vars run-id)
(let ((keys (cdb:remote-run db:get-keys #f))
(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)
(hash-table-set! vals key val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
run-id))
(if (not *current-run-name*)
(sqlite3:for-each-row
(lambda (runname)
(set! *current-run-name* runname))
db
"SELECT runname FROM runs WHERE id=?;"
run-id))
(setenv "MT_RUNNAME" *current-run-name*)
(define (runs:can-run-more-tests db test-record)
(define (runs:can-run-more-tests test-record)
(let* ((tconfig (tests:testqueue-get-testconfig test-record))
(jobgroup (config-lookup tconfig "requirements" "jobgroup"))
(num-running (db:get-count-tests-running db))
(num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup))
(num-running (cdb:remote-run db:get-count-tests-running #f))
(num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup))
(max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(if (and mcj (string->number mcj))
(string->number mcj)
#f)))
(job-group-limit (config-lookup *configdat* "jobgroups" jobgroup)))
(if (not (eq? *last-num-running-tests* num-running))
(begin
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
|
(debug:print 0 "ERROR: Called without all necessary keys")
#f))))
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals
(define (runs:run-tests target runname test-patts user flags)
(let* ((db #f)
(keys (open-run-close db:get-keys db))
(keys (cdb:remote-run db:get-keys #f))
(keyvallst (keys:target->keyval keys target))
(run-id (open-run-close runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(run-id (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
;; keepgoing is the defacto modality now, will add hit-n-run a bit later
;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '())
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table)))
(open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(set-megatest-env-vars run-id) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(open-run-close 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))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
|
| ︙ | | |
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
-
-
+
+
|
;; -keepgoing is specified
(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.
(open-run-close db:delete-tests-in-state db run-id "NOT_STARTED")
(open-run-close db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED")
(cdb:remote-run db:set-tests-state-status #f 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
|
| ︙ | | |
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
|
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
|
-
+
|
(if (member test-name waitons)
(begin
(debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
(cond ;; OUTER COND
((not items) ;; when false the test is ok to be handed off to launch (but not before)
(let* ((run-limits-info (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running
(let* ((run-limits-info (open-run-close runs:can-run-more-tests test-record)) ;; look at the test jobgroup and tot jobs running
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
(prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode))
(fails (runs:calc-fails prereqs-not-met))
|
| ︙ | | |
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
|
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
|
-
+
|
(debug:print-info 4 "End of items list, looping with next after short delay")
(thread-sleep! (+ 0.01 *global-delta*))
(loop (car tal)(cdr tal) reruns))))
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
((or (procedure? items)(eq? items 'have-procedure))
(let ((can-run-more (open-run-close runs:can-run-more-tests #f test-record)))
(let ((can-run-more (runs:can-run-more-tests test-record)))
(if can-run-more
(let* ((prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met)))
(debug:print-info 8 "can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
|
| ︙ | | |
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
|
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
|
-
+
|
((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 set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
(set-megatest-env-vars 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)
(thread-sleep! *global-delta*)
(loop hed tal reruns))
(begin
|
| ︙ | | |
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
|
-
+
-
-
+
+
|
)
;; 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 set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(set-megatest-env-vars 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)
(open-run-close runs:update-test_meta db test-name test-conf)))
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
(test-id (open-run-close db:get-test-id db run-id test-name item-path))
(testdat (open-run-close db:get-test-info-by-id db test-id)))
(test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
(testdat (cdb:remote-run db:get-test-info-by-id #f test-id)))
(if (not testdat)
(begin
;; ensure that the path exists before registering the test
;; NOPE: Cannot! Don't know yet which disk area will be assigned....
;; (system (conc "mkdir -p " new-test-path))
;;
;; (open-run-close tests:register-test db run-id test-name item-path)
|
| ︙ | | |