| ︙ | | | ︙ | |
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
|
"\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)
(begin
|
|
|
|
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
|
"\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 (db:test-make-full-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 (db:test-make-full-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)
(begin
|
| ︙ | | | ︙ | |
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
|
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
#f))
;; Register tests
;;
((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(let register-loop ((numtries 15))
(rmt:general-call 'register-test run-id run-id test-name item-path)
(thread-sleep! 0.5)
(if (rmt:get-test-id run-id test-name item-path)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
(if (> numtries 0)
(register-loop (- numtries 1))
(debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path)))))
(if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))
(begin
(rmt:general-call 'register-test run-id run-id test-name "")
(if (rmt:get-test-id run-id test-name "")
(hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
(if (and (null? tal)(null? reg))
(list hed tal (append reg (list hed)) reruns)
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
;; NB// Here we are building reg as we register tests
;; if regfull we must pop the front item off reg
(if regfull
(append (cdr reg) (list hed))
(append reg (list hed)))
reruns)))
;; At this point hed test registration must be completed.
;;
((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)
'start)
(debug:print-info 0 "Waiting on test registration(s): "
(string-intersperse
(filter (lambda (x)
(eq? (hash-table-ref/default test-registry x #f) 'start))
(hash-table-keys test-registry))
", "))
|
|
|
|
|
|
|
|
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
|
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
#f))
;; Register tests
;;
((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(let register-loop ((numtries 15))
(rmt:general-call 'register-test run-id run-id test-name item-path)
(thread-sleep! 0.5)
(if (rmt:get-test-id run-id test-name item-path)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
(if (> numtries 0)
(register-loop (- numtries 1))
(debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path)))))
(if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
(begin
(rmt:general-call 'register-test run-id run-id test-name "")
(if (rmt:get-test-id run-id test-name "")
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
(if (and (null? tal)(null? reg))
(list hed tal (append reg (list hed)) reruns)
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
;; NB// Here we are building reg as we register tests
;; if regfull we must pop the front item off reg
(if regfull
(append (cdr reg) (list hed))
(append reg (list hed)))
reruns)))
;; At this point hed test registration must be completed.
;;
((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
'start)
(debug:print-info 0 "Waiting on test registration(s): "
(string-intersperse
(filter (lambda (x)
(eq? (hash-table-ref/default test-registry x #f) 'start))
(hash-table-keys test-registry))
", "))
|
| ︙ | | | ︙ | |
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
|
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
(and (eq? testmode 'toplevel)
(null? non-completed))))
;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path))
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
;; well, first lets see if cpu load throttling is enabled. If so wait around until the
;; average cpu load is under the threshold before continuing
(if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
(common:wait-for-cpuload maxload numcpus waitdelay))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(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)
|
|
|
|
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
|
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
(and (eq? testmode 'toplevel)
(null? non-completed))))
;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
;; well, first lets see if cpu load throttling is enabled. If so wait around until the
;; average cpu load is under the threshold before continuing
(if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
(common:wait-for-cpuload maxload numcpus waitdelay))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(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)
|
| ︙ | | | ︙ | |
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
" from the launch list as it has prerequistes that are FAIL")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
;; This next is for the items
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)
(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 ;; WAS: (cons hed reruns) ;; but that makes no sense?
))
(let ((nth-try (hash-table-ref/default test-registry hed 0)))
(cond
|
|
|
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
" from the launch list as it has prerequistes that are FAIL")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
;; This next is for the items
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
(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 ;; WAS: (cons hed reruns) ;; but that makes no sense?
))
(let ((nth-try (hash-table-ref/default test-registry hed 0)))
(cond
|
| ︙ | | | ︙ | |
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
|
;; convert state to symbol and use that as the hash value
(for-each (lambda (trec)
(let ((id (db:test-get-id trec))
(tn (db:test-get-testname trec))
(ip (db:test-get-item-path trec))
(st (db:test-get-state trec)))
(if (not (equal? st "DELETED"))
(hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st)))))
tests-info)
(set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
(let loop ((hed (car sorted-test-names))
(tal (cdr sorted-test-names))
(reg '()) ;; registered, put these at the head of tal
(reruns '()))
|
|
|
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
|
;; convert state to symbol and use that as the hash value
(for-each (lambda (trec)
(let ((id (db:test-get-id trec))
(tn (db:test-get-testname trec))
(ip (db:test-get-item-path trec))
(st (db:test-get-state trec)))
(if (not (equal? st "DELETED"))
(hash-table-set! test-registry (db:test-make-full-name tn ip) (string->symbol st)))))
tests-info)
(set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
(let loop ((hed (car sorted-test-names))
(tal (cdr sorted-test-names))
(reg '()) ;; registered, put these at the head of tal
(reruns '()))
|
| ︙ | | | ︙ | |
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
|
(if m (map string->symbol (string-split m)) '(normal))))
(itemmap (configf:lookup tconfig "requirements" "itemmap"))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
(tfullname (runs:make-full-test-name test-name item-path))
(newtal (append tal (list hed)))
(regfull (>= (length reg) reglen))
(num-running (rmt:get-count-tests-running-for-run-id run-id)))
;; every couple minutes verify the server is there for this run
(if (and (common:low-noise-print 60 "try start server" run-id)
(tasks:need-server run-id))
(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running 240))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))
;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
;; and it is clear they *should* have run but did not.
(if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f))
(begin
(rmt:general-call 'register-test run-id run-id test-name "")
(hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
;;
(if (member (hash-table-ref/default test-registry tfullname #f)
'(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
(begin
(if (runs:lownoise (conc "been marked do not run " tfullname) 60)
|
|
|
|
|
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
|
(if m (map string->symbol (string-split m)) '(normal))))
(itemmap (configf:lookup tconfig "requirements" "itemmap"))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
(tfullname (db:test-make-full-name test-name item-path))
(newtal (append tal (list hed)))
(regfull (>= (length reg) reglen))
(num-running (rmt:get-count-tests-running-for-run-id run-id)))
;; every couple minutes verify the server is there for this run
(if (and (common:low-noise-print 60 "try start server" run-id)
(tasks:need-server run-id))
(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; NOTE: delay and wait is done under the hood
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running 240))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))
;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
;; and it is clear they *should* have run but did not.
(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
(begin
(rmt:general-call 'register-test run-id run-id test-name "")
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))
;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
;;
(if (member (hash-table-ref/default test-registry tfullname #f)
'(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
(begin
(if (runs:lownoise (conc "been marked do not run " tfullname) 60)
|
| ︙ | | | ︙ | |
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
|
(for-each
(lambda (my-itemdat)
(let* ((new-test-record (let ((newrec (make-tests:testqueue)))
(vector-copy! test-record newrec)
newrec))
(my-item-path (item-list->path my-itemdat)))
(if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here!
(let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path
(tests:testqueue-set-items! new-test-record #f)
(tests:testqueue-set-itemdat! new-test-record my-itemdat)
(tests:testqueue-set-item_path! new-test-record my-item-path)
(hash-table-set! test-records newtestname new-test-record)
(set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
items)
|
|
|
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
|
(for-each
(lambda (my-itemdat)
(let* ((new-test-record (let ((newrec (make-tests:testqueue)))
(vector-copy! test-record newrec)
newrec))
(my-item-path (item-list->path my-itemdat)))
(if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here!
(let ((newtestname (db:test-make-full-name hed my-item-path))) ;; test names are unique on testname/item-path
(tests:testqueue-set-items! new-test-record #f)
(tests:testqueue-set-itemdat! new-test-record my-itemdat)
(tests:testqueue-set-item_path! new-test-record my-item-path)
(hash-table-set! test-records newtestname new-test-record)
(set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
items)
|
| ︙ | | | ︙ | |
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
|
(define (runs:pretty-string lst)
(map (lambda (t)
(if (not (vector? t))
(conc t)
(conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
lst))
(define (runs:make-full-test-name testname itempath)
(if (equal? itempath "") testname (conc testname "/" itempath)))
(set! full-test-name (runs:make-full-test-name test-name item-path))
(debug:print-info 4
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 "Attempting to launch test " full-test-name)
(setenv "MT_TEST_NAME" test-name) ;;
|
<
<
<
|
|
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
|
(define (runs:pretty-string lst)
(map (lambda (t)
(if (not (vector? t))
(conc t)
(conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
lst))
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(test-conf (tests:testqueue-get-testconfig test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
(item-path "")
(db #f)
(full-test-name #f))
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(set! item-path (item-list->path itemdat))
(set! full-test-name (db:test-make-full-name test-name item-path))
(debug:print-info 4
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 "Attempting to launch test " full-test-name)
(setenv "MT_TEST_NAME" test-name) ;;
|
| ︙ | | | ︙ | |
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
|
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))))
((KILLED)
(debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(debug:print 2 "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (debug:print 2 "NOTE: " test-name " is already running")))
(else
(debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN))))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
(define (get-dir-up-n dir . params)
(let ((dparts (string-split dir "/"))
|
|
|
|
|
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
|
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))))
((KILLED)
(debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(debug:print 2 "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (debug:print 2 "NOTE: " test-name " is already running")))
(else
(debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
(define (get-dir-up-n dir . params)
(let ((dparts (string-split dir "/"))
|
| ︙ | | | ︙ | |