︙ | | | ︙ | |
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
*configdat*
(if (setup-for-run)
*configdat*
(begin
(debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
(exit 1)))))
(runrec (runs:runrec-make-record))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")))
(runname (or (args:get-arg ":runname")
(args:get-arg "-runname")))
(testpatt (or (args:get-arg "-testpatt")
(args:get-arg "-runtests")))
(keys (keys:config-get-fields mconfig))
(keyvals (keys:target->keyval keys target))
(toppath *toppath*)
|
|
<
|
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
*configdat*
(if (setup-for-run)
*configdat*
(begin
(debug:print 0 "ERROR: Called setup in a non-megatest area, exiting")
(exit 1)))))
(runrec (runs:runrec-make-record))
(target (common:args-get-target))
(runname (or (args:get-arg ":runname")
(args:get-arg "-runname")))
(testpatt (or (args:get-arg "-testpatt")
(args:get-arg "-runtests")))
(keys (keys:config-get-fields mconfig))
(keyvals (keys:target->keyval keys target))
(toppath *toppath*)
|
︙ | | | ︙ | |
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
(set! envdat (append envdat (list varval)))
(safe-setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))
(list "default" target))
(vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(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)))
|
|
<
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
(set! envdat (append envdat (list varval)))
(safe-setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))
(list "default" target))
(vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((target (or (common:args-get-target)
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(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)))
|
︙ | | | ︙ | |
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
|
;;
(define (runs:run-tests target runname test-patts user flags) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names (hash-table-keys all-tests-registry))
(test-names (tests:filter-test-names all-test-names test-patts)))
(set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "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
|
<
|
>
|
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
;;
(define (runs:run-tests target runname test-patts user flags) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names (hash-table-keys all-tests-registry))
(test-names (tests:filter-test-names all-test-names test-patts))
(required-tests test-names))
(set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "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
|
︙ | | | ︙ | |
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
|
"\n items: " items
"\n can-run-more: " can-run-more)
(cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a)
'(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
(debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue")
(if (or (not (null? tal))
(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
|
>
|
|
|
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
"\n items: " items
"\n can-run-more: " can-run-more)
(cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
((and (not (member 'toplevel testmode))
(member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a)
'(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
(debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue")
(if (or (not (null? tal))
(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
|
︙ | | | ︙ | |
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
|
;; (notinqueue (filter (lambda (x)
;; (not (member x allinqueue)))
;; prereqstrs))
(give-up #f))
;; We can get here when a prereq has not been run due to *it* having a prereq that failed.
;; We need to use this to dequeue this item as CANNOTRUN
(for-each (lambda (prereq)
(if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
(set! give-up #t)))
prereqstrs)
(if (and give-up
(not (and (null? tal)(null? reg))))
(let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
(trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
(debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(mt:test-set-state-status-by-id test-id "DEQUED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
(if (and (null? trimmed-tal)
(null? trimmed-reg))
#f
(list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
|
>
>
|
|
|
|
>
|
|
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
|
;; (notinqueue (filter (lambda (x)
;; (not (member x allinqueue)))
;; prereqstrs))
(give-up #f))
;; We can get here when a prereq has not been run due to *it* having a prereq that failed.
;; We need to use this to dequeue this item as CANNOTRUN
;;
(if (member testmode '(toplevel))
(for-each (lambda (prereq)
(if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
(set! give-up #t)))
prereqstrs))
(if (and give-up
(not (and (null? tal)(null? reg))))
(let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
(trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
(debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(mt:test-set-state-status-by-id test-id "DEQUEUED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))
(if (and (null? trimmed-tal)
(null? trimmed-reg))
#f
(list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
|
︙ | | | ︙ | |
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
|
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(let ((runname (args:get-arg ":runname"))
(target (if (args:get-arg "-target")
(args:get-arg "-target")
(args:get-arg "-reqtarg"))))
;; (th1 #f))
(cond
((not target)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 3))
(else
(let ((db #f)
(keys #f)
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target"))))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; (if (args:get-arg "-server")
;; (cdb:remote-run server:start db (args:get-arg "-server")))
(set! keys (keys:config-get-fields *configdat*))
|
|
<
<
<
|
<
<
|
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
|
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(let ((runname (args:get-arg ":runname"))
(target (common:args-get-target)))
(cond
((not target)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 3))
(else
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; (if (args:get-arg "-server")
;; (cdb:remote-run server:start db (args:get-arg "-server")))
(set! keys (keys:config-get-fields *configdat*))
|
︙ | | | ︙ | |