︙ | | | ︙ | |
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
"\n reruns: " reruns
"\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)
|
|
|
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
"\n reruns: " reruns
"\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)
|
︙ | | | ︙ | |
680
681
682
683
684
685
686
687
688
689
690
691
692
693
|
;; 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))))
(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)
|
>
>
>
>
|
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
|
;; 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))
(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)
|
︙ | | | ︙ | |
728
729
730
731
732
733
734
735
736
737
738
739
740
741
|
(cons hed reruns)))
(begin
(debug:print 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (list hed tal reg reruns)
(list (car newtal)(cdr newtal) reg reruns)
))))))))
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))
|
>
>
>
>
>
|
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
|
(cons hed reruns)))
(begin
(debug:print 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (list hed tal reg reruns)
(list (car newtal)(cdr newtal) reg reruns)
))))))))
;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))
|
︙ | | | ︙ | |
792
793
794
795
796
797
798
799
800
801
802
803
804
805
|
(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)))
;; 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
(cdb:tests-register-test *runremote* run-id test-name "")
(hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
|
>
>
>
|
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
|
(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)))
(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
(cdb:tests-register-test *runremote* run-id test-name "")
(hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
|
︙ | | | ︙ | |
837
838
839
840
841
842
843
844
845
846
847
848
849
850
|
;; error
(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
;; items is #f then the test is ok to be handed off to launch (but not before)
;;
((not items)
(debug:print-info 4 "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
|
;; error
(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
;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF
;; they have been through the wringer 10 or more times
((and (list? waitons)
(not (null? waitons))
(> (hash-table-ref/default *max-tries-hash* tfullname 0) 10)
(not (null? (filter
number?
(map (lambda (waiton)
(if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run
(not (member waiton reruns)))
1
#f))
waitons))))) ;; could do this more elegantly with a marker....
(debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.")
(hash-table-set! test-registry tfullname 'removed))
;; items is #f then the test is ok to be handed off to launch (but not before)
;;
((not items)
(debug:print-info 4 "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
|
︙ | | | ︙ | |