Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -42,12 +42,12 @@ csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard -ndboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard +odboard : olddashboard.scm $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) olddashboard.scm -o odboard # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl @@ -57,11 +57,11 @@ tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm -client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.scm +client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm olddashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm rpc-transport.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm @@ -77,16 +77,16 @@ @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest -$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard - $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard +$(PREFIX)/bin/.$(ARCHSTR)/odboard : odboard + $(INSTALL) odboard $(PREFIX)/bin/.$(ARCHSTR)/odboard -$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard - utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard - chmod a+x $(PREFIX)/bin/newdashboard +$(PREFIX)/bin/olddashboard : $(PREFIX)/bin/.$(ARCHSTR)/odboard + utils/mk_wrapper $(PREFIX) odboard $(PREFIX)/bin/olddashboard + chmod a+x $(PREFIX)/bin/olddashboard # $(HELPERS) : utils/% # $(INSTALL) $< $@ # chmod a+x $@ @@ -138,11 +138,11 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/bin/newdashboard + $(PREFIX)/bin/olddashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -99,11 +99,11 @@ ;; These are called by the server on recipt of /api calls ;; - keep it simple, only return the actual result of the call, i.e. no meta info here ;; ;; - returns #( flag result ) ;; -(define (api:execute-requests dbstruct dat) +(define (api:execute-requests dbstruct area-dat dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) @@ -121,134 +121,134 @@ ;;=============================================== ;; READ/WRITE QUERIES ;;=============================================== ;; SERVERS - ((start-server) (apply server:kind-run params)) + ((start-server) (apply server:kind-run params area-dat)) ((kill-server) (set! *server-run* #f)) ;; TESTS - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) - ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct area-dat params)) + ((delete-test-records) (apply db:delete-test-records dbstruct area-dat params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct area-dat params)) + ((test-set-status-state) (apply db:test-set-status-state dbstruct area-dat params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct area-dat params)) + ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct area-dat params)) + ((update-fail-pass-counts) (apply db:general-call dbstruct area-dat 'update-pass-fail-counts params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct area-dat params)) ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((register-run) (apply db:register-run dbstruct area-dat params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct area-dat params)) + ((delete-run) (apply db:delete-run dbstruct area-dat params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct area-dat params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct area-dat params)) ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct area-dat params)) ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) + ((test-data-rollup) (apply db:test-data-rollup dbstruct area-dat params)) + ((csv->test-data) (apply db:csv->test-data dbstruct area-dat params)) ;; MISC ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) + (db:sync-touched dbstruct area-dat run-id force-sync: #t))) + ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct area-dat params)) ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct area-dat params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct area-dat params)) ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-add) (apply tasks:add dbstruct area-dat params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct area-dat params)) ;; ARCHIVES ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + ((archive-register-disk) (apply db:archive-register-disk dbstruct area-dat params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct area-dat params)) + ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct area-dat block-id testsuite-name areakey)) ;;====================================================================== ;; READ ONLY QUERIES ;;====================================================================== ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct area-dat params)) + ((get-keys) (db:get-keys dbstruct area-dat)) ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct area-dat params)) ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct area-dat params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct area-dat params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct area-dat params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct area-dat params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct area-dat params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct area-dat params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct area-dat params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct area-dat params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct area-dat params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct area-dat params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct area-dat params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct area-dat params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct area-dat params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct area-dat params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct area-dat params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct area-dat params)) + ((synchash-get) (apply synchash:server-get dbstruct area-dat params)) ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-run-info) (apply db:get-run-info dbstruct area-dat params)) + ((get-run-status) (apply db:get-run-status dbstruct area-dat params)) + ((set-run-status) (apply db:set-run-status dbstruct area-dat params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct area-dat params)) + ((get-test-id) (apply db:get-test-id dbstruct area-dat params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct area-dat params)) + ((get-runs) (apply db:get-runs dbstruct area-dat params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct area-dat)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct area-dat params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct area-dat params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct area-dat params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct area-dat params)) ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ((get-steps-data) (apply db:get-steps-data dbstruct area-dat params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct area-dat params)) ;; MISC - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct area-dat params)) + ((login) (apply db:login dbstruct area-dat params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) - (db:with-db dbstruct run-id #t ;; these are all for modifying the db + (db:with-db dbstruct area-dat run-id #t ;; these are all for modifying the db (lambda (db) - (db:general-call db stmtname realparams))))) + (db:general-call db stmtname realparams area-dat))))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct area-dat params)) ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)))))))) + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct area-dat params)))))))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; -(define (api:process-request dbstruct $) ;; the $ is the request vars proc +(define (api:process-request dbstruct area-dat $) ;; the $ is the request vars proc (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj)) - (resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result ) + (resdat (api:execute-requests dbstruct area-dat (vector cmd params))) ;; #( flag result ) (res (vector-ref resdat 1))) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -43,17 +43,17 @@ (apath (archive:get-archive testname itempath dused))) (jobrunner:run-job flavor maxload '() - archive:run-bup + archive:run-bup ;; this will break!!! need area-dat (list testdir apath)))))) ;; Get archive disks from megatest.config ;; -(define (archive:get-archive-disks) - (let ((section (configf:get-section *configdat* "archive-disks"))) +(define (archive:get-archive-disks area-dat) + (let ((section (configf:get-section (megatest:area-configdat area-dat) "archive-disks"))) (if section section '()))) ;; look for the best candidate archive area, else create new @@ -99,23 +99,25 @@ ;; 1. create the bup dir if not exists ;; 2. start the du of each directory ;; 3. gen index ;; 4. save ;; -(define (archive:run-bup archive-command run-id run-name tests) +(define (archive:run-bup archive-command run-id run-name tests area-dat) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) - (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) + (let* ((configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (min-space (string->number (or (configf:lookup configdat "archive" "minspace") "1000"))) + (archive-info (archive:allocate-new-archive-block toppath (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely - (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (compress (or (configf:lookup *configdat* "archive" "compress") "9")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (bup-exe (or (configf:lookup configdat "archive" "bup") "bup")) + (compress (or (configf:lookup configdat "archive" "compress") "9")) + (linktree (configf:lookup configdat "setup" "linktree"))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") (debug:print 0 " use [archive] minspace to specify minimum available space") @@ -196,22 +198,23 @@ (runs:remove-test-directory test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) #t)) -(define (archive:bup-restore archive-command run-id run-name tests) ;; move the getting of archive space down into the below block so that a single run can +(define (archive:bup-restore archive-command run-id run-name tests area-dat) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; - (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) - (linktree (configf:lookup *configdat* "setup" "linktree"))) + (let* ((configdat (megatest:area-configdat area-dat)) + (bup-exe (or (configf:lookup configdat "archive" "bup") "bup")) + (linktree (configf:lookup configdat "setup" "linktree"))) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) ;; When restoring test-dat will initially contain an old and invalid path to the test - (let* ((best-disk (get-best-disk *configdat*)) + (let* ((best-disk (get-best-disk configdat)) (item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) (keyvals (rmt:get-key-val-pairs run-id)) Index: batchsim/Makefile ================================================================== --- batchsim/Makefile +++ batchsim/Makefile @@ -1,3 +1,7 @@ + +all : batchsim + ./batchsim batchsim : batchsim.scm csc batchsim.scm + Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -36,27 +36,27 @@ (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; Not currently used! But, I think it *should* be used!!! -(define (client:logout serverdat) +(define (client:logout serverdat area-dat) (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (client:get-signature))))) + (cdb:logout serverdat (megatest:area-path area-dat) (client:get-signature))))) ok)) -(define (client:connect iface port) - (case (server:get-transport) +(define (client:connect iface port area-dat) + (case (server:get-transport area-dat) ((rpc) (rpc:client-connect iface port)) ((http) (http:client-connect iface port)) ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) -(define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) - (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http run-id)) - (else (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id)))) +(define (client:setup run-id area-dat #!key (remaining-tries 10) (failed-connects 0)) + (case (server:get-transport area-dat) + ((rpc) (rpc-transport:client-setup run-id area-dat)) + ((http)(client:setup-http run-id area-dat)) + (else (rpc-transport:client-setup run-id area-dat)))) ;; (define (client:login-no-auto-setup server-info run-id) ;; (case (server:get-transport) ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) @@ -66,28 +66,28 @@ ;; (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries) ;; (if (<= remaining-tries 0) ;; (begin ;; (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) ;; (exit 1)) -;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) +;; (let ((host-info (hash-table-ref/default (common:get-remote remote) run-id #f))) ;; (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) ;; (if host-info ;; (let* ((iface (car host-info)) ;; (port (cadr host-info)) ;; (start-res (client:connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) ;; (ping-res (client:login-no-auto-setup start-res run-id))) ;; (if ping-res ;; sucessful login? ;; (begin -;; (hash-table-set! *runremote* run-id start-res) +;; (hash-table-set! (common:get-remote remote) run-id start-res) ;; start-res) ;; return the server info ;; (if (member remaining-tries '(3 4 6)) ;; (begin ;; login failed ;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) -;; (hash-table-delete! *runremote* run-id) +;; (hash-table-delete! (common:get-remote remote) run-id) ;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db +;; (lambda ()(tasks:open-db area-dat)) ;; run-id ;; (car host-info) ;; (cadr host-info) ;; " client:setup (host-info=#t)") ;; (thread-sleep! 5) @@ -95,28 +95,28 @@ ;; (begin ;; (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; ;; YUK: rename server-dat here -;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) +;; (let* ((server-dat (open-run-close tasks:get-server (lambda ()(tasks:open-db area-dat)) run-id))) ;; (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) ;; (if server-dat ;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) ;; (port (tasks:hostinfo-get-port server-dat)) ;; (start-res (http-transport:client-connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) ;; (ping-res (rmt:login-no-auto-client-setup start-res run-id))) ;; (if start-res ;; (begin -;; (hash-table-set! *runremote* run-id start-res) +;; (hash-table-set! (common:get-remote remote) run-id start-res) ;; start-res) ;; (if (member remaining-tries '(2 5)) ;; (begin ;; login failed ;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) -;; (hash-table-delete! *runremote* run-id) +;; (hash-table-delete! (common:get-remote remote) run-id) ;; (open-run-close tasks:server-force-clean-run-record -;; tasks:open-db +;; (lambda ()(tasks:open-db area-dat)) ;; run-id ;; (tasks:hostinfo-get-interface server-dat) ;; (tasks:hostinfo-get-port server-dat) ;; " client:setup (server-dat = #t)") ;; (thread-sleep! 2) @@ -128,87 +128,88 @@ ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; (begin ;; no server registered ;; (if (eq? remaining-tries 2) ;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") +;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id (lambda ()(tasks:open-db area-dat)) run-id " client:setup (server-dat=#f)") ;; (client:setup run-id remaining-tries: 10)) ;; (begin ;; (thread-sleep! 2) ;; (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) -;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) +;; (if (< (open-run-close tasks:num-in-available-state (lambda ()(tasks:open-db area-dat)) run-id) 3) ;; (begin -;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") +;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id (lambda ()(tasks:open-db area-dat)) run-id " client:setup (server-dat=#f)") ;; (server:try-running run-id))) ;; (thread-sleep! 10) ;; give server a little time to start up ;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline +;; 1. We are a test manager and we received transport-type and (common:get-remote remote) via cmdline ;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db +;; transport-type and (common:get-remote remote) from the monitor.db ;; ;; client:setup ;; -;; lookup_server, need to remove *runremote* stuff +;; lookup_server, need to remove (common:get-remote remote) stuff ;; -(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) +(define (client:setup-http run-id area-dat #!key (remaining-tries 10) (failed-connects 0)(remote #f)) (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) - (let* ((tdbdat (tasks:open-db))) + (let* ((tdbdat (tasks:open-db area-dat)) + (transport-type (megatest:area-transport area-dat))) (if (<= remaining-tries 0) (begin (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) - (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) + (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat area-dat) run-id))) (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (hostname (tasks:hostinfo-get-hostname server-dat)) (port (tasks:hostinfo-get-port server-dat)) - (start-res (case *transport-type* + (start-res (case transport-type ((http)(http-transport:client-connect iface port)) ((nmsg)(nmsg-transport:client-connect hostname port)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res run-id)) - ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) + (ping-res (case transport-type + ((http)(rmt:login-no-auto-client-setup start-res run-id area-dat)) + ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id area-dat))) (if logininfo (car (vector-ref logininfo 1)) #f)))))) (if (and start-res ping-res) (begin - (hash-table-set! *runremote* run-id start-res) + (common:set-remote! remote run-id start-res) (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (case *transport-type* + (case transport-type ((http)(http-transport:close-connections run-id))) - (hash-table-delete! *runremote* run-id) + (common:del-remote! remote run-id) (tasks:kill-server-run-id run-id) - (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) + (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat area-dat) run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time (server:try-running run-id) (thread-sleep! 5) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1)) + (client:setup run-id area-dat remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) - (server:try-running run-id)) + (server:try-running run-id area-dat)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) + (client:setup run-id area-dat remaining-tries: (- remaining-tries 1))))))))) ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -35,14 +35,23 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES -(define *db-keys* #f) -(define *configinfo* #f) -(define *configdat* #f) -(define *toppath* #f) +(define-record megatest:area + name + path + transport + configinfo + configdat + denoise + client-signature + remote + run-keys + runs ;; used in dashboard + ) + (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar @@ -65,13 +74,35 @@ (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'http) -(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg -(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold +;; (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg +;; (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold + +(define (common:get-remote remote run-id) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-ref/default ht run-id #f) + #f))) + +(define (common:set-remote! remote run-id value) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-set! ht run-id value)))) + +(define (common:del-remote! remote run-id) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-delete! ht run-id)))) + +(define (common:get-remote-all remote) + (let ((ht (or remote *runremote*))) + (if ht + (hash-table-keys ht) + '()))) + (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) (define *server-info* #f) @@ -234,27 +265,28 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) -(define (common:get-testsuite-name) - (or (configf:lookup *configdat* "setup" "testsuite" ) - (pathname-file *toppath*))) +(define (common:get-testsuite-name area-dat) + (or (configf:lookup (megatest:area-configdat area-dat) "setup" "testsuite" ) + (pathname-file (megatest:area-path area-dat)))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== -(define (std-exit-procedure) +(define (std-exit-procedure area-dat) (debug:print-info 2 "starting exit process, finalizing databases.") - (rmt:print-db-stats) - (let ((run-ids (hash-table-keys *db-local-sync*))) + (rmt:print-db-stats area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) + (run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) - (configf:lookup *configdat* "setup" "megatest-db")) + (configf:lookup configdat "setup" "megatest-db")) (db:multi-db-sync run-ids 'new2old))) - (if *dbstruct-db* (db:close-all *dbstruct-db*)) - (if *inmemdb* (db:close-all *inmemdb*)) + (if *dbstruct-db* (db:close-all *dbstruct-db* area-dat)) + (if *inmemdb* (db:close-all *inmemdb* area-dat)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) (begin (sqlite3:interrupt! *megatest-db*) (sqlite3:finalize! *megatest-db* #t) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -31,12 +31,13 @@ (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") -(define (control-panel db tdb keys) - (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove? +(define (control-panel db tdb keys area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove? (key-params (make-hash-table)) (monitordat '()) ;; list of monitor records (keyentries (iup:frame #:title "Keys" (apply @@ -100,12 +101,12 @@ #:font "Courier New, -10" #:value "None...............................................")) (lastmodtime 0) (next-touch 0) ;; the last time the "last_update" field was updated (refreshdat (lambda () - (let* ((monitordbpath (conc *toppath* "/monitor.db")) - (megatestdbpath (conc *toppath* "/megatest.db")) + (let* ((monitordbpath (conc toppath "/monitor.db")) + (megatestdbpath (conc toppath "/megatest.db")) (modtime (max (file-modification-time megatestdbpath) (file-modification-time monitordbpath)))) ;; do stuff here when the db is updated by some other process (if (> modtime lastmodtime) (let ((tlst (tasks:get-tasks tdb '() '())) @@ -174,19 +175,19 @@ (iup:attribute-set! tabtop "TABTITLE3" "Tools") tabtop)))) ;; BUG: Remember to re-instate this!!!! ;; (on-exit (lambda () -;; (let ((tdb (tasks:open-db))) +;; (let ((tdb (tasks:open-db area-dat))) ;; ;; (print "On-exit called") ;; (tasks:remove-monitor-record tdb) ;; (sqlite3:finalize! tdb)))) -(define (gui-monitor db) +(define (gui-monitor db area-dat) (let ((keys (db:get-keys db)) - (tdb (tasks:open-db))) + (tdb (tasks:open-db area-dat))) (tasks:register-monitor db tdb) ;;; let the other monitors know we are here (control-panel db tdb keys) ;(tasks:remove-monitor-record db) ;(sqlite3:finalize! db) )) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -39,16 +39,16 @@ ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) -(define (dtests:get-pre-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) +(define (dtests:get-pre-command area-dat #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) -(define (dtests:get-post-command #!key (default-override #f)) - (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) +(define (dtests:get-post-command area-dat #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup (megatest:area-configdat area-dat) "dashboard" "post-command"))) (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) (define (test-info-panel testdat store-label widgets) (iup:frame @@ -302,11 +302,12 @@ (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) - )))) + )) + area-dat)) (begin (rmt:test-set-state-status-by-id run-id test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) @@ -319,12 +320,12 @@ (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) -(define (dashboard-tests:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) +(define (dashboard-tests:run-html-viewer lfilename area-dat) + (let ((htmlviewercmd (configf:lookup (megatest:area-configdat area-dat) "setup" "htmlviewercmd"))) (if htmlviewercmd (system (conc "(" htmlviewercmd " " lfilename " ) &")) (iup:send-url lfilename)))) (define (dashboard-tests:run-a-step info) @@ -353,12 +354,12 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd area-dat) + (let* ((wpatt (configf:lookup (megatest:area-configdat area-dat) "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) @@ -399,13 +400,13 @@ ;;====================================================================== ;; ;;====================================================================== -(define (examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") +(define (examine-test run-id test-id area-dat) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path run-id)) + (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) @@ -417,11 +418,11 @@ (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) - (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + (tdb (tdb:open-test-db-by-test-id-local dbstruct area-dat run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) @@ -443,18 +444,18 @@ "/")) (item-path (db:test-get-item-path testdat)) (viewlog (lambda (x) (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer logfile) + (dashboard-tests:run-html-viewer logfile area-dat) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) (if (file-exists? lfilename) ;(system (conc "firefox " logfile "&")) - (dashboard-tests:run-html-viewer lfilename) + (dashboard-tests:run-html-viewer lfilename area-dat) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) @@ -542,13 +543,13 @@ lbl)) (store-button store-label) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10")) (command-launch-button (iup:button "Execute!" #:action (lambda (x) (let* ((cmd (iup:attribute command-text-box "VALUE")) - (fullcmd (conc (dtests:get-pre-command) + (fullcmd (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))) + (dtests:get-post-command area-dat)))) (debug:print-info 02 "Running command: " fullcmd) (system fullcmd))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" @@ -579,13 +580,13 @@ ";megatest -target " keystring " -runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))) - (system (conc (dtests:get-pre-command) + (system (conc (dtests:get-pre-command area-dat) cmd - (dtests:get-post-command)))))) + (dtests:get-post-command area-dat)))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") @@ -694,11 +695,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%"))) + (tdb:open-run-close-db-by-test-id-local dbstruct area-dat run-id test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1,78 +1,61 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use format) +(use format numbers) (require-library iup) (import (prefix iup iup:)) - (use canvas-draw) -(import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) -(declare (uses common)) (declare (uses margs)) -(declare (uses keys)) -(declare (uses items)) +(declare (uses launch)) +(declare (uses megatest-version)) +(declare (uses gutils)) (declare (uses db)) -(declare (uses configf)) -(declare (uses process)) -(declare (uses launch)) -(declare (uses runs)) -(declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) +(declare (uses server)) +(declare (uses synchash)) +(declare (uses dcommon)) (declare (uses tree)) -(declare (uses dcommon)) - -;; (declare (uses dashboard-main)) -(declare (uses megatest-version)) -(declare (uses mt)) +(declare (uses configf)) (include "common_records.scm") (include "db_records.scm") -(include "run_records.scm") -(include "megatest-fossil-hash.scm") +(include "key_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2014 + license GPL, Copyright (C) Matt Welland 2011 Usage: dashboard [options] - -h : this help - -server host:port : connect to host:port instead of db access - -test run-id,test-id : control test identified by testid - -guimonitor : control panel for runs + -h : this help + -group groupname : display this group of areas + -test testid : control test identified by testid + -guimonitor : control panel for runs Misc -rows N : set number of rows ")) ;; process args (define remargs (args:get-args (argv) - (list "-rows" - "-run" - "-test" + (list "-group" ;; display this group of areas "-debug" - "-host" - "-transport" ) (list "-h" - "-use-server" - "-guimonitor" - "-main" "-v" "-q" ) args:arg-hash 0)) @@ -80,1504 +63,607 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (launch:setup-for-run)) +;;; REMOVE ME, this is a stop-gap +(define *area-dat* (make-megatest:area + "default" ;; area name + #f ;; area path + 'http ;; transport + #f ;; configinfo + #f ;; configdat + (make-hash-table) ;; denoise + #f ;; client signature + #f ;; remote connections + )) + +(if (not (launch:setup-for-run *area-dat*)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* - local: #t)) -(define *db-file-path* (db:dbfile-path 0)) - -;; HACK ALERT: this is a hack, please fix. -(define *read-only* (not (file-read-access? *db-file-path*))) - -(define toplevel #f) -(define dlg #f) -(define max-test-num 0) -(define *keys* (db:get-keys *dbstruct-local*)) - -(define *dbkeys* (append *keys* (list "runname"))) - -(define *header* #f) -(define *allruns* '()) -(define *allruns-by-id* (make-hash-table)) ;; -(define *runchangerate* (make-hash-table)) - -(define *buttondat* (make-hash-table)) ;; -(define *alltestnamelst* '()) -(define *searchpatts* (make-hash-table)) -(define *num-runs* 8) -(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) -;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) - -;; Update management -;; -(define *last-update* (current-seconds)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) -(define *update-is-running* #f) -(define *update-mutex* (make-mutex)) - -(define *all-item-test-names* '()) -(define *num-tests* 15) -(define *start-run-offset* 0) -(define *start-test-offset* 0) -(define *examine-test-dat* (make-hash-table)) -(define *exit-started* #f) -(define *status-ignore-hash* (make-hash-table)) -(define *state-ignore-hash* (make-hash-table)) - -(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") - (vector "Sort -a" 'testname "DESC") - (vector "Sort +t" 'event_time "ASC") - (vector "Sort -t" 'event_time "DESC") - (vector "Sort +s" 'statestatus "ASC") - (vector "Sort -s" 'statestatus "DESC") - (vector "Sort +a" 'testname "ASC"))) - -(define *tests-sort-type-index* '(("+testname" 0) - ("-testname" 1) - ("+event_time" 2) - ("-event_time" 3) - ("+statestatus" 4) - ("-statestatus" 5))) - -;; Don't forget to adjust the >= below if you add to the sort-options above -(define (next-sort-option) - (if (>= *tests-sort-reverse* 5) - (set! *tests-sort-reverse* 0) - (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) - *tests-sort-reverse*) - -(define *tests-sort-reverse* - (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) - (if t-sort - (cadr t-sort) - 3))) - -(define (get-curr-sort) - (vector-ref *tests-sort-options* *tests-sort-reverse*)) - -(define *hide-empty-runs* #f) -(define *hide-not-hide* #t) ;; toggle for hide/not hide -(define *hide-not-hide-button* #f) -(define *hide-not-hide-tabs* #f) - -(define *current-tab-number* 0) -(define *updaters* (make-hash-table)) +;; (if (args:get-arg "-host") +;; (begin +;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(define *runremote* #f) (debug:setup) -(define uidat #f) - -(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) -(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) -(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) -(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) - -(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) +(define *tim* (iup:timer)) +(define *ord* #f) + +(iup:attribute-set! *tim* "TIME" 300) +(iup:attribute-set! *tim* "RUN" "YES") (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) +(define (iuplistbox-fill-list lb items . default) + (let ((i 1) + (selected-item (if (null? default) #f (car default)))) + (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) (for-each (lambda (item) (iup:attribute-set! lb (number->string i) item) (if selected-item (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) (set! i (+ i 1))) items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) i)) (define (pad-list l n)(append l (make-list (- n (length l))))) -(define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -(define (update-rundat runnamepatt numruns testnamepatt keypatts) - (let* ((referenced-run-ids '()) - (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*)) - (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath))) - ;; - ;; trim runs to only those that are changing often here - ;; - (for-each (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses - #f #f - *hide-not-hide* - sort-by - sort-order - 'shortlist)) - ;; NOTE: bubble-up also sets the global *all-item-test-names* - ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (db:get-key-vals *dbstruct-local* run-id))) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (set! referenced-run-ids (cons run-id referenced-run-ids)) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set - (not (null? tests))) - (let ((dstruct (vector run tests key-vals))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) - (set! result (cons dstruct result)))))) - runs) - - (set! *header* header) - (set! *allruns* result) - (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") - maxtests)) - -(define *collapsed* (make-hash-table)) -; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) - -(define (toggle-hide lnum) ; fulltestname) - (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) - (fulltestname (iup:attribute btn "TITLE")) - (parts (string-split fulltestname "(")) - (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) - (if (hash-table-ref/default *collapsed* basetestname #f) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") - (hash-table-delete! *collapsed* basetestname)) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") - (hash-table-set! *collapsed* basetestname #t))))) - -(define blank-line-rx (regexp "^\\s*$")) - -(define (run-item-name->vectors lst) - (map (lambda (x) - (let ((splst (string-split x "(")) - (res (vector "" ""))) - (vector-set! res 0 (car splst)) - (if (> (length splst) 1) - (vector-set! res 1 (car (string-split (cadr splst) ")")))) - res)) - lst)) - -(define (collapse-rows inlst) - (let* ((sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) - (newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) - ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) - ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - (vlst2 (bubble-up vlst priority: bubble-type))) - (map (lambda (x) - (if (equal? (vector-ref x 1) "") - (vector-ref x 0) - (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) - vlst2))) - -(define (update-labels uidat) - (let* ((rown 0) - (keycol (dboard:uidat-get-keycol uidat)) - (lftcol (dboard:uidat-get-lftcol uidat)) - (numcols (vector-length lftcol)) - (maxn (- numcols 1)) - (allvals (make-vector numcols ""))) - (for-each (lambda (name) - (if (<= rown maxn) - (vector-set! allvals rown name)) ;) - (set! rown (+ 1 rown))) - *alltestnamelst*) - (let loop ((i 0)) - (let* ((lbl (vector-ref lftcol i)) - (keyval (vector-ref keycol i)) - (oldval (iup:attribute lbl "TITLE")) - (newval (vector-ref allvals i))) - (if (not (equal? oldval newval)) - (let ((munged-val (let ((parts (string-split newval "("))) - (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) - (vector-set! keycol i newval) - (iup:attribute-set! lbl "TITLE" munged-val))) - (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) - (if (< i maxn) - (loop (+ i 1))))))) - -;; -(define (get-itemized-tests test-dats) - (let ((tnames '())) - (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) - (if (not (equal? ipath "")) - (if (and (list? tnames) - (string? tname) - (not (member tname tnames))) - (set! tnames (append tnames (list tname))))))) - test-dats) - tnames)) - -;; Bubble up the top tests to above the items, collect the items underneath -;; all while preserving the sort order from the SQL query as best as possible. -;; -(define (bubble-up test-dats #!key (priority 'itempath)) - (if (null? test-dats) - test-dats - (begin - (let* ((tnames '()) ;; list of names used to reserve order - (tests (make-hash-table)) ;; hash of lists, used to build as we go - (itemized (get-itemized-tests test-dats))) - (for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (if (equal? ipath "") - ;; This a top level, prepend it - (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) - ;; This is item, append it - (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) - test-dats) - ;; Set all tests with items - (set! *all-item-test-names* (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - *all-item-test-names*)) - (let loop ((hed (car tnames)) - (tal (cdr tnames)) - (res '())) - (let ((newres (append res (hash-table-ref tests hed)))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))))) - -(define (update-buttons uidat numruns numtests) - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0)) - (set! *alltestnamelst* '()) - ;; create a concise list of test names - (for-each - (lambda (rundat) - (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) - (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* - (null? testnames))) - (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) - testnames))))) - runs) - - (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) - (update-labels uidat) - (for-each - (lambda (rundat) - (if (not rundat) ;; handle padded runs - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - - ;; For this run now fill in the buttons for each test - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) - (if buttondat - (let* ((test (let ((matching (filter - (lambda (x)(equal? (test:test-get-fullname x) testname)) - testsdat))) - (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) - (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - ;;(teststart (db:test-get-event_time test)) - ;;(runtime (db:test-get-run_duration test)) - (buttontxt (cond - ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) - ((and (equal? teststate "NOT_STARTED") - (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) - teststatus) - (else - teststate))) - (button (vector-ref columndat rown)) - (color (car (gutils:get-color-for-state-status teststate teststatus))) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - *alltestnamelst*)) - (set! coln (+ coln 1)))) - runs))) (define (mkstr . x) (string-intersperse (map conc x) ",")) -(define (set-bg-on-filter) - (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref *searchpatts* key) "%"))) - (hash-table-keys *searchpatts*))))) - (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) - (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) - (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" - (if (or search-changed - state-changed - status-changed) - "190 180 190" - "190 190 190" - )))) - -(define (update-search x val) - (hash-table-set! *searchpatts* x val) - (set-bg-on-filter)) - -(define (mark-for-update) - (set! *last-db-update-time* 0) - (set! *delayed-update* 1)) - -;;====================================================================== -;; R U N C O N T R O L -;;====================================================================== - -;; target populating logic -;; -;; lb = -;; field = target field name for this dropdown -;; referent-vals = selected value in the left dropdown -;; targets = list of targets to use to build the dropdown -;; -;; each node is chained: key1 -> key2 -> key3 -;; -;; must select values from only apropriate targets -;; a b c -;; a d e -;; a b f -;; a/b => c f -;; -(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) - ;; is the current value in the new list? choose new default if not - (let* ((remvalues (map (lambda (row) - (common:list-is-sublist referent-vals (vector->list row))) - targets)) - (values (delete-duplicates (map car (filter list? remvalues)))) - (sel-valnum (iup:attribute lb "VALUE")) - (sel-val (iup:attribute lb sel-valnum)) - (val-num 1)) - ;; first check if the current value is in the new list, otherwise replace with - ;; first value from values - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (for-each (lambda (val) - ;; (iup:attribute-set! lb "APPENDITEM" val) - (iup:attribute-set! lb (conc val-num) val) - (if (equal? sel-val val) - (iup:attribute-set! lb "VALUE" val-num)) - (set! val-num (+ val-num 1))) - values) - (let ((val (iup:attribute lb "VALUE"))) - (if val - val - (if (not (null? values)) - (let ((newval (car values))) - (iup:attribute-set! lb "VALUE" newval) - newval)))))) - -(define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (db:get-targets *dbstruct-local*)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (all-targets (append db-targets - (map (lambda (x) - (list->vector - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header)))) - runconf-targs))) - (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) - (let loop ((key (car header)) - (remkeys (cdr header)) - (refvals '()) - (indx 0) - (lbs '())) - (let* ((lb (let ((lb (list-ref key-listboxes indx))) - (if lb - lb - (iup:listbox - #:size "45x50" - #:fontsize "10" - #:expand "YES" ;; "VERTICAL" - ;; #:dropdown "YES" - #:editbox "YES" - #:action (lambda (obj a b c) - (action-proc)) - #:caret_cb (lambda (obj a b c)(action-proc)) - )))) - ;; loop though all the targets and build the list for this dropdown - (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) - (if (null? remkeys) - ;; return a list of the listbox items and an iup:hbox with the labels and listboxes - (let ((listboxes (append lbs (list lb)))) - (list listboxes - (map (lambda (htxt lb) - (iup:vbox - (iup:label htxt) - lb)) - header - listboxes))) - (loop (car remkeys) - (cdr remkeys) - (append refvals (list selected-value)) - (+ indx 1) - (append lbs (list lb)))))))) - -;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string -;; interspersed with commas -;; -(define (dashboard:text-list-toggle-box items proc) - (let ((alltgls (make-hash-table))) - (apply iup:vbox - (map (lambda (item) - (iup:toggle - item - #:expand "YES" - #:action (lambda (obj tstate) - (if (eq? tstate 0) - (hash-table-delete! alltgls item) - (hash-table-set! alltgls item #t)) - (let ((all (hash-table-keys alltgls))) - (proc all))))) - items)))) - -;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command) - (let* ((cmd-tb (dboard:data-get-command-tb *data*)) - (cmd (dboard:data-get-command *data*)) - (test-patt (let ((tp (dboard:data-get-test-patts *data*))) - (if (equal? tp "") "%" tp))) - (states (dboard:data-get-states *data*)) - (statuses (dboard:data-get-statuses *data*)) - (target (let ((targ-list (dboard:data-get-target *data*))) - (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:data-get-run-name *data*)) - (states-str (if (or (not states) - (null? states)) - "" - (conc " :state " (string-intersperse states ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " :status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((runtests) - (set! full-cmd (conc full-cmd - " -runtests " - test-patt - " -target " - target - " -runname " - run-name - ))) - ((remove-runs) - (set! full-cmd (conc full-cmd - " -remove-runs -runname " - run-name - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - -;; Display the tests as rows of boxes on the test/task pane -;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) - (canvas-clear! cnv) - (canvas-font-set! cnv "Helvetica, -10") - (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 8) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) - (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) - )) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; -(define (dashboard:run-controls) - (let* ((targets (make-hash-table)) - (test-records (make-hash-table)) - (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) - (test-names (hash-table-keys all-tests-registry)) - (sorted-testnames #f) - (action "-runtests") - (cmdln "") - (runlogs (make-hash-table)) - (key-listboxes #f) - (updater-for-runs #f) - (update-keyvals (lambda () - (let ((targ (map (lambda (x) - (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector key-listboxes))))) - (dboard:data-set-target! *data* targ) - (if updater-for-runs (updater-for-runs)) - (dashboard:update-run-command)))) - (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas - (test-patterns-textbox #f)) - (hash-table-set! tests-draw-state 'first-time #t) - (hash-table-set! tests-draw-state 'scalef 8) - (tests:get-full-data test-names test-records '() all-tests-registry) - (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - - ;; refer to *keys*, *dbkeys* for keys - (iup:vbox - ;; The command line display/exectution control - (iup:frame - #:title "Command to be exectuted" - (iup:hbox - (iup:label "Run on" #:size "40x") - (iup:radio - (iup:hbox - (iup:toggle "Local" #:size "40x") - (iup:toggle "Server" #:size "40x"))) - (let ((tb (iup:textbox - #:value "megatest " - #:expand "HORIZONTAL" - #:readonly "YES" - #:font "Courier New, -12" - ))) - (dboard:data-set-command-tb! *data* tb) - tb) - (iup:button "Execute" #:size "50x" - #:action (lambda (obj) - (let ((cmd (conc "xterm -geometry 180x20 -e \"" - (iup:attribute (dboard:data-get-command-tb *data*) "VALUE") - ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd)))))) - - (iup:split - #:orientation "HORIZONTAL" - - (iup:split - #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:vbox - ;; Command to run - (iup:frame - #:title "Set the action to take" - (iup:hbox - ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("runtests" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - ;; (print obj " " val " " index " " lbstate) - (dboard:data-set-command! *data* val) - (dashboard:update-run-command)))) - (default-cmd (car cmds-list))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (dboard:data-set-command! *data* default-cmd) - lb))) - - (iup:frame - #:title "Runname" - (let* ((default-run-name (seconds->work-week/day (current-seconds))) - (tb (iup:textbox #:expand "HORIZONTAL" - #:action (lambda (obj val txt) - ;; (print "obj: " obj " val: " val " unk: " unk) - (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) - (dashboard:update-run-command)) - #:value default-run-name)) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (iup:attribute-set! tb "VALUE" val) - (dboard:data-set-run-name! *data* val) - (dashboard:update-run-command)))) - (refresh-runs-list (lambda () - (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) - (runs-header (vector-ref runs-for-targ 0)) - (runs-dat (vector-ref runs-for-targ 1)) - (run-names (cons default-run-name - (map (lambda (x) - (db:get-value-by-header x runs-header "runname")) - runs-dat)))) - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) - (set! updater-for-runs refresh-runs-list) - (refresh-runs-list) - (dboard:data-set-run-name! *data* default-run-name) - (iup:hbox - tb - lb))) - - (iup:frame - #:title "SELECTORS" - (iup:vbox - ;; Text box for test patterns - (iup:frame - #:title "Test patterns (one per line)" - (let ((tb (iup:textbox #:action (lambda (val a b) - (dboard:data-set-test-patts! - *data* - (dboard:lines->test-patt b)) - (dashboard:update-run-command)) - #:value (dboard:test-patt->lines - (dboard:data-get-test-patts *data*)) - #:expand "YES" - #:size "x50" - #:multiline "YES"))) - (set! test-patterns-textbox tb) - tb)) - (iup:frame - #:title "Target" - ;; Target selectors - (apply iup:hbox - (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) - (key-lb (car dat)) - (combos (cadr dat))) - (set! key-listboxes key-lb) - combos))) - (iup:hbox - ;; Text box for STATES - (iup:frame - #:title "States" - (dashboard:text-list-toggle-box - ;; Move these definitions to common and find the other useages and replace! - (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - (lambda (all) - (dboard:data-set-states! *data* all) - (dashboard:update-run-command)))) - ;; Text box for STATES - (iup:frame - #:title "Statuses" - (dashboard:text-list-toggle-box - (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") - (lambda (all) - (dboard:data-set-statuses! *data* all) - (dashboard:update-run-command)))))))) - - (iup:frame - #:title "Tests and Tasks" - (let* ((updater #f) - (last-xadj 0) - (last-yadj 0) - (the-cnv #f) - (canvas-obj - (iup:canvas #:action (make-canvas-action - (lambda (cnv xadj yadj) - (if (not updater) - (set! updater (lambda (xadj yadj) - ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) - (set! last-xadj xadj) - (set! last-yadj yadj)))) - (updater xadj yadj) - (set! the-cnv cnv) - )) - ;; Following doesn't work - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (let ((xadj last-xadj) - (yadj (+ last-yadj (if (> step 0) - -0.01 - 0.01)))) - ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") - ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) - (if the-cnv - (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) - (set! last-xadj xadj) - (set! last-yadj yadj) - )) - ;; #:size "50x50" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj) - (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) - ;; (print "x\ty\tllx\tlly\turx\tury") - (for-each (lambda (test-name) - (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (list-ref rec-coords 0)) - (urx (list-ref rec-coords 1)) - (lly (list-ref rec-coords 2)) - (ury (list-ref rec-coords 3))) - ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " - (if (and (eq? pressed 1) - (> x llx) - (> y lly) - (< x urx) - (< y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) - (let* ((selected (not (member test-name patterns))) - (newpatt-list (if selected - (cons test-name patterns) - (delete test-name patterns))) - (newpatt (string-intersperse newpatt-list "\n"))) - ;; (if cnv-obj - ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) - (iup:attribute-set! obj "REDRAW" "ALL") - (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command) - (if updater (updater last-xadj last-yadj))))))) - (hash-table-keys tests-info))))))) - canvas-obj))) - ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) - - (iup:frame - #:title "Logs" ;; To be replaced with tabs - (let ((logs-tb (iup:textbox #:expand "YES" - #:multiline "YES"))) - (dboard:data-set-logs-textbox! *data* logs-tb) - logs-tb)))))) - - -;; (trace dashboard:populate-target-dropdown -;; common:list-is-sublist) -;; -;; ;; key1 key2 key3 ... -;; ;; target entry (wild cards allowed) -;; -;; ;; The action -;; (iup:hbox -;; ;; label Action | action selector -;; )) -;; ;; Test/items selector -;; (iup:hbox -;; ;; tests -;; ;; items -;; )) -;; ;; The command line -;; (iup:hbox -;; ;; commandline entry -;; ;; GO button -;; ) -;; ;; The command log monitor -;; (iup:tabs -;; ;; log monitor -;; ))) - -;;====================================================================== -;; S U M M A R Y -;;====================================================================== -;; -;; General info about the run(s) and megatest area -(define (dashboard:summary db) - (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) - (iup:vbox - (iup:split - #:value 500 - (iup:frame - #:title "General Info" - (iup:vbox - (iup:hbox - (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - ))) - (iup:frame - #:title "Server" - (dcommon:servers-table))) - (iup:frame - #:title "Megatest config settings" - (iup:hbox - (dcommon:section-matrix rawconfig "setup" "Varname" "Value") - (iup:vbox - (dcommon:section-matrix rawconfig "server" "Varname" "Value") - ;; (iup:frame - ;; #:title "Disks Areas" - (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) - (iup:frame - #:title "Run statistics" - (dcommon:run-stats db))))) - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -(define (tree-path->run-id path) - (if (not (null? path)) - (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) - #f)) - -(define dashboard:update-run-summary-tab #f) - -;; (define (tests window-id) -(define (dashboard:one-run db) - (let* ((tb (iup:treebox - #:value 0 - #:name "Runs" - #:expand "YES" - #:addexpanded "NO" +(define (update-search x val) + (hash-table-set! *searchpatts* x val)) + +;; mtest is actually the megatest.config file +;; +(define (mtest window-id area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (curr-row-num 0) + (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) + (keys-matrix (dcommon:keys-matrix rawconfig)) + (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) + (jobtools-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 3)) + (validvals-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2)) + (envovrd-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + (disks-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 20 + #:numcol-visible 1 + #:numlin-visible 8)) + ) + (iup:attribute-set! disks-matrix "0:0" "Disk Name") + (iup:attribute-set! disks-matrix "0:1" "Disk Path") + (iup:attribute-set! disks-matrix "WIDTH1" "120") + (iup:attribute-set! disks-matrix "WIDTH0" "100") + (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") + (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") + + ;; fill in existing info + (for-each + (lambda (mat fname) + (set! curr-row-num 1) + (for-each + (lambda (var) + (iup:attribute-set! mat (conc curr-row-num ":0") var) + (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) + (set! curr-row-num (+ curr-row-num 1))) + (configf:section-vars rawconfig fname))) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) + (list "setup" "jobtools" "validvalues" "env-override" "disks")) + + (for-each + (lambda (mat) + (iup:attribute-set! mat "0:1" "Value") + (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES") + (iup:attribute-set! mat "WIDTH1" "120") + (iup:attribute-set! mat "WIDTH0" "100") + ) + (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) + + (iup:attribute-set! validvals-matrix "WIDTH1" "290") + (iup:attribute-set! envovrd-matrix "WIDTH1" "290") + + (iup:vbox + (iup:hbox + + (iup:vbox + (let ((tabs (iup:tabs + ;; The required tab + (iup:hbox + ;; The keys + (iup:frame + #:title "Keys (required)" + (iup:vbox + (iup:label (conc "Set the fields for organising your runs\n" + "here. Note: can only be changed before\n" + "running the first run when megatest.db\n" + "is created.")) + keys-matrix)) + (iup:vbox + ;; The setup section + (iup:frame + #:title "Setup" + (iup:vbox + (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" + "linktree : directory where linktree will be created.")) + setup-matrix)) + ;; The jobtools + (iup:frame + #:title "Jobtools" + (iup:vbox + (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" + "useshell : use system to run your launcher\n" + "workhosts : spread jobs out on these hosts")) + jobtools-matrix)) + ;; The disks + (iup:frame + #:title "Disks" + (iup:vbox + (iup:label (conc "Enter names and existing paths of locations to run tests")) + disks-matrix)))) + ;; The optional tab + (iup:vbox + ;; The Environment Overrides + (iup:frame + #:title "Env override" + envovrd-matrix) + ;; The valid values + (iup:frame + #:title "Validvalues" + validvals-matrix) + )))) + (iup:attribute-set! tabs "TABTITLE0" "Required settings") + (iup:attribute-set! tabs "TABTITLE1" "Optional settings") + tabs)) + )))) + +;; The runconfigs.config file +;; +(define (rconfig window-id) + (iup:vbox + (iup:frame #:title "Default"))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +(define (tree-path->test-id path) + (if (not (null? path)) + (hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f) + #f)) + +(define (test-panel window-id) + (let* ((curr-row-num 0) + (viewlog (lambda (x) + (if (file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (iup:send-url logfile) + (message-window (conc "File " logfile " not found"))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (system (conc "cd " rundir + ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (message-window (conc "Directory " rundir " not found"))))) + (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) + (command-launch-button (iup:button "Execute!" + ;; #:expand "HORIZONTAL" + #:size "50x" + #:action (lambda (x) + (let ((cmd (iup:attribute command-text-box "VALUE"))) + (system (conc cmd " &")))))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname + " -runtests " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) + (run-info-matrix (iup:matrix + #:expand "YES" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin 4 + #:numcol-visible 1 + #:numlin-visible 4 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + (test-info-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 7 + #:numcol-visible 1 + #:numlin-visible 7)) + (test-run-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (meta-dat-matrix (iup:matrix + #:expand "YES" + #:numcol 1 + #:numlin 5 + #:numcol-visible 1 + #:numlin-visible 5)) + (steps-matrix (iup:matrix + #:expand "YES" + #:numcol 6 + #:numlin 50 + #:numcol-visible 6 + #:numlin-visible 8)) + (data-matrix (iup:matrix + #:expand "YES" + #:numcol 8 + #:numlin 50 + #:numcol-visible 8 + #:numlin-visible 8)) + (updater (lambda (testdat) + (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) + + ;; Set the updater in updaters + (hash-table-set! (dboard:data-get-updaters *data*) window-id updater) + ;; + (for-each + (lambda (mat) + ;; (iup:attribute-set! mat "0:1" "Value") + ;; (iup:attribute-set! mat "0:0" "Var") + (iup:attribute-set! mat "HEIGHT0" 0) + (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") + (iup:attribute-set! mat "RESIZEMATRIX" "YES")) + ;; (iup:attribute-set! mat "WIDTH1" "120") + ;; (iup:attribute-set! mat "WIDTH0" "100")) + (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) + + ;; Steps matrix + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "WIDTH2" "40") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "40") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "40") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "WIDTH5" "40") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") + ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") + + ;; Data matrix + ;; + (let ((rownum 1)) + (for-each + (lambda (x) + (iup:attribute-set! data-matrix (conc "0:" rownum) x) + (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") + (set! rownum (+ rownum 1))) + (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) + (iup:attribute-set! data-matrix "REDRAW" "ALL") + + (for-each + (lambda (data) + (let ((mat (car data)) + (keys (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (iup:attribute-set! mat (conc rownum ":0") key) + (set! rownum (+ rownum 1))) + keys) + (iup:attribute-set! mat "REDRAW" "ALL"))) + (list + (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) + (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) + (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) + (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) + + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) + +;; Test browser +(define (tree-browser data adat window-id) + ;; (iup:split + (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id (cdr run-path)))) - (if run-id - (begin - (dboard:data-set-curr-run-id! *data* run-id) - (dashboard:update-run-summary-tab))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - )))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #:click-cb - (lambda (obj lin col status) - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) - (system cmd))))) - (updater (lambda () - (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (db:get-tests-for-run db run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status"))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) - (tests-mindat (dcommon:minimize-test-data tests-dat)) - (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b)))))) - - ;; (iup:attribute-set! tb "VALUE" "0") - ;; (iup:attribute-set! tb "NAME" "Runs") - ;; Update the runs tree - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - *keys*)) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (dboard:data-get-path-run-ids *data*) run-path #f)) - (begin - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) - ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) - run-ids) - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 - ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) - ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) - - (set! dashboard:update-run-summary-tab updater) - (dboard:data-set-runs-tree! *data* tb) - (iup:split - tb - run-matrix))) - -;;====================================================================== -;; R U N S -;;====================================================================== - -(define (make-dashboard-buttons db nruns ntests keynames) - (let* ((nkeys (length keynames)) - (runsvec (make-vector nruns)) - (header (make-vector nruns)) - (lftcol (make-vector ntests)) - (keycol (make-vector ntests)) - (controls '()) - (lftlst '()) - (hdrlst '()) - (bdylst '()) - (result '()) - (i 0)) - ;; controls (along bottom) - (set! controls - (iup:hbox - (iup:vbox - (iup:frame - #:title "filter test and items" - (iup:hbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search "test-name" val))) - ;;(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" - ;; #:action (lambda (obj unk val) - ;; (mark-for-update) - ;; (update-search "item-name" val)) - )) - (iup:vbox - (iup:hbox - (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (mark-for-update)))) - (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (mark-for-update) - ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) - lb) - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update))) - (iup:button "HideEmpty" #:action (lambda (obj) - (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) - (mark-for-update))) - (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (set! *hide-not-hide* (not *hide-not-hide*)) - (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) - (mark-for-update))))) - (set! *hide-not-hide-button* hideit) - hideit)) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) - (exit))) - (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update))) - (iup:button "Collapse" #:action (lambda (obj) - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - *all-item-test-names*) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update)))))) - (iup:frame - #:title "state/status filter" - (iup:vbox - (apply - iup:hbox - (map (lambda (status) - (iup:toggle status #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *status-ignore-hash* status #t) - (hash-table-delete! *status-ignore-hash* status)) - (set-bg-on-filter)))) - (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) - (apply - iup:hbox - (map (lambda (state) - (iup:toggle state #:action (lambda (obj val) - (mark-for-update) - (if (eq? val 1) - (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state)) - (set-bg-on-filter)))) - (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns *tot-run-count*)) - (set! *start-run-offset* val) - (mark-for-update) - (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) - (iup:attribute-set! obj "MAX" (* maxruns 10)))) - #:expand "HORIZONTAL" - #:max (* 10 (length *allruns*)) - #:min 0 - #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) - ) - ) - - ;; create the left most column for the run key names and the test names - (set! lftlst (list (iup:hbox - (iup:label) ;; (iup:valuator) - (apply iup:vbox - (map (lambda (x) - (let ((res (iup:hbox #:expand "HORIZONTAL" - (iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL") - (iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL" - #:action (lambda (obj unk val) - (mark-for-update) - (update-search x val)))))) - (set! i (+ i 1)) - res)) - keynames))))) - (let loop ((testnum 0) - (res '())) - (cond - ((>= testnum ntests) - ;; now lftlst will be an hbox with the test keys and the test name labels - (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" - (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL" - #:min 0 - #:step 0.01) - (apply iup:vbox (reverse res))))))) - (else - (let ((labl (iup:button "" - #:flat "YES" - #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 - #:size "x15" - #:expand "HORIZONTAL" - #:fontsize "10" - #:action (lambda (obj) - (mark-for-update) - (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE")))) - (vector-set! lftcol testnum labl) - (loop (+ testnum 1)(cons labl res)))))) - ;; - (let loop ((runnum 0) - (keynum 0) - (keyvec (make-vector nkeys)) - (res '())) - (cond ;; nb// no else for this approach. - ((>= runnum nruns) #f) - ((>= keynum nkeys) - (vector-set! header runnum keyvec) - (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) - (loop (+ runnum 1) 0 (make-vector nkeys) '())) - (else - (let ((labl (iup:label "" #:size "60x15" #:fontsize "10" #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" - (vector-set! keyvec keynum labl) - (loop runnum (+ keynum 1) keyvec (cons labl res)))))) - ;; By here the hdrlst contains a list of vboxes containing nkeys labels - (let loop ((runnum 0) - (testnum 0) - (testvec (make-vector ntests)) - (res '())) - (cond - ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) - ((>= testnum ntests) - (vector-set! runsvec runnum testvec) - (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) - (loop (+ runnum 1) 0 (make-vector ntests) '())) - (else - (let* ((button-key (mkstr runnum testnum)) - (butn (iup:button "" ;; button-key - #:size "60x15" - #:expand "HORIZONTAL" - #:fontsize "10" - #:action (lambda (x) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref *buttondat* button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - ;(print "Launching " cmd) - (system cmd)))))) - (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) - (vector-set! testvec testnum butn) - (loop runnum (+ testnum 1) testvec (cons butn res)))))) - ;; now assemble the hdrlst and bdylst and kick off the dialog - (iup:show - (iup:dialog - #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) - #:menu (dcommon:main-menu) - (let* ((runs-view (iup:vbox - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst)))))) - controls)) - (tabs (iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (set! *please-update-buttons* #t) - (set! *current-tab-number* curr)) - (dashboard:summary db) - runs-view - (dashboard:one-run db) - (dashboard:run-controls) - ))) - ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Summary") - (iup:attribute-set! tabs "TABTITLE1" "Runs") - (iup:attribute-set! tabs "TABTITLE2" "Run Summary") - (iup:attribute-set! tabs "TABTITLE3" "Run Control") - (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - (set! *hide-not-hide-tabs* tabs) - tabs))) - (vector keycol lftcol header runsvec))) - -(if (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS" )) - (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) - (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) - -(define *tim* (iup:timer)) -(define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300) -(iup:attribute-set! *tim* "RUN" "YES") - -;; Move this stuff to db.scm? I'm not sure that is the right thing to do... -;; -(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) -(define *last-recalc-ended-time* 0) - -(define (dashboard:been-changed) - (> (file-modification-time *db-file-path*) *last-db-update-time*)) - -(define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time *db-file-path*))) - -(define (dashboard:recalc modtime please-update-buttons last-db-update-time) - (or please-update-buttons - (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) - (> modtime last-db-update-time) - (> (current-seconds)(+ last-db-update-time 1))))) - -(define *monitor-db-path* (conc *dbdir* "/monitor.db")) -(define *last-monitor-update-time* 0) - -;; Force creation of the db in case it isn't already there. -(tasks:open-db) - -(define (dashboard:get-youngest-run-db-mod-time) - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (apply max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc *dbdir* "/*.db")))))) - -(define (dashboard:run-update x) - (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) - (monitor-modtime (if (file-exists? *monitor-db-path*) - (file-modification-time *monitor-db-path*) - -1)) - (run-update-time (current-seconds)) - (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) - (if (and (eq? *current-tab-number* 0) - (or (> monitor-modtime *last-monitor-update-time*) - (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case - (begin - (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) - (if dashboard:update-servers-table (dashboard:update-servers-table)))) - (if recalc - (begin - (case *current-tab-number* - ((0) - (if dashboard:update-summary-tab (dashboard:update-summary-tab))) - ((1) ;; The runs table is active - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) - (if val (set! res (cons (list key val) res)))))) - *dbkeys*) - res)) - (update-buttons uidat *num-runs* *num-tests*)) - ((2) - (dashboard:update-run-summary-tab)) - (else - (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) - (if updater (updater))))) - (set! *please-update-buttons* #f) - (set! *last-db-update-time* modtime) - (set! *last-update* run-update-time) - (set! *last-recalc-ended-time* (current-milliseconds)))))) - -;;====================================================================== -;; The heavy lifting starts here -;;====================================================================== - -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - -(cond - ((args:get-arg "-run") - (let ((runid (string->number (args:get-arg "-run")))) - (if runid - (begin - (lambda (x) - (on-exit std-exit-procedure) - (examine-run *dbstruct-local* runid))) - (begin - (print "ERROR: runid is not a number " (args:get-arg "-run")) - (exit 1))))) - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (examine-test run-id test-id) - (begin - (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ((args:get-arg "-guimonitor") - (gui-monitor *dbstruct-local*)) - (else - (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (x) - (let ((update-is-running #f)) - (mutex-lock! *update-mutex*) - (set! update-is-running *update-is-running*) - (if (not update-is-running) - (set! *update-is-running* #t)) - (mutex-unlock! *update-mutex*) - (if (not update-is-running) - (begin - (dashboard:run-update x) - (mutex-lock! *update-mutex*) - (set! *update-is-running* #f) - (mutex-unlock! *update-mutex*)))) - 1)))) - -(let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (set! *please-update-buttons* #t) - (dashboard:run-update 1)) "update buttons once")) - ;; need to wait for first *update-is-running* #t - ;; (let loop () - ;; (mutex-lock! *update-mutex*) - ;; (if *update-is-running* - ;; (begin - ;; (set! *please-update-buttons* #t) - ;; (mark-for-update) - ;; (print "Did redraw trigger")) "First update after startup") - ;; (mutex-unlock! *update-mutex*) - ;; (thread-sleep! 1) - ;; (if (not *please-update-buttons*) - ;; (loop)))))) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th2)) - -;; (iup:main-loop)(db:close-all *dbstruct-local*) + (let* ((tree-path (tree:node->path obj id)) + (area (car tree-path)) + (area-path (cdr tree-path))) + #f + ;; (test-id (tree-path->test-id (cdr run-path)))) + ;; (if test-id + ;; (hash-table-set! (dboard:data-get-curr-test-ids *data*) + ;; window-id test-id)) + ;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) + ))))) + ;; (iup:attribute-set! tb "VALUE" "0") + ;; (iup:attribute-set! tb "NAME" "Runs") + ;; (iup:attribute-set! tb "ADDEXPANDED" "NO") + ;; (dboard:data-set-tests-tree! *data* tb) + tb)) +;; (test-panel window-id))) + +;; The function to update the fields in the test view panel +(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) + ;; get test-id + ;; then get test record + (if testdat + (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) + (test-data (hash-table-ref/default testdat test-id #f)) + (run-id (db:test-get-run_id test-data)) + (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) + run-id + '())) + (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) + (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) + (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) + + (if test-data + (begin + ;; + (for-each + (lambda (data) + (let ((mat (car data)) + (vals (cadr data)) + (rownum 1)) + (for-each + (lambda (key) + (let ((cell (conc rownum ":1"))) + (if (not (equal? (iup:attribute mat cell)(conc key))) + (begin + ;; (print "setting cell " cell " in matrix " mat " to value " key) + (iup:attribute-set! mat cell (conc key)) + (iup:attribute-set! mat "REDRAW" cell))) + (set! rownum (+ rownum 1)))) + vals))) + (list + (list run-info-matrix + (if test-id + (list (db:test-get-run_id test-data) + target + runname + "n/a") + (make-list 4 ""))) + (list test-info-matrix + (if test-id + (list test-id + (db:test-get-testname test-data) + (db:test-get-item-path test-data) + (db:test-get-state test-data) + (db:test-get-status test-data) + (seconds->string (db:test-get-event_time test-data)) + (db:test-get-comment test-data)) + (make-list 7 ""))) + (list test-run-matrix + (if test-id + (list (db:test-get-host test-data) + (db:test-get-uname test-data) + (db:test-get-diskfree test-data) + (db:test-get-cpuload test-data) + (seconds->hr-min-sec (db:test-get-run_duration test-data))) + (make-list 5 ""))) + )) + (dcommon:populate-steps steps-dat steps-matrix)))))) + ;;(list meta-dat-matrix + ;; (if test-id + ;; (list ( + + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; General displayer +;; +(define (area-display data adat window-id) + (let* ((view-matrix (iup:matrix + #:expand "YES" + ;; #:fittosize "YES" + #:scrollbar "YES" + #:numcol 100 + #:numlin 100 + #:numcol-visible 3 + #:numlin-visible 3 + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + + (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! view-matrix "WIDTH0" "100") + (dboard:area-matrix-set! adat view-matrix) + ;; (dboard:data-set-runs-matrix! *data* runs-matrix) + (iup:hbox + (iup:frame + #:title "Runs browser" + (iup:vbox + view-matrix))))) + +;; Browse and control a single run +;; +(define (runcontrol window-id) + (iup:hbox)) + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + +(define (make-area-panel data area-name window-id) + (let* ((adat (hash-table-ref areas area-name)) + (tb (tree-browser data adat window-id)) ;; (dboard:areas-tree-browser data) + (ad (area-display data adat window-id)) + (areas (dboard:data-areas data))) + (dboard:area-tree-set! adat tb) + (dboard:area-matrix-set! adat ad) + (iup:split + #:value 200 + tb ad))) + + +;; Main Panel +(define (main-panel data window-id) + (iup:dialog + #:title "Megatest Control Panel" + #:menu (dcommon:main-menu data) + #:shrink "YES" + (iup:vbox + (let* ((area-names (hash-table-keys (dboard:data-cfgdat data))) + (area-panels (map (lambda (aname) + (make-area-panel data aname window-id)) + area-names)) + (tabtop (apply iup:tabs areas))) + (let loop ((index 0) + (hed (car area-names)) + (tal (cdr area-names))) + (let* ((apath (hash-table-ref (dboard:data-cfgdat data)) hed) + (mtconf (read-config apath (make-hash-table) #f)) ;; megatest.config + (area-dat (make-megatest:area + hed ;; area name + apath ;; path to area + 'http ;; transport + (list apath mtconf) ;; configinfo (legacy) + mtconf ;; megatest.config + (make-hash-table) + #f + #f ;; remote connections + #f ;; run keys + (make-hash-table) ;; run-id -> (hash of test-ids => dat) + ))) + (hash-table-set! (dboard:data-areas data) hed + (make-dboard:area + #f ;; tree + #f ;; matrix + (and (file-exists? apath) + (file-write-access? apath)) + area-dat + hed + + )) + (debug:print 0 "Adding area " hed " with index " index " to dashboard") + (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) + (if (not (null? tal)) + (loop (+ index 1)(car tal)(cdr tal)))) + tabtop))))) + +(define (newdashboard data window-id) + (let* (;; (keys (db:get-keys *dbstruct-local* *area-dat*)) + ;; (runname "%") + ;; (testpatt "%") + ;; (keypatts (map (lambda (k)(list k "%")) keys)) + ;; (states '()) + ;; (statuses '()) + (nextmintime (current-milliseconds))) + (dboard:data-current-window-id-set! data (+ 1 (dboard:data-current-window-id data))) + ;; (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application + (iup:show (main-panel data (dboard:data-current-window-id data))) + ;; Yes, running iup:show will pop up a new panel + ;; (iup:show (main-panel my-window-id)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + (let ((starttime (current-milliseconds))) + ;; Want to dedicate no more than 50% of the time to this so skip if + ;; 2x delta time has not passed since last query + ;; (if (< (inexact->exact nextmintime)(inexact->exact starttime)) + ;; (let* ((changes (dcommon:run-update data)) ;;keys data runname keypatts testpatt states statuses 'full my-window-id)) + ;; (endtime (current-milliseconds))) + ;; (set! nextmintime (+ endtime (* 2.0 (- endtime starttime)))) + ;; ;; (debug:print 11 "CHANGE(S): " (car changes) "...") + ;; ) + ;; (debug:print-info 11 "Server overloaded"))))))) + (dcommon:run-update data)))))) + +;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id +;;; +(let* ((window-id 0) + (groupn (or (args:get-arg "-group") "default")) + (cfname (conc (getenv "HOME") "/.megatest/" groupn ".dat")) + (cfgdat (if (file-exists? cfname)(read-config cfname (make-hash-table) #t))) + (data (make-dboard:data + cfgdat ;; this is the data from ~/.megatest for the selected group + (make-hash-table) ;; areaname -> area-rec + 0 + ))) + (newdashboard data window-id) + (iup:main-loop)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -57,19 +57,19 @@ ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct run-id) +(define (db:get-db dbstruct area-dat run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (mutex-lock! *rundb-mutex*) (let ((dbdat (if (or (not run-id) (eq? run-id 0)) - (db:open-main dbstruct) - (db:open-rundb dbstruct run-id) + (db:open-main dbstruct area-dat) + (db:open-rundb dbstruct area-dat run-id) ))) ;; db prunning would go here (mutex-unlock! *rundb-mutex*) dbdat)))) @@ -98,16 +98,16 @@ (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; -(define (db:with-db dbstruct run-id r/w proc . params) +(define (db:with-db dbstruct area-dat run-id r/w proc . params) (let* ((dbdat (if (vector? dbstruct) - (db:get-db dbstruct run-id) + (db:get-db dbstruct area-dat run-id) dbstruct)) ;; cheat, allow for passing in a dbdat (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (handle-exceptions exn (begin (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) @@ -121,11 +121,11 @@ ;; (define (db:get-filedb dbstruct run-id) ;; (let ((db (vector-ref dbstruct 2))) ;; (if db ;; db -;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) +;; (let ((fdb (filedb:open-db (conc toppath "/db/files.db")))) ;; (vector-set! dbstruct 2 fdb) ;; fdb)))) ;; ;; ;; Can also be used to save arbitrary strings ;; ;; @@ -140,14 +140,16 @@ ;; (filedb:get-path db id))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; -(define (db:dbfile-path run-id) +(define (db:dbfile-path run-id area-dat) (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (dbpath (configf:lookup *configdat* "setup" "dbdir")) + (configdat (megatest:area-configdat area-dat)) + (toppath (megatest:area-path area-dat)) + (link-tree-path (configf:lookup configdat "setup" "linktree")) + (dbpath (configf:lookup configdat "setup" "dbdir")) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f)) (dbdir (if dbpath dbpath @@ -160,50 +162,50 @@ (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir fname) dbdir))) -(define (db:set-sync db) - (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) +(define (db:set-sync db area-dat) + (let ((syncprag (configf:lookup (megatest:area-configdat area-dat) "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening ;; -(define (db:lock-create-open fname initproc) +(define (db:lock-create-open fname initproc area-dat) (if (file-exists? fname) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + (db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") db) (let* ((parent-dir (pathname-directory fname)) (dir-writable (file-write-access? parent-dir))) (if dir-writable (let ((exists (file-exists? fname)) (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") + (db:set-sync db area-dat) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not exists)(initproc db)) (release-dot-lock fname) db) (begin (debug:print 0 "ERROR: no such db in non-writable dir " fname) (sqlite3:open-database fname)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; -(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-rundb dbstruct area-dat run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc toppath "/megatest.db") (car configinfo))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb - (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) + (let* ((dbpath (db:dbfile-path run-id area-dat)) ;; (conc toppath "/db/" run-id ".db")) (dbexists (file-exists? dbpath)) (inmem (if local #f (db:open-inmem-db))) (refdb (if local #f (db:open-inmem-db))) (db (db:lock-create-open dbpath ;; this is the database physically on disk (lambda (db) @@ -211,24 +213,25 @@ exn (begin (release-dot-lock dbpath) (if (> attemptnum 2) (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) - (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) + (db:open-rundb dbstruct area-dat run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute db "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" (* run-id 30000) ;; allow for up to 30k tests per run run-id) ;; do a dummy query to test that the table exists and the db is truly readable (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) - )))) ;; add strings db to rundb, not in use yet + )) + area-dat)) ;; add strings db to rundb, not in use yet ;; )) ;; (sqlite3:open-database dbpath)) (olddb (if *megatest-db* *megatest-db* - (let ((db (db:open-megatest-db))) + (let ((db (db:open-megatest-db area-dat))) (set! *megatest-db* db) db))) (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) @@ -244,29 +247,32 @@ db) (begin (dbr:dbstruct-set-inmem! dbstruct inmem) ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context - (db:sync-tables db:sync-tests-only db inmem) - (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? + (db:sync-tables area-dat db:sync-tests-only db inmem) + (db:delay-if-busy refdb area-dat) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? (dbr:dbstruct-set-refdb! dbstruct refdb) - (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db + (db:sync-tables area-dat db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db ;; sync once more to deal with delays? ;; (db:sync-tables db:sync-tests-only db inmem) ;; (db:sync-tables db:sync-tests-only inmem refdb) inmem)))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; -(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-main dbstruct area-dat) ;; (conc toppath "/megatest.db") (car configinfo))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb - (let* ((dbpath (db:dbfile-path 0)) + (let* ((dbpath (db:dbfile-path 0 area-dat)) (dbexists (file-exists? dbpath)) - (db (db:lock-create-open dbpath db:initialize-main-db)) - (olddb (db:open-megatest-db)) + (db (db:lock-create-open dbpath + (lambda (db) + (db:initialize-main-db db area-dat)) + area-dat)) + (olddb (db:open-megatest-db area-dat)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-set-main! dbstruct dbdat) @@ -273,32 +279,34 @@ (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) dbdat)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; -(define (db:setup run-id #!key (local #f)) - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define (db:setup run-id area-dat #!key (local #f)) + (let* ((dbdir (db:dbfile-path #f area-dat)) ;; (conc (configf:lookup configdat "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; -(define (db:open-megatest-db) - (let* ((dbpath (conc *toppath* "/megatest.db")) +(define (db:open-megatest-db area-dat) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc toppath "/megatest.db")) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db) - (db:initialize-run-id-db db)))) + (db:initialize-main-db db area-dat) + (db:initialize-run-id-db db)) + area-dat)) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched ;; -(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) +(define (db:sync-touched dbstruct area-dat run-id #!key (force-sync #f)) (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) (stime (dbr:dbstruct-get-stime dbstruct)) (rundb (dbr:dbstruct-get-rundb dbstruct)) (inmem (dbr:dbstruct-get-inmem dbstruct)) (maindb (dbr:dbstruct-get-main dbstruct)) @@ -314,13 +322,13 @@ (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin - (db:delay-if-busy maindb) - (db:delay-if-busy olddb) - (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (db:delay-if-busy maindb area-dat) + (db:delay-if-busy olddb area-dat) + (let ((num-synced (db:sync-tables area-dat (db:sync-main-list maindb area-dat) maindb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) @@ -332,49 +340,49 @@ (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin - (db:delay-if-busy rundb) - (db:delay-if-busy olddb) + (db:delay-if-busy rundb area-dat) + (db:delay-if-busy olddb area-dat) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) - (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (let ((num-synced (db:sync-tables area-dat db:sync-tests-only inmem refdb rundb olddb))) ;; (mutex-unlock! *http-mutex*) num-synced) (begin ;; (mutex-unlock! *http-mutex*) 0)))))) -(define (db:close-main dbstruct) +(define (db:close-main dbstruct area-dat) (let ((maindb (dbr:dbstruct-get-main dbstruct))) (if maindb (begin (sqlite3:finalize! (db:dbdat-get-db maindb)) (dbr:dbstruct-set-main! dbstruct #f))))) -(define (db:close-run-db dbstruct run-id) +(define (db:close-run-db dbstruct area-dat run-id) (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) (if (and rdb (sqlite3:database? rdb)) (begin (sqlite3:finalize! rdb) (dbr:dbstruct-set-localdb! dbstruct run-id #f) (dbr:dbstruct-set-inmem! dbstruct #f))))) ;; close all opened run-id dbs -(define (db:close-all dbstruct) +(define (db:close-all dbstruct area-dat) ;; finalize main.db - (db:sync-touched dbstruct 0 force-sync: #t) + (db:sync-touched dbstruct area-dat 0 force-sync: #t) ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? - (db:close-main dbstruct) + (db:close-main dbstruct area-dat) (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) - (db:close-run-db dbstruct run-id)) + (db:close-run-db dbstruct area-dat run-id)) (hash-table-keys locdbs)))) ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) ;; (if local @@ -460,12 +468,12 @@ '("status" #f) '("type" #f)))) ;; needs db to get keys, this is for syncing all tables ;; -(define (db:sync-main-list db) - (let ((keys (db:get-keys db))) +(define (db:sync-main-list db area-dat) + (let ((keys (db:get-keys db area-dat))) (list (list "keys" '("id" #f) '("fieldname" #f) '("fieldtype" #f)) @@ -488,11 +496,11 @@ '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) +(define (db:sync-tables area-dat tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") @@ -537,11 +545,11 @@ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) + (batch-len (string->number (or (configf:lookup (megatest:area-configdat area-dat) "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each @@ -631,53 +639,53 @@ ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; -(define (db:multi-db-sync run-ids . options) - (let* ((toppath (launch:setup-for-run)) +(define (db:multi-db-sync run-ids area-dat . options) + (let* ((toppath (launch:setup-for-run area-dat)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) - (mtdb (if toppath (db:open-megatest-db))) + (mtdb (if toppath (db:open-megatest-db area-dat))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids (if toppath (begin - (db:delay-if-busy mtdb) - (db:get-all-run-ids mtdb))))) - (tdbdat (tasks:open-db)) - (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (db:delay-if-busy mtdb area-dat) + (db:get-all-run-ids mtdb area-dat))))) + (tdbdat (tasks:open-db area-dat)) + (servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat)))) ;; kill servers (if (member 'killservers options) (for-each (lambda (server) - (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") + (tasks:server-delete-record (db:delay-if-busy tdbdat area-dat) (vector-ref server 0) "dbmigration") (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) (begin - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (db:clean-up mtdb))) ;; adjust test-ids to fit into proper range ;; (if (member 'adj-testids options) (begin - (db:delay-if-busy mtdb) - (db:prep-megatest.db-for-migration mtdb))) + (db:delay-if-busy mtdb area-dat) + (db:prep-megatest.db-for-migration mtdb area-dat))) ;; sync runs, test_meta etc. ;; (if (member 'old2new options) (begin - (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (db:sync-tables area-dat (db:sync-main-list mtdb area-dat) mtdb (db:get-db dbstruct area-dat #f)) (for-each (lambda (run-id) - (db:delay-if-busy mtdb) + (db:delay-if-busy mtdb area-dat) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) @@ -686,36 +694,36 @@ ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; (if (member 'new2old options) (let* ((maindb (make-dbr:dbstruct path: toppath local: #t)) - (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))) + (src-run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb area-dat 0)) area-dat)) (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <)) (count 1) (total (length all-run-ids)) (dead-runs '())) (for-each (lambda (run-id) (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) (set! count (+ count 1)) (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) + (frundb (db:dbdat-get-db (db:get-db fromdb area-dat run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) ;; (db:clean-up frundb) (if (eq? run-id 0) (begin - (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) - (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) + (db:sync-tables area-dat (db:sync-main-list dbstruct area-dat) (db:get-db fromdb area-dat #f) mtdb) + (set! dead-runs (db:clean-up-maindb (db:get-db fromdb area-dat #f) area-dat))) (begin ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) - (db:clean-up-rundb (db:get-db fromdb run-id)) + (db:sync-tables area-dat db:sync-tests-only (db:get-db fromdb area-dat run-id) mtdb) + (db:clean-up-rundb (db:get-db fromdb area-dat run-id) area-dat) )))) all-run-ids) ;; removed deleted runs - (let ((dbdir (tasks:get-task-db-path))) + (let ((dbdir (tasks:get-task-db-path area-dat))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) (if (file-exists? fullname) (begin (debug:print 0 "Removing database file for deleted run " fullname) @@ -766,12 +774,12 @@ (define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) -(define (db:initialize-main-db dbdat) - (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... +(define (db:initialize-main-db dbdat area-dat) + (let* ((configdat (megatest:area-configdat area-dat)) ;; (car configinfo)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys)) (db (db:dbdat-get-db dbdat))) @@ -954,12 +962,12 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; -(define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db +(define (db:archive-get-allocations dbstruct area-dat testname itempath dneeded) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) @@ -985,12 +993,12 @@ blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; -(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db +(define (db:archive-register-disk dbstruct area-dat bdisk-name bdisk-path df) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1007,18 +1015,18 @@ (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) - (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) + (db:archive-register-disk dbstruct area-dat bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; -(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db +(define (db:archive-register-block-name dbstruct area-dat bdisk-id archive-path #!key (du #f)) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) @@ -1034,29 +1042,30 @@ res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) - (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) + (db:archive-register-block-name dbstruct area-dat bdisk-id archive-path du: du))))) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; -(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) +(define (db:test-set-archive-block-id dbstruct area-dat run-id area-dat test-id archive-block-id) (db:with-db - dbstruct + dbstruct area-dat run-id + area-dat #f (lambda (db) (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; -(define (db:test-get-archive-block-info dbstruct archive-block-id) +(define (db:test-get-archive-block-info dbstruct area-dat archive-block-id) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row @@ -1077,22 +1086,23 @@ ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== -(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) +(define (open-logging-db area-dat) ;; (conc toppath "/megatest.db") (car configinfo))) + (let* ((toppath (megatest:area-path area-dat)) + (dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + (db:set-sync db area-dat) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) )) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) @@ -1114,17 +1124,17 @@ ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== -(define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) +(define (db:have-incompletes? dbstruct area-dat run-id ovr-deadtime) + (let* ((dbdat (db:get-db dbstruct area-dat run-id)) (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1133,11 +1143,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1149,11 +1159,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1173,17 +1183,17 @@ ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); -(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((dbdat (db:get-db dbstruct run-id)) +(define (db:find-and-mark-incomplete dbstruct area-dat run-id ovr-deadtime area-dat) + (let* ((dbdat (db:get-db dbstruct area-dat run-id)) (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime-str (configf:lookup (megatest:area-configdat area-dat) "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) @@ -1192,11 +1202,11 @@ ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1208,11 +1218,11 @@ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? @@ -1224,11 +1234,11 @@ (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete @@ -1245,11 +1255,11 @@ (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) @@ -1283,11 +1293,11 @@ ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1297,11 +1307,11 @@ (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1311,11 +1321,11 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up-rundb dbdat) +(define (db:clean-up-rundb dbdat area-dat) ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) @@ -1324,11 +1334,11 @@ ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1338,11 +1348,11 @@ (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -1352,11 +1362,11 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up-maindb dbdat) +(define (db:clean-up-maindb dbdat area-dat) ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) @@ -1371,11 +1381,11 @@ (sqlite3:for-each-row (lambda (run-id) (set! dead-runs (cons run-id dead-runs))) db "SELECT id FROM runs WHERE state='deleted';") - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) @@ -1385,11 +1395,11 @@ (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S @@ -1398,18 +1408,18 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; ;; Operates on megatestdb ;; -(define (db:get-var dbstruct var) +(define (db:get-var dbstruct area-dat var area-dat) (let* ((start-ms (current-milliseconds)) - (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) + (throttle (let ((t (config-lookup (megatest:area-configdat area-dat) "setup" "throttle"))) (if t (string->number t) t))) (res #f) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) @@ -1425,41 +1435,39 @@ (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) res)) -(define (db:set-var dbstruct var val) - (let ((dbdat (db:get-db dbstruct #f)) +(define (db:set-var dbstruct area-dat var val) + (let ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) -(define (db:del-var dbstruct var) +(define (db:del-var dbstruct area-dat var) ;; (db:delay-if-busy) - (db:with-db dbstruct #f #t + (db:with-db dbstruct area-dat #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change -;; why get the keys from the db? why not get from the *configdat* +;; why get the keys from the db? why not get from the configdat ;; using keys:config-get-fields? -(define (db:get-keys dbstruct) - (if *db-keys* *db-keys* - (let ((res '())) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) - res))) +(define (db:get-keys dbstruct area-dat) + (let ((res '())) + (db:with-db dbstruct area-dat #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (key) + (set! res (cons key res))) + db + "SELECT fieldname FROM keys ORDER BY id DESC;"))) + res)) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (null? header) #f (let loop ((hed (car header)) @@ -1476,13 +1484,13 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (db:get-run-name-from-id dbstruct run-id) +(define (db:get-run-name-from-id dbstruct area-dat run-id) (db:with-db - dbstruct + dbstruct area-dat #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) (sqlite3:for-each-row @@ -1491,13 +1499,13 @@ db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) -(define (db:get-run-key-val dbstruct run-id key) +(define (db:get-run-key-val dbstruct area-dat run-id key) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row @@ -1530,12 +1538,12 @@ ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; -(define (db:register-run dbstruct keyvals runname state status user) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:register-run dbstruct area-dat keyvals runname state status user) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat)) (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) @@ -1545,23 +1553,23 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "NOTE: using target " (string-intersperse (map cadr 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)) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (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) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (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) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) @@ -1569,13 +1577,13 @@ ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; -(define (db:get-runs dbstruct runpatt count offset keypatts) +(define (db:get-runs dbstruct area-dat runpatt count offset keypatts) (let* ((res '()) - (keys (db:get-keys dbstruct)) + (keys (db:get-keys dbstruct area-dat)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) @@ -1596,11 +1604,11 @@ "") (if (number? offset) (conc " OFFSET " offset) "")))) (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (db:with-db dbstruct #f #f + (db:with-db dbstruct area-dat #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db @@ -1616,11 +1624,11 @@ ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; ;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames ;; -(define (db:get-run-ids-matching dbstruct keynames target res) +(define (db:get-run-ids-matching dbstruct area-dat keynames target res) ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) @@ -1642,31 +1650,31 @@ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (db:with-db dbstruct area-dat #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) - (db:get-db dbstruct #f) + (db:get-db dbstruct area-dat #f) qry-str runnamepatt))) (vector header res))) ;; Get all targets from the db ;; -(define (db:get-targets dbstruct) +(define (db:get-targets dbstruct area-dat) (let* ((res '()) - (keys (db:get-keys dbstruct)) + (keys (db:get-keys dbstruct area-dat)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) @@ -1679,13 +1687,13 @@ qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs -(define (db:get-num-runs dbstruct runpatt) +(define (db:get-num-runs dbstruct area-dat runpatt) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) @@ -1695,13 +1703,13 @@ db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)))) -(define (db:get-all-run-ids dbstruct) +(define (db:get-all-run-ids dbstruct area-dat) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (let ((run-ids '())) (sqlite3:for-each-row @@ -1713,19 +1721,19 @@ ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats dbstruct) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:get-run-stats dbstruct area-dat) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat)) (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted';") @@ -1734,11 +1742,11 @@ (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) (run-name (cadr run-info))) (db:with-db - dbstruct + dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (state status count) @@ -1765,11 +1773,11 @@ ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) +(define (db:get-runs-by-patt dbstruct area-dat keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1790,11 +1798,11 @@ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (db:with-db dbstruct area-dat #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) db @@ -1801,23 +1809,23 @@ qry-str runnamepatt))) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) -(define (db:get-run-info dbstruct run-id) +(define (db:get-run-info dbstruct area-dat run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) - (let* ((dbdat (db:get-db dbstruct #f)) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat)) (res (vector #f #f #f #f)) - (keys (db:get-keys dbstruct)) + (keys (db:get-keys dbstruct area-dat)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") @@ -1825,44 +1833,44 @@ (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) -(define (db:set-comment-for-run dbstruct run-id comment) +(define (db:set-comment-for-run dbstruct area-dat run-id comment) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run dbstruct run-id) +(define (db:delete-run dbstruct area-dat run-id) ;; First set any related tests to DELETED - (let* ((rdbdat (db:get-db dbstruct run-id)) + (let* ((rdbdat (db:get-db dbstruct area-dat run-id)) (rdb (db:dbdat-get-db rdbdat)) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy rdbdat) + (db:delay-if-busy rdbdat area-dat) (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute rdb "DELETE FROM test_steps;") (sqlite3:execute rdb "DELETE FROM test_data;") - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) -(define (db:update-run-event_time dbstruct run-id) +(define (db:update-run-event_time dbstruct area-dat run-id) (db:with-db - dbstruct + dbstruct area-dat #f #t (lambda (db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) -(define (db:lock/unlock-run dbstruct run-id lock unlock user) +(define (db:lock/unlock-run dbstruct area-dat run-id lock unlock user) (db:with-db - dbstruct + dbstruct area-dat #f #t (lambda (db) (let ((newlockval (if lock "locked" (if unlock @@ -1871,22 +1879,22 @@ (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))))) -(define (db:set-run-status dbstruct run-id status msg) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:set-run-status dbstruct area-dat run-id status msg) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) -(define (db:get-run-status dbstruct run-id) +(define (db:get-run-status dbstruct area-dat run-id) (let ((res "n/a")) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (sqlite3:for-each-row (lambda (status) @@ -1900,36 +1908,36 @@ ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs dbstruct run-id) - (let* ((keys (db:get-keys dbstruct)) +(define (db:get-key-val-pairs dbstruct area-dat run-id) + (let* ((keys (db:get-keys dbstruct area-dat)) (res '()) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id -(define (db:get-key-vals dbstruct run-id) - (let* ((keys (db:get-keys dbstruct)) +(define (db:get-key-vals dbstruct area-dat run-id) + (let* ((keys (db:get-keys dbstruct area-dat)) (res '()) - (dbdat (db:get-db dbstruct #f)) + (dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) @@ -1936,24 +1944,24 @@ (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often -(define (db:get-target dbstruct run-id) - (let* ((keyvals (db:get-key-vals dbstruct run-id)) +(define (db:get-target dbstruct area-dat run-id) + (let* ((keyvals (db:get-key-vals dbstruct area-dat run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; -(define (db:get-prev-run-ids dbstruct run-id) +(define (db:get-prev-run-ids dbstruct area-dat run-id) (let* ((keyvals (rmt:get-key-val-pairs run-id)) (kvalues (map cadr keyvals)) (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) - (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db + (db:with-db dbstruct area-dat #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db @@ -1966,11 +1974,11 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) +(define (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) @@ -2022,11 +2030,11 @@ (if limit (conc " LIMIT " limit) " ") (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f + (db:with-db dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db @@ -2049,17 +2057,17 @@ -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) -(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) +(define (db:get-tests-for-run-state-status dbstruct area-dat run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) - (db:with-db dbstruct run-id #f + (db:with-db dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) @@ -2066,13 +2074,13 @@ db qry run-id))) res)) -(define (db:get-testinfo-state-status dbstruct run-id test-id) +(define (db:get-testinfo-state-status dbstruct area-dat run-id test-id) (let ((res #f)) - (db:with-db dbstruct run-id #f + (db:with-db dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (run-id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) @@ -2082,53 +2090,53 @@ res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} ;; -(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) +(define (db:get-tests-for-runs-mindata dbstruct area-dat run-ids testpatt states statuses not-in) (debug:print 0 "ERROR: BROKN!") ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ) ;; get a useful subset of the tests data (used in dashboard ;; -(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-run-mindata dbstruct area-dat run-id testpatt states statuses not-in) + (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) ;; do not use. ;; -(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) +(define (db:get-tests-for-runs dbstruct area-dat run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) ;; (db:delay-if-busy) (let ((res '())) (for-each (lambda (run-id) (set! res (append res - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) + (db:get-tests-for-run dbstruct area-dat run-id testpatt states statuses #f #f not-in #f #f qryvals)))) (if run-ids run-ids - (db:get-all-run-ids dbstruct))) + (db:get-all-run-ids dbstruct area-dat))) res)) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; -(define (db:delete-test-records dbstruct run-id test-id) - (let* ((dbdat (db:get-db dbstruct run-id)) +(define (db:delete-test-records dbstruct area-dat run-id test-id) + (let* ((dbdat (db:get-db dbstruct area-dat run-id)) (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) -(define (db:delete-old-deleted-test-records dbstruct) - (let ((run-ids (db:get-all-run-ids dbstruct)) +(define (db:delete-old-deleted-test-records dbstruct area-dat) + (let ((run-ids (db:get-all-run-ids dbstruct area-dat)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) (db:with-db - dbstruct + dbstruct area-dat run-id #t (lambda (db) (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timetest-data dbstruct run-id test-id csvdata) +(define (db:csv->test-data dbstruct area-dat run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let* ((dbdat (db:get-db dbstruct run-id)) + (let* ((dbdat (db:get-db dbstruct area-dat run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) @@ -2605,21 +2613,21 @@ ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== -(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:get-run-ids-matching-target dbstruct area-dat keynames target res runname testpatt statepatt statuspatt) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat)) (row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) @@ -2634,15 +2642,15 @@ (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) row-ids)) -(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) +(define (db:test-get-paths-matching-keynames-target-new dbstruct area-dat run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db - dbstruct + dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (p) @@ -2649,13 +2657,13 @@ (set! res (cons p res))) db tstsqry) res)))) -(define (db:test-toplevel-num-items dbstruct run-id testname) +(define (db:test-toplevel-num-items dbstruct area-dat run-id testname) (db:with-db - dbstruct + dbstruct area-dat run-id #f (lambda (db) (let ((res 0)) (sqlite3:for-each-row @@ -2701,34 +2709,34 @@ (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (db:test-set-status-state dbstruct run-id test-id status state msg) - (let ((dbdat (db:get-db dbstruct run-id))) +(define (db:test-set-status-state dbstruct area-dat run-id test-id status state msg) + (let ((dbdat (db:get-db dbstruct area-dat run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbdat 'set-test-start-time (list test-id))) (if msg (db:general-call dbdat 'state-status-msg (list state status msg test-id)) (db:general-call dbdat 'state-status (list state status test-id))))) -(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) +(define (db:roll-up-pass-fail-counts dbstruct area-dat run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) - (let ((dbdat (db:get-db dbstruct run-id))) + (let ((dbdat (db:get-db dbstruct area-dat run-id))) (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") (db:general-call dbdat 'top-test-set-running (list test-name)) (if (equal? status "LAUNCHED") (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) #f) #f)) -(define (db:test-get-logfile-info dbstruct run-id test-name) +(define (db:test-get-logfile-info dbstruct area-dat run-id test-name) (db:with-db - dbstruct + dbstruct area-dat run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row @@ -2830,48 +2838,48 @@ sync set-verbosity killserver )) -(define (db:login dbstruct calling-path calling-version run-id client-signature) +(define (db:login dbstruct area-dat area-dat calling-path calling-version run-id client-signature) (cond - ((not (equal? calling-path *toppath*)) - (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) + ((not (equal? calling-path (megatest:area-path area-dat))) + (list #f "Login failed due to mismatch paths: " calling-path ", " (megatest:area-path area-dat))) ((not (equal? *run-id* run-id)) (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbdat stmtname params) +(define (db:general-call dbdat stmtname params area-dat) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; -(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) - (let* ((dbdat (db:get-db dbstruct #f)) +(define (db:get-matching-previous-test-run-records dbstruct area-dat run-id test-name item-path) + (let* ((dbdat (db:get-db dbstruct area-dat #f)) (db (db:dbdat-get-db dbdat)) - (keys (db:get-keys db)) + (keys (db:get-keys db area-dat)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id - (db:delay-if-busy dbdat) + (db:delay-if-busy dbdat area-dat) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) @@ -2888,11 +2896,11 @@ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct area-dat run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) @@ -2906,12 +2914,12 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -(define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) +(define (db:delay-if-busy dbdat area-dat #!key (count 6)) + (if (not (configf:lookup (megatest:area-configdat area-dat) "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) @@ -2918,41 +2926,41 @@ (if (handle-exceptions exn (begin (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) + (db:delay-if-busy dbdat area-dat count: (- count 1))) (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) + (db:delay-if-busy dbdat area-dat count: 5)) ((5) (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) + (db:delay-if-busy dbdat area-dat count: 4)) ((4) (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) + (db:delay-if-busy dbdat area-dat count: 3)) ((3) (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) + (db:delay-if-busy dbdat area-dat count: 2)) ((2) (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) + (db:delay-if-busy dbdat area-dat count: 1)) ((1) (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) + (db:delay-if-busy dbdat area-dat count: 0)) (else (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) -(define (db:test-get-records-for-index-file dbstruct run-id test-name) +(define (db:test-get-records-for-index-file dbstruct area-dat run-id test-name) (let ((res '())) (db:with-db - dbstruct + dbstruct area-dat run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) @@ -2965,14 +2973,14 @@ ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record dbstruct testname) +(define (db:testmeta-get-record dbstruct area-dat testname) (let ((res #f)) (db:with-db - dbstruct + dbstruct area-dat #f #f (lambda (db) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) @@ -2981,27 +2989,27 @@ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)))) ;; create a new record for a given testname -(define (db:testmeta-add-record dbstruct testname) - (db:with-db dbstruct #f #f +(define (db:testmeta-add-record dbstruct area-dat testname) + (db:with-db dbstruct area-dat #f #f (lambda (db) (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields -(define (db:testmeta-update-field dbstruct testname field value) - (db:with-db dbstruct #f #f +(define (db:testmeta-update-field dbstruct area-dat testname field value) + (db:with-db dbstruct area-dat #f #f (lambda (db) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) -(define (db:testmeta-get-all dbstruct) - (db:with-db dbstruct #f #f +(define (db:testmeta-get-all dbstruct area-dat) + (db:with-db dbstruct area-dat #f #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) @@ -3034,12 +3042,12 @@ ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; -;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) -(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) +;; (define (db:get-prereqs-not-met dbstruct area-dat run-id waitons ref-item-path mode) +(define (db:get-prereqs-not-met dbstruct area-dat run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) @@ -3046,11 +3054,11 @@ (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + (let ((tests (db:get-tests-for-run-state-status dbstruct area-dat run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) @@ -3108,11 +3116,11 @@ ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) -(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) +(define (db:extract-ods-file dbstruct area-dat outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (windows (and pathmod (substring-index "\\" pathmod))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -32,76 +32,105 @@ ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; -;; A single data structure for all the data used in a dashboard. -;; Share this structure between newdashboard and dashboard with the -;; intent of converging on a single app. +;; A single data structure for all the data used in a dashboard for +;; all areas tracked. +;; + + +(define-record dboard:data + cfgdat ;; data from ~/.megatest/.dat + areas ;; hash of areaname -> area-rec + current-window-id + ) + +(define-record dboard:area + tree + matrix + read-only ;; #t => can't write + area-dat ;; the one-structure (one day dbstruct will be put in here) + name ;; name for this area + mpath ;; path to the megatest home (MT_RUN_AREA_HOME) + view-path ;; //... + view-type ;; standard, etc. + matrix ;; the spreadsheet + controls ;; the controls + data ;; all the data kept in sync with db + filters ;; user filters + run-id ;; the current run-id + test-ids ;; the current test id hash, run-id => test-id + command ;; the command from the entry field + ;; dbstruct ;; not needed + ) + +(define-record dboard:filter + target ;; hash of widgets for the target + runname ;; the runname widget + testpatt ;; the testpatt widget + ) + +;; Use megatest:area from common.scm for an area record + +;;====================================================================== +;; D O T F I L E +;;====================================================================== + +;; write a sexp list to fname +;; +(define (dcommon:write-dotfile fname dat) + (with-output-to-file fname + (lambda () + (pp dat)))) + +(define (dcommon:read-dotfile fname) + (if (file-exists? fname) + (with-input-from-file fname + (lambda () + (read))) + '())) + +;; gets the name for the file ~/.megatest/ +;; creates .megatest dir if not there +;; +(define (dcommon:get-dot-file-pathn name) + (let* ((dot-dir (conc (get-environment-variable "HOME") "/.megatest")) + (dfile (conc dot-dir "/" name))) + (if (not (file-exists? dot-dir)) + (create-directory dot-dir)) + dfile)) + +;; dat is the top level data stucture that contains all the info being +;; displayed in all runs etc. +;; +(define (dcommon:dotfiles-save-areas data) + (let* ((areas-dat (dcommon:data-get-areas data)) + (areas-dfile (dcommon:get-dot-file-pathn "areas"))) + (dcommon:write-dotfile areas-dfile areas-dat))) + +;; returns alist of area => path +;; +(define (dcommon:data-get-areas data) + (let ((area-names (hash-table-keys data))) + (map (lambda (area-name) + (cons area-name + (dboard:data-get-area-path (hash-table-ref data area-name)))) + area-names))) + +;; Fill the hash table data with area => area-record ;; -(define *data* (make-vector 25 #f)) -(define (dboard:data-get-runs vec) (vector-ref vec 0)) -(define (dboard:data-get-tests vec) (vector-ref vec 1)) -(define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) -(define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) -(define (dboard:data-get-run-keys vec) (vector-ref vec 4)) -(define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) -;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) -(define (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) -(define (dboard:data-get-updaters vec) (vector-ref vec 8)) -(define (dboard:data-get-path-run-ids vec) (vector-ref vec 9)) -(define (dboard:data-get-curr-run-id vec) (vector-ref vec 10)) -(define (dboard:data-get-runs-tree vec) (vector-ref vec 11)) -;; For test-patts convert #f to "" -(define (dboard:data-get-test-patts vec) - (let ((val (vector-ref vec 12)))(if val val ""))) -(define (dboard:data-get-states vec) (vector-ref vec 13)) -(define (dboard:data-get-statuses vec) (vector-ref vec 14)) -(define (dboard:data-get-logs-textbox vec val)(vector-ref vec 15)) -(define (dboard:data-get-command vec) (vector-ref vec 16)) -(define (dboard:data-get-command-tb vec) (vector-ref vec 17)) -(define (dboard:data-get-target vec) (vector-ref vec 18)) -(define (dboard:data-get-target-string vec) - (let ((targ (dboard:data-get-target vec))) - (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) -(define (dboard:data-get-run-name vec) (vector-ref vec 19)) -(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) - -(define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) -(define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) -(define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) -(define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) -(define (dboard:data-set-run-keys! vec val)(vector-set! vec 4 val)) -(define (dboard:data-set-curr-test-ids! vec val)(vector-set! vec 5 val)) -;; (define (dboard:data-set-test-details! vec val)(vector-set! vec 6 val)) -(define (dboard:data-set-path-test-ids! vec val)(vector-set! vec 7 val)) -(define (dboard:data-set-updaters! vec val)(vector-set! vec 8 val)) -(define (dboard:data-set-path-run-ids! vec val)(vector-set! vec 9 val)) -(define (dboard:data-set-curr-run-id! vec val)(vector-set! vec 10 val)) -(define (dboard:data-set-runs-tree! vec val)(vector-set! vec 11 val)) -;; For test-patts convert "" to #f -(define (dboard:data-set-test-patts! vec val) - (vector-set! vec 12 (if (equal? val "") #f val))) -(define (dboard:data-set-states! vec val)(vector-set! vec 13 val)) -(define (dboard:data-set-statuses! vec val)(vector-set! vec 14 val)) -(define (dboard:data-set-logs-textbox! vec val)(vector-set! vec 15 val)) -(define (dboard:data-set-command! vec val)(vector-set! vec 16 val)) -(define (dboard:data-set-command-tb! vec val)(vector-set! vec 17 val)) -(define (dboard:data-set-target! vec val)(vector-set! vec 18 val)) -(define (dboard:data-set-run-name! vec val)(vector-set! vec 19 val)) -(define (dboard:data-set-runs-listbox! vec val)(vector-set! vec 20 val)) - -(dboard:data-set-run-keys! *data* (make-hash-table)) - -;; List of test ids being viewed in various panels -(dboard:data-set-curr-test-ids! *data* (make-hash-table)) - -;; Look up test-ids by (key1 key2 ... testname [itempath]) -(dboard:data-set-path-test-ids! *data* (make-hash-table)) - -;; Look up run-ids by ?? -(dboard:data-set-path-run-ids! *data* (make-hash-table)) +(define (dcommon:read-areas-init-data data) + (let* ((dfile (dcommon:get-dot-file-pathn "areas")) + (areas-dfile (dcommon:read-dotfile dfile))) + (for-each + (lambda (area) + (let ((rec (vector 25 #f))) + (dboard:data-set-area-path! rec (cdr area)) + (dboard:data-set-updaters! rec (make-hash-table)) + (hash-table-set! data (car area) rec))) + areas-dfile))) ;;====================================================================== ;; TARGET AND PATTERN MANIPULATIONS ;;====================================================================== @@ -111,175 +140,171 @@ (string-substitute (regexp ",") "\n" test-patt)) (define (dboard:lines->test-patt lines) (string-substitute (regexp "\n") "," lines #t)) - ;;====================================================================== ;; P R O C E S S R U N S ;;====================================================================== -;; MOVE THIS INTO *data* -(define *cachedata* (make-hash-table)) -(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) -(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) - ;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) - (let* (;; count and offset => #f so not used - ;; the synchash calls modify the "data" hash - (get-runs-sig (conc (client:get-signature) " get-runs")) - (get-tests-sig (conc (client:get-signature) " get-tests")) - (get-details-sig (conc (client:get-signature) " get-test-details")) - - ;; test-ids to get and display are indexed on window-id in curr-test-ids hash - (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) - ;; run-id is #f in next line to send the query to server 0 - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) - (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) - '())) - - ;; Now can calculate the run-ids - (run-hash (hash-table-ref/default data get-runs-sig #f)) - (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) - - (all-test-changes (let ((res (make-hash-table))) - (for-each (lambda (run-id) - (if (> run-id 0) - (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) - run-ids) - res)) - (runs-hash (hash-table-ref/default data get-runs-sig #f)) - (header (hash-table-ref/default runs-hash "header" #f)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a header "event_time")) - (time-b (db:get-value-by-header record-b header "event_time"))) - (> time-a time-b))) - )) - (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) - (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) - (colnum 1) - (rownum 0)) ;; rownum = 0 is the header -;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) - - ;; tests related stuff - ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) - - ;; Given a run-id and testname/item_path calculate a cell R:C - - ;; NOTE: Also build the test tree browser and look up table - ;; - ;; Each run is unique on its keys and runname or run-id, store in hash on colnum - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) - keys)) - (run-name (db:get-value-by-header run-record header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) col-name) - (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (set! colnum (+ colnum 1)))) - run-ids) - - ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table - ;; Do this analysis in the order of the run-ids, the most recent run wins - (for-each (lambda (run-id) - (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) - (test-changes (hash-table-ref all-test-changes run-id)) - (new-test-dat (car test-changes)) - (removed-tests (cadr test-changes)) - (tests (sort (map cadr (filter (lambda (testrec) - (eq? run-id (db:mintest-get-run_id (cadr testrec)))) - new-test-dat)) - (lambda (a b) - (let ((time-a (db:mintest-get-event_time a)) - (time-b (db:mintest-get-event_time b))) - (> time-a time-b))))) - ;; test-changes is a list of (( id record ) ... ) - ;; Get list of test names sorted by time, remove tests - (test-names (delete-duplicates (map (lambda (t) - (let ((i (db:mintest-get-item_path t)) - (n (db:mintest-get-testname t))) - (if (string=? i "") - (conc " " i) - n))) - tests))) - (colnum (car (hash-table-ref runid-to-col run-id)))) - ;; for each test name get the slot if it exists and fill in the cell - ;; or take the next slot and fill in the cell, deal with items in the - ;; run view panel? The run view panel can have a tree selector for - ;; browsing the tests/items - - ;; SWITCH THIS TO USING CHANGED TESTS ONLY - (for-each (lambda (test) - (let* ((test-id (db:mintest-get-id test)) - (state (db:mintest-get-state test)) - (status (db:mintest-get-status test)) - (testname (db:mintest-get-testname test)) - (itempath (db:mintest-get-item_path test)) - (fullname (conc testname "/" itempath)) - (dispname (if (string=? itempath "") testname (conc " " itempath))) - (rownum (hash-table-ref/default testname-to-row fullname #f)) - (test-path (append run-path (if (equal? itempath "") - (list testname) - (list testname itempath)))) - (tb (dboard:data-get-tests-tree *data*))) - (print "INFONOTE: run-path: " run-path) - (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" - test-path - userdata: (conc "test-id: " test-id)) - (let ((node-num (tree:find-node tb (cons "Runs" test-path))) - (color (car (gutils:get-color-for-state-status state status)))) - (debug:print 0 "node-num: " node-num ", color: " color) - (iup:attribute-set! tb (conc "COLOR" node-num) color)) - (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) - (if (not rownum) - (let ((rownums (hash-table-values testname-to-row))) - (set! rownum (if (null? rownums) - 1 - (+ 1 (apply max rownums)))) - (hash-table-set! testname-to-row fullname rownum) - ;; create the label - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" 0) dispname) - )) - ;; set the cell text and color - ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc rownum ":" colnum) - (if (member state '("ARCHIVED" "COMPLETED")) - status - state)) - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) - (conc "BGCOLOR" rownum ":" colnum) - (car (gutils:get-color-for-state-status state status))) - )) - tests))) - run-ids) - - (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) - (if updater (updater (hash-table-ref/default data get-details-sig #f)))) - - (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") - ;; (debug:print 2 "run-changes: " run-changes) - ;; (debug:print 2 "test-changes: " test-changes) - (list run-changes all-test-changes))) +(define (dcommon:run-update data) + (thread-sleep! 0.25)) + +;; (let* (;; count and offset => #f so not used +;; ;; the synchash calls modify the "data" hash +;; (get-runs-sig (conc (client:get-signature) " get-runs")) +;; (get-tests-sig (conc (client:get-signature) " get-tests")) +;; (get-details-sig (conc (client:get-signature) " get-test-details")) +;; +;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash +;; (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) +;; ;; run-id is #f in next line to send the query to server 0 +;; (run-changes (synchash:client-get *area-dat* 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) +;; (tests-detail-changes (if (not (null? test-ids)) +;; (synchash:client-get *area-dat* 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) +;; '())) +;; +;; ;; Now can calculate the run-ids +;; (run-hash (hash-table-ref/default data get-runs-sig #f)) +;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) +;; +;; (all-test-changes (let ((res (make-hash-table))) +;; (for-each (lambda (run-id) +;; (if (> run-id 0) +;; (hash-table-set! res run-id (synchash:client-get *area-dat* 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) +;; run-ids) +;; res)) +;; (runs-hash (hash-table-ref/default data get-runs-sig #f)) +;; (header (hash-table-ref/default runs-hash "header" #f)) +;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) +;; (lambda (a b) +;; (let* ((record-a (hash-table-ref runs-hash a)) +;; (record-b (hash-table-ref runs-hash b)) +;; (time-a (db:get-value-by-header record-a header "event_time")) +;; (time-b (db:get-value-by-header record-b header "event_time"))) +;; (> time-a time-b))) +;; )) +;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) +;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) +;; (colnum 1) +;; (rownum 0)) ;; rownum = 0 is the header +;; ;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; +;; ;; tests related stuff +;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) +;; +;; ;; Given a run-id and testname/item_path calculate a cell R:C +;; +;; ;; NOTE: Also build the test tree browser and look up table +;; ;; +;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum +;; (for-each (lambda (run-id) +;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) +;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) +;; keys)) +;; (run-name (db:get-value-by-header run-record header "runname")) +;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) +;; (run-path (append key-vals (list run-name)))) +;; (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) +;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) +;; (conc rownum ":" colnum) col-name) +;; (hash-table-set! runid-to-col run-id (list colnum run-record)) +;; ;; Here we update the tests treebox and tree keys +;; (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" (append key-vals (list run-name)) +;; userdata: (conc "run-id: " run-id)) +;; (set! colnum (+ colnum 1)))) +;; run-ids) +;; +;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table +;; ;; Do this analysis in the order of the run-ids, the most recent run wins +;; (for-each (lambda (run-id) +;; (let* ((run-path (hash-table-ref (dboard:data-get-run-keys *data*) run-id)) +;; (test-changes (hash-table-ref all-test-changes run-id)) +;; (new-test-dat (car test-changes)) +;; (removed-tests (cadr test-changes)) +;; (tests (sort (map cadr (filter (lambda (testrec) +;; (eq? run-id (db:mintest-get-run_id (cadr testrec)))) +;; new-test-dat)) +;; (lambda (a b) +;; (let ((time-a (db:mintest-get-event_time a)) +;; (time-b (db:mintest-get-event_time b))) +;; (> time-a time-b))))) +;; ;; test-changes is a list of (( id record ) ... ) +;; ;; Get list of test names sorted by time, remove tests +;; (test-names (delete-duplicates (map (lambda (t) +;; (let ((i (db:mintest-get-item_path t)) +;; (n (db:mintest-get-testname t))) +;; (if (string=? i "") +;; (conc " " i) +;; n))) +;; tests))) +;; (colnum (car (hash-table-ref runid-to-col run-id)))) +;; ;; for each test name get the slot if it exists and fill in the cell +;; ;; or take the next slot and fill in the cell, deal with items in the +;; ;; run view panel? The run view panel can have a tree selector for +;; ;; browsing the tests/items +;; +;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY +;; (for-each (lambda (test) +;; (let* ((test-id (db:mintest-get-id test)) +;; (state (db:mintest-get-state test)) +;; (status (db:mintest-get-status test)) +;; (testname (db:mintest-get-testname test)) +;; (itempath (db:mintest-get-item_path test)) +;; (fullname (conc testname "/" itempath)) +;; (dispname (if (string=? itempath "") testname (conc " " itempath))) +;; (rownum (hash-table-ref/default testname-to-row fullname #f)) +;; (test-path (append run-path (if (equal? itempath "") +;; (list testname) +;; (list testname itempath)))) +;; (tb (dboard:data-get-tests-tree *data*))) +;; (print "INFONOTE: run-path: " run-path) +;; (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" +;; test-path +;; userdata: (conc "test-id: " test-id)) +;; (let ((node-num (tree:find-node tb (cons "Runs" test-path))) +;; (color (car (gutils:get-color-for-state-status state status)))) +;; (debug:print 0 "node-num: " node-num ", color: " color) +;; (iup:attribute-set! tb (conc "COLOR" node-num) color)) +;; (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) +;; (if (not rownum) +;; (let ((rownums (hash-table-values testname-to-row))) +;; (set! rownum (if (null? rownums) +;; 1 +;; (+ 1 (apply max rownums)))) +;; (hash-table-set! testname-to-row fullname rownum) +;; ;; create the label +;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) +;; (conc rownum ":" 0) dispname) +;; )) +;; ;; set the cell text and color +;; ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) +;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) +;; (conc rownum ":" colnum) +;; (if (member state '("ARCHIVED" "COMPLETED")) +;; status +;; state)) +;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) +;; (conc "BGCOLOR" rownum ":" colnum) +;; (car (gutils:get-color-for-state-status state status))) +;; )) +;; tests))) +;; run-ids) +;; +;; (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) +;; (if updater (updater (hash-table-ref/default data get-details-sig #f)))) +;; +;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") +;; ;; (debug:print 2 "run-changes: " run-changes) +;; ;; (debug:print 2 "test-changes: " test-changes) +;; (list run-changes all-test-changes))) ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -328,11 +353,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:attribute-set! keys-matrix "WIDTHDEF" "40") keys-matrix)) ;; Section to table @@ -354,11 +379,11 @@ (for-each (lambda (var) ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup configdat "fields" var))) key-vals) (iup:vbox (iup:label (if title title (conc "Settings from [" sectionname "]")) ;; #:size "5x" #:expand "HORIZONTAL" @@ -380,11 +405,11 @@ ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area ;; (iup:attribute-set! general-matrix "2:0" "Area") - ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; (iup:attribute-set! general-matrix "2:1" toppath) ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) @@ -451,22 +476,22 @@ (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) -(define (dcommon:servers-table) - (let* ((tdbdat (tasks:open-db)) +(define (dcommon:servers-table area-dat) + (let* ((tdbdat (tasks:open-db area-dat)) (colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () - (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) + (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat area-dat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -540,28 +565,35 @@ ;; ))) servers-matrix )) ;; The main menu -(define (dcommon:main-menu) +(define (dcommon:main-menu data) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Open" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))) + ;; (lambda (obj) + ;; (iup:show (iup:file-dialog)) + ;; (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ docs/manual/howto.txt @@ -26,12 +26,30 @@ [jobgroups] group1 10 custdes 4 --------------- +Limiting Job Runtime +-------------------- + +runtimlim can be set in megatest.config (affects all tests), +runconfigs (modifies for all tests based on a run) or in the +testconfig (affects only that test). The default in all cases is unlimited. +.megatest.config or runconfig +------------------------- +[setup] +# Default runtimelim 1d 1h 1m 10s +# +runtimelim 20m +------------------------- +.testconfig +------------------------- +[requirements] +runtimelim 1h 5m +------------------------- Debugging Tricks ---------------- Examining The Environment Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,11 +1,11 @@ - + The Megatest Users Manual