823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
|
;; keyvals
(define (runs:run-tests db target runname test-patts item-patts user flags)
(let* ((keys (db-get-keys db))
(keyvallst (keys:target->keyval keys target))
(run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '()))
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
(for-each
(lambda (patt)
(let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*")))))
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(set! test-names (append test-names
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
(string-split test-patts ","))
;; now remove duplicates
(set! test-names (delete-duplicates test-names))
(debug:print 0 "INFO: test names " test-names)
;; now add non-directly referenced dependencies (i.e. waiton)
;; could cache all these since they need to be read again ...
;; FIXME SOMEDAY
(for-each
(lambda (test-name)
(let* ((config (test:get-testconfig test-name #f))
(waiton (config-lookup config "requirements" "waiton")))
(if (and waiton (not (member waiton test-names)))
(set! test-names (append test-names (list waiton))))))
test-names)
|
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
|
<
<
|
>
>
|
>
>
>
>
|
>
>
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
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
879
880
881
882
883
|
;; keyvals
(define (runs:run-tests db target runname test-patts item-patts user flags)
(let* ((keys (db-get-keys db))
(keyvallst (keys:target->keyval keys target))
(run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '())
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '()))
(if (file-exists? runconfigf)
(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
(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)
(for-each
(lambda (patt)
(let ((tests (glob (conc *toppath* "/tests/" (string-translate patt "%" "*")))))
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(set! test-names (append test-names
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
(string-split test-patts ","))
;; now remove duplicates
(set! test-names (delete-duplicates test-names))
(debug:print 0 "INFO: test names " test-names)
;; now add non-directly referenced dependencies (i.e. waiton)
;; could cache all these since they need to be read again ...
;; FIXME SOMEDAY
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names)))
(let* ((config (test:get-testconfig hed #f))
(waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
(if w w "")))))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(begin
(set! required-tests (cons waiton required-tests))
(set! test-names (append test-names (list waiton))))))
waitons)
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(loop (car remtests)(cdr remtests)))))))
(if (not (null? required-tests))
(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (and (eq? *passnum* 0)
keepgoing)
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
|
980
981
982
983
984
985
986
987
988
989
990
991
992
993
|
(set! testdat ts)
(begin
(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(change-directory test-path)
;; this block is here only to inform the user early on
;; (if (file-exists? runconfigf)
;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
(debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
|
>
>
>
|
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
|
(set! testdat ts)
(begin
(debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(change-directory test-path)
;; this block is here only to inform the user early on
;; Moving this to the run calling block
;; (if (file-exists? runconfigf)
;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
(debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
|