774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
|
(loop (hash-table-keys *waiting-queue*)))))))
;;======================================================================
;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
;;======================================================================
;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests.
;; keyvals
(define (runs:run-tests db target runname testpatts itempatts flags)
(let* ((keys (db-get-keys db))
(keyvallst (keys:target->keyval keys target))
(run-id (register-run db keys)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(keepgoing (hash-table-ref/default flags "-keepgoing")))
;; 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
;; 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.
(db:delete-tests-in-state db run-id "NOT_STARTED")
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(set! *passnum* (+ *passnum* 1))
(let loop ((numtimes 0))
(for-each
(lambda (test-name)
(if (runs:can-run-more-tests db)
(run-one-test db run-id test-name keyvallst)
;; add some delay
;(sleep 2)
))
(tests:sort-by-priority-and-waiton test-names))
;; (run-waiting-tests db)
(if keepgoing
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (and (> estrem 0)
(eq? *globalexitstatus* 0))
(begin
(debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
(sleep 3)
(run-waiting-tests db)
(loop (+ numtimes 1)))))))))
(define (run-one-test db run-id runname test-name keyvallst item-patts flags)
(debug:print 1 "Launching test " test-name)
;; All these vars might be referenced by the testconfig file reader
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(test-conf (if testexists (read-config test-configf #f #t) (make-hash-table)))
(waiton (let ((w (config-lookup test-conf "requirements" "waiton")))
(if (string? w)(string-split w)'())))
(force (hash-table-ref/default flags "-force"))
(rerun (hash-table-ref/default flags "-rerun"))
;; Are these tags still used? I don't think so...
;;(tags (let ((t (config-lookup test-conf "setup" "tags")))
;; ;; we want our tags to be separated by commas and fully delimited by commas
;; ;; so that queries with "like" can tie to the commas at either end of each tag
;; ;; while also allowing the end user to freely use spaces and commas to separate tags
;; (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
;; '()))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
|
|
|
>
|
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
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
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
|
(loop (hash-table-keys *waiting-queue*)))))))
;;======================================================================
;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
;;======================================================================
;; register a test run with the db
(define (runs:register-run db keys keyvallst runname state status user)
(let* ((keystr (keys->keystr keys))
(comma (if (> (length keys) 0) "," ""))
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(keyvals (map cadr keyvallst))
(allvals (append (list runname state status user) keyvals))
(qryvals (append (list runname) keyvals))
(key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND ")))
(debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals)
(debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
(let ((res #f))
(apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
allvals)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
(let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
;(debug:print 4 "qry: " qry)
qry)
qryvals)
(sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res)
res)
(begin
(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 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)
;; 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
;; 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.
(db:delete-tests-in-state db run-id "NOT_STARTED")
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
(set! *passnum* (+ *passnum* 1))
(let loop ((numtimes 0))
(for-each
(lambda (test-name)
(if (runs:can-run-more-tests db)
(run:test db run-id runname test-name keyvallst item-patts flags)
))
(tests:sort-by-priority-and-waiton test-names))
;; (run-waiting-tests db)
(if keepgoing
(let ((estrem (db:estimated-tests-remaining db run-id)))
(if (and (> estrem 0)
(eq? *globalexitstatus* 0))
(begin
(debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
(sleep 3)
(run-waiting-tests db)
(loop (+ numtimes 1)))))))))
(define (run:test db run-id runname test-name keyvallst item-patts flags)
(debug:print 1 "Launching test " test-name)
;; All these vars might be referenced by the testconfig file reader
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(change-directory *toppath*)
(let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
(test-configf (conc test-path "/testconfig"))
(testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
(test-conf (if testexists (read-config test-configf #f #t) (make-hash-table)))
(waiton (let ((w (config-lookup test-conf "requirements" "waiton")))
(if (string? w)(string-split w)'())))
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
;; Are these tags still used? I don't think so...
;;(tags (let ((t (config-lookup test-conf "setup" "tags")))
;; ;; we want our tags to be separated by commas and fully delimited by commas
;; ;; so that queries with "like" can tie to the commas at either end of each tag
;; ;; while also allowing the end user to freely use spaces and commas to separate tags
;; (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
;; '()))))
|
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
|
(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-run ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print 0 "ERROR: Failed to insert the record into the db"))
((NOT_STARTED COMPLETED)
|
|
|
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
|
(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
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print 0 "ERROR: Failed to insert the record into the db"))
((NOT_STARTED COMPLETED)
|