Index: .fossil-settings/ignore-glob
==================================================================
--- .fossil-settings/ignore-glob
+++ .fossil-settings/ignore-glob
@@ -1,5 +1,6 @@
+altdb.scm
utils/build/*
*~
*.o
bin/*
megatest.db
Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -1,26 +1,26 @@
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
- ods.scm runconfig.scm server.scm configf.scm \
- db.scm keys.scm margs.scm megatest-version.scm \
- process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm nmsg-transport.scm filedb.scm \
- client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
- tree.scm ezsteps.scm lock-queue.scm sdb.scm \
- rmt.scm api.scm tdb.scm rpc-transport.scm \
- portlogger.scm archive.scm env.scm
+ ods.scm runconfig.scm server.scm configf.scm \
+ db.scm keys.scm margs.scm megatest-version.scm \
+ process.scm runs.scm tasks.scm tests.scm genexample.scm \
+ http-transport.scm nmsg-transport.scm filedb.scm \
+ client.scm synchash.scm daemon.scm mt.scm \
+ ezsteps.scm lock-queue.scm sdb.scm \
+ rmt.scm api.scm tdb.scm rpc-transport.scm \
+ portlogger.scm archive.scm env.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
- dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
- json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
- spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3
+dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
+json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
+spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3
-GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm
+GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
ADTLSCR=mt_laststep mt_runstep mt_ezstep
@@ -40,31 +40,33 @@
mtest: $(OFILES) readline-fix.scm megatest.o
csc $(CSCOPTS) $(OFILES) megatest.o -o mtest
dboard : $(OFILES) $(GOFILES) dashboard.scm
- csc $(OFILES) dashboard.scm $(GOFILES) -o dboard
+ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
- csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
+ csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
- csc $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard
+ csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard
#
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \
- archive.o megatest.o : db_records.scm
+archive.o megatest.o : db_records.scm
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 : common_records.scm rpc-transport.scm
+common_records.scm : altdb.scm
+vg.o dashboard.o : vg_records.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
@@ -74,27 +76,27 @@
$(OFILES) $(GOFILES) : common_records.scm
%.o : %.scm
csc $(CSCOPTS) -c $<
-$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest
+$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@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/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard
+$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
chmod a+x $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard
-$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard
+$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper
utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
chmod a+x $(PREFIX)/bin/mdboard
# $(HELPERS) : utils/%
# $(INSTALL) $< $@
@@ -140,11 +142,11 @@
$(INSTALL) $< $@
chmod a+x $@
# install dashboard as dboard so wrapper script can be called dashboard
-$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES)
+$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
@@ -164,14 +166,23 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o
+ rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm
+
+#======================================================================
+# Make the records files
+#======================================================================
+
+# vg_records.scm : records.sh
+# ./records.sh
+#======================================================================
# Deploy section (not complete yet)
-#
+#======================================================================
+
$(DEPLOYHELPERS) : utils/mt_*
$(INSTALL) $< $@
chmod a+X $@
deploytarg/apropos.so : Makefile
@@ -201,40 +212,52 @@
mv deploytarg/deploytarg deploytarg/dboard
# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
# megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
- csc datashare.scm $(OFILES) -o datashare-testing/sd
+ csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd
datashare-testing/sdat: sharedat.scm $(OFILES)
- csc sharedat.scm $(OFILES) -o datashare-testing/sdat
+ csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat
sd : datashare-testing/sd
mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath
xterm : sd
(export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)
datashare-testing/spublish : spublish.scm $(OFILES)
- csc spublish.scm $(OFILES) -o datashare-testing/spublish
+ csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish
datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o
- csc sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve
+ csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve
sretrieve/sretrieve : datashare-testing/sretrieve
- csc -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o
+ csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o
chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \
srfi-1 posix regex regex-case srfi-69
# base64 dot-locking \
# csv-xml z3
# "(define (toplevel-command . a) #f)"
+# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
+
readline-fix.scm :
- if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \
- echo "(use-legacy-bindings)" > readline-fix.scm; \
+ if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
+ echo "(define *use-new-readline* #f)" > readline-fix.scm; \
else \
- echo "" > readline-fix.scm;\
+ echo "(define *use-new-readline* #t)" > readline-fix.scm;\
+ fi
+
+altdb.scm :
+ echo ";; optional alternate db setup" > altdb.scm
+ echo "(define *available-db* (make-hash-table))" >> altdb.scm
+ if csi -ne '(use mysql-client)';then \
+ echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
+ fi
+ if csi -ne '(use postgresql)';then \
+ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o nmsg-transport.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
ADDED README
Index: README
==================================================================
--- /dev/null
+++ README
@@ -0,0 +1,9 @@
+Megatest
+
+To build:
+
+1. Install chicken scheme. See utils/Makefile.installall
+
+2. Compile with "make -j install PREFIX=/some/path"
+
+3. To test ....
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -47,10 +47,11 @@
get-prev-run-ids
get-run-ids-matching-target
get-runs-by-patt
get-steps-data
get-steps-for-test
+ read-test-data
login
testmeta-get-record
have-incompletes?
synchash-get
))
@@ -106,11 +107,11 @@
(define (api:execute-requests dbstruct 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))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(if (not (vector? dat)) ;; it is an error to not receive a vector
(vector #f #f "remote must be called with a vector")
(vector ;; return a vector + the returned data structure
#t
@@ -165,10 +166,11 @@
((testmeta-update-field) (apply db:testmeta-update-field dbstruct 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-get-last) (apply tasks:get-last dbstruct 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))
@@ -180,11 +182,12 @@
;; KEYS
((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
((get-keys) (db:get-keys dbstruct))
((get-key-vals) (apply db:get-key-vals dbstruct params))
- ((get-targets) (db:get-targets dbstruct))
+ ((get-target) (apply db:get-target dbstruct params))
+ ((get-targets) (db:get-targets dbstruct))
;; ARCHIVES
((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
;; TESTS
@@ -221,15 +224,19 @@
((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-main-run-stats) (apply db:get-main-run-stats dbstruct params))
((get-var) (apply db:get-var dbstruct params))
+ ((get-run-stats) (apply db:get-run-stats dbstruct params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
+ ;; TEST DATA
+ ((read-test-data) (apply db:read-test-data dbstruct params))
+
;; MISC
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -68,11 +68,11 @@
(list
(vector-ref block 1) ;; archive-area-name
(vector-ref block 2))) ;; disk-path
existing-blocks)))
(or (common:get-disk-with-most-free-space candidate-disks dused)
- (archive:allocate-new-archive-block testname itempath))))
+ (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath))))
;; allocate a new archive area
;;
(define (archive:allocate-new-archive-block run-area-home testsuite-name dneeded)
(let* ((adisks (archive:get-archive-disks))
@@ -115,15 +115,15 @@
(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")
- (debug:print 0 " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
+ (debug:print 0 *default-log-port* "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 *default-log-port* " use [archive] minspace to specify minimum available space")
+ (debug:print 0 *default-log-port* " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n "))
(exit 1))
- (debug:print-info 0 "Using path " archive-dir " for archiving"))
+ (debug:print-info 0 *default-log-port* "Using path " archive-dir " for archiving"))
;; from the test info bin the path to the test by stem
;;
(for-each
(lambda (test-dat)
@@ -151,15 +151,15 @@
partial-path-index)
#f)))
(cond
(toplevel/children
- (debug:print 0 "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children"))
+ (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children"))
((not (file-exists? test-path))
- (debug:print 0 "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist"))
+ (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist"))
(else
- (debug:print 0
+ (debug:print 0 *default-log-port*
"From test-dat=" test-dat " derived the following:\n"
"test-partial-path = " test-partial-path "\n"
"test-path = " test-path "\n"
"test-physical-path = " test-physical-path "\n"
"partial-path-index = " partial-path-index "\n"
@@ -169,11 +169,11 @@
test-path))))
tests)
;; for each disk-group
(for-each
(lambda (disk-group)
- (debug:print 0 "Processing disk-group " disk-group)
+ (debug:print 0 *default-log-port* "Processing disk-group " disk-group)
(let* ((test-paths (hash-table-ref disk-groups disk-group))
;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-")
(bup-init-params (list "-d" archive-dir "init"))
(bup-index-params (append (list "-d" archive-dir "index") test-paths))
(bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree)
@@ -185,19 +185,19 @@
(if (not (file-exists? archive-dir))
(create-directory archive-dir #t))
(if (not (file-exists? (conc archive-dir "/HEAD")))
(begin
;; replace this with jobrunner stuff enventually
- (debug:print-info 0 "Init bup in " archive-dir)
+ (debug:print-info 0 *default-log-port* "Init bup in " archive-dir)
;; (mutex-lock! bup-mutex)
(run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix)
;; (mutex-unlock! bup-mutex)
))
- (debug:print-info 0 "Indexing data to be archived")
+ (debug:print-info 0 *default-log-port* "Indexing data to be archived")
;; (mutex-lock! bup-mutex)
(run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix)
- (debug:print-info 0 "Archiving data with bup")
+ (debug:print-info 0 *default-log-port* "Archiving data with bup")
(run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix)
;; (mutex-unlock! bup-mutex)
(for-each
(lambda (test-dat)
(let ((test-id (db:test-get-id test-dat))
@@ -254,11 +254,11 @@
prev-test-physical-path
(file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in?
(let* ((base (pathname-directory prev-test-physical-path))
(dirn (pathname-file prev-test-physical-path))
(newn (conc base "/." dirn)))
- (debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
+ (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn)
(rename-file prev-test-physical-path newn)))
(if (and archive-path ;; no point in proceeding if there is no actual archive
(not toplevel/children))
(begin
@@ -276,17 +276,17 @@
;; DO BUP RESTORE
(let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id))
(new-test-path (if (vector? new-test-dat )
(db:test-get-rundir new-test-dat)
(begin
- (debug:print 0 "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id)
+ (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id)
(exit 1))))
;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
(bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path)))
- (debug:print-info 0 "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
+ (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
;; (mutex-lock! bup-mutex)
(run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
;; (mutex-unlock! bup-mutex)
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
- (debug:print 0 "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id))))
+ (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
(filter vector? tests))))
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -61,17 +61,17 @@
;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id))
;; ((http) (rmt:login-no-auto-client-setup server-info run-id))
;; (else (rpc:login-no-auto-client-setup server-info run-id))))
;;
;; (define (client:setup-rpc run-id)
-;; (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries)
+;; (debug:print 0 *default-log-port* "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)
+;; (debug:print-error 0 *default-log-port* "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)))
-;; (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries)
+;; (debug:print-info 0 *default-log-port* "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))
@@ -80,11 +80,11 @@
;; (begin
;; (hash-table-set! *runremote* 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)
+;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info)
;; (hash-table-delete! *runremote* run-id)
;; (open-run-close tasks:server-force-clean-run-record
;; tasks:open-db
;; run-id
;; (car host-info)
@@ -91,16 +91,16 @@
;; (cadr host-info)
;; " client:setup (host-info=#t)")
;; (thread-sleep! 5)
;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; (begin
-;; (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info)
+;; (debug:print 25 *default-log-port* "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)))
-;; (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+;; (debug:print-info 0 *default-log-port* "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))
@@ -109,11 +109,11 @@
;; (begin
;; (hash-table-set! *runremote* 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)
+;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; (hash-table-delete! *runremote* run-id)
;; (open-run-close tasks:server-force-clean-run-record
;; tasks:open-db
;; run-id
;; (tasks:hostinfo-get-interface server-dat)
@@ -122,21 +122,21 @@
;; (thread-sleep! 2)
;; (server:try-running run-id)
;; (thread-sleep! 10) ;; give server a little time to start up
;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
;; (begin
-;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
+;; (debug:print 25 *default-log-port* "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
;; (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)")
;; (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)
+;; (debug:print 25 *default-log-port* "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)
;; (begin
;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
;; (server:try-running run-id)))
;; (thread-sleep! 10) ;; give server a little time to start up
@@ -153,18 +153,18 @@
;; client:setup
;;
;; lookup_server, need to remove *runremote* stuff
;;
(define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0))
- (debug:print-info 2 "client:setup remaining-tries=" remaining-tries)
+ (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
(let* ((tdbdat (tasks:open-db)))
(if (<= remaining-tries 0)
(begin
- (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
+ (debug:print-error 0 *default-log-port* "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)))
- (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (debug:print-info 4 *default-log-port* "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*
@@ -178,14 +178,14 @@
#f))))))
(if (and start-res
ping-res)
(begin
(hash-table-set! *runremote* run-id start-res)
- (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res))
+ (debug:print-info 2 *default-log-port* "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)
+ (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
(case *transport-type*
((http)(http-transport:close-connections run-id)))
(hash-table-delete! *runremote* run-id)
(tasks:kill-server-run-id run-id)
(tasks:server-force-clean-run-record (db:delay-if-busy tdbdat)
@@ -200,11 +200,11 @@
(thread-sleep! 5) ;; give server a little time to start up
(client:setup run-id 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)
+ (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
(if (< num-available 2)
(server:try-running run-id))
(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)))))))))
@@ -217,18 +217,18 @@
;; (define (client:signal-handler signum)
;; (signal-mask! signum)
;; (set! *time-to-exit* #t)
;; (handle-exceptions
;; exn
-;; (debug:print " ... exiting ...")
+;; (debug:print 0 *default-log-port* " ... exiting ...")
;; (let ((th1 (make-thread (lambda ()
;; "") ;; do nothing for now (was flush out last call if applicable)
;; "eat response"))
;; (th2 (make-thread (lambda ()
-;; (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
+;; (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
;; (thread-sleep! 1) ;; give the flush one second to do it's stuff
-;; (debug:print 0 " Done.")
+;; (debug:print 0 *default-log-port* " Done.")
;; (exit 4))
;; "exit on ^C timer")))
;; (thread-start! th2)
;; (thread-start! th1)
;; (thread-join! th2))))
@@ -239,10 +239,10 @@
;; ;;
;; (define (client:launch run-id)
;; (set-signal-handler! signal/int client:signal-handler)
;; (set-signal-handler! signal/term client:signal-handler)
;; (if (client:setup run-id)
-;; (debug:print-info 2 "connected as client")
+;; (debug:print-info 2 *default-log-port* "connected as client")
;; (begin
-;; (debug:print 0 "ERROR: Failed to connect as client")
+;; (debug:print-error 0 *default-log-port* "Failed to connect as client")
;; (exit))))
;;
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -34,13 +34,13 @@
(define getenv get-environment-variable)
(define (safe-setenv key val)
(if (and (string? val)(string? key))
(handle-exceptions
exn
- (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)
(setenv key val))
- (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
@@ -58,10 +58,11 @@
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
+(define *default-log-port* (current-error-port))
;; DATABASE
(define *dbstruct-db* #f)
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
@@ -129,10 +130,96 @@
;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
;; Generic path database
(define *fdb* #f)
+
+;;======================================================================
+;; V E R S I O N
+;;======================================================================
+
+(define (common:get-full-version)
+ (conc megatest-version "-" megatest-fossil-hash))
+
+(define (common:version-signature)
+ (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version)
+ (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:set-last-run-version)
+ (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+(define (common:version-changed?)
+ (not (equal? (common:get-last-run-version)
+ (common:version-signature))))
+
+;; Move me elsewhere ...
+;;
+(define (common:cleanup-db)
+ (db:multi-db-sync
+ #f ;; do all run-ids
+ ;; 'new2old
+ 'killservers
+ 'dejunk
+ ;; 'adj-testids
+ ;; 'old2new
+ 'new2old)
+ (if (common:version-changed?)
+ (common:set-last-run-version)))
+
+(define (common:exit-on-version-changed)
+ (if (common:version-changed?)
+ (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")))
+ (debug:print 0 *default-log-port*
+ "ERROR: Version mismatch!\n"
+ " expected: " (common:version-signature) "\n"
+ " got: " (common:get-last-run-version))
+ (if (and (file-exists? mtconf)
+ (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
+ (begin
+ (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Failed to switch versions.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))
+ (exit 1))
+ (common:cleanup-db)))
+ (begin
+ (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
+ (exit 1))))))
+
+;;======================================================================
+;; S P A R S E A R R A Y S
+;;======================================================================
+
+(define (make-sparse-array)
+ (let ((a (make-sparse-vector)))
+ (sparse-vector-set! a 0 (make-sparse-vector))
+ a))
+
+(define (sparse-array? a)
+ (and (sparse-vector? a)
+ (sparse-vector? (sparse-vector-ref a 0))))
+
+(define (sparse-array-ref a x y)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-ref row y)
+ #f)))
+
+(define (sparse-array-set! a x y val)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-set! row y val)
+ (let ((new-row (make-sparse-vector)))
+ (sparse-vector-set! a x new-row)
+ (sparse-vector-set! new-row y val)))))
;;======================================================================
;; L O C K E R S A N D B L O C K E R S
;;======================================================================
@@ -187,11 +274,11 @@
(handle-exceptions
exn
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
#f)
(read (open-input-string (base64:base64-decode instr))))
(read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))
@@ -289,11 +376,11 @@
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
- (debug:print-info 4 "starting exit process, finalizing databases.")
+ (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (and (not (null? run-ids))
@@ -312,63 +399,40 @@
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
(sqlite3:finalize! db #t)
- (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread"))
+ (vector-set! *task-db* 0 #f)))))
+ (close-output-port *default-log-port*)
+ (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
- (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...")
+ (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
(if no-hurry
(thread-sleep! 5) ;; give the clean up few seconds to do it's stuff
(thread-sleep! 2))
- (debug:print 4 " ... done")
+ (debug:print 4 *default-log-port* " ... done")
)
"clean exit")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1))))
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
- (debug:print 0 "ERROR: Received signal " signum " exiting promptly")
+ (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
(exit))
(set-signal-handler! signal/int std-signal-handler) ;; ^C
(set-signal-handler! signal/term std-signal-handler)
-(set-signal-handler! signal/stop std-signal-handler) ;; ^Z
+;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
;;======================================================================
;; M I S C U T I L S
;;======================================================================
-;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
-(define (common:hms-string->seconds tstr)
- (let ((parts (string-split tstr))
- (time-secs 0)
- ;; s=seconds, m=minutes, h=hours, d=days
- (trx (regexp "(\\d+)([smhd])")))
- (for-each (lambda (part)
- (let ((match (string-match trx part)))
- (if match
- (let ((val (string->number (cadr match)))
- (unt (caddr match)))
- (if val
- (set! time-secs (+ time-secs (* val
- (case (string->symbol unt)
- ((s) 1)
- ((m) 60)
- ((h) (* 60 60))
- ((d) (* 24 60 60))
- (else 0))))))))))
- parts)
- time-secs))
-
-(define (common:version-signature)
- (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
;; one-of args defined
(define (args-defined? . param)
(let ((res #f))
(for-each
(lambda (arg)
@@ -387,17 +451,17 @@
(define (any->number-if-possible val)
(let ((num (any->number val)))
(if num num val)))
(define (patt-list-match item patts)
- (debug:print-info 8 "patt-list-match item=" item " patts=" patts)
+ (debug:print-info 8 *default-log-port* "patt-list-match item=" item " patts=" patts)
(if (and item patts) ;; here we are filtering for matches with item patterns
(let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
(for-each
(lambda (patt)
(let ((modpatt (string-substitute "%" ".*" patt #t)))
- (debug:print-info 10 "patt " patt " modpatt " modpatt)
+ (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
(if (string-match (regexp modpatt) item)
(set! res #t))))
(string-split patts ","))
res)
#t))
@@ -448,11 +512,11 @@
(args:get-arg "-runtests")
"%"))
(testpatt (or (and (equal? args-testpatt "%")
rtestpatt)
args-testpatt)))
- (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt))
+ (if rtestpatt (debug:print-info 0 *default-log-port* "TESTPATT from runconfigs: " rtestpatt))
testpatt))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
@@ -482,11 +546,11 @@
(if split
tlist
target)
(if target
(begin
- (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+ (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
#f)
#f))))
;;======================================================================
;; M I S C L I S T S
@@ -525,11 +589,11 @@
(cdr tal))
(max hed max-val))))
;;======================================================================
-;; Munge data into nice forms
+;; M U N G E D A T A I N T O N I C E F O R M S
;;======================================================================
;; Generate an index for a sparse list of key values
;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) )
;;
@@ -555,11 +619,11 @@
(existing-coldat (assoc colkey colnames))
(curr-rownum (if existing-rowdat rownum (+ rownum 1)))
(curr-colnum (if existing-coldat colnum (+ colnum 1)))
(new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
(new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
- ;; (debug:print-info 0 "Processing record: " hed )
+ ;; (debug:print-info 0 *default-log-port* "Processing record: " hed )
(if proc (proc curr-rownum curr-colnum rowkey colkey value))
(if (null? tal)
(list new-rownames new-colnames)
(loop (car tal)
(cdr tal)
@@ -568,18 +632,35 @@
(if (> curr-rownum rownum) curr-rownum rownum)
(if (> curr-colnum colnum) curr-colnum colnum)
))))))
;;======================================================================
-;; System stuff
+;; S Y S T E M S T U F F
;;======================================================================
;; return a nice clean pathname made absolute
-(define (nice-path dir)
- (normalize-pathname (if (absolute-pathname? dir)
- dir
- (conc (current-directory) "/" dir))))
+(define (common:nice-path dir)
+ (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+ (if match ;; using ~ for home?
+ (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
+ (normalize-pathname (if (absolute-pathname? dir)
+ dir
+ (conc (current-directory) "/" dir))))))
+
+;; make "nice-path" available in config files and the repl
+(define nice-path common:nice-path)
+
+(define (common:read-link-f path)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.")
+ path) ;; just give up
+ (with-input-from-pipe
+ (conc "/bin/readlink -f " path)
+ (lambda ()
+ (read-line)))))
(define (get-cpu-load)
(car (common:get-cpu-load)))
;; (let* ((load-res (process:cmd-run->list "uptime"))
;; (load-rx (regexp "load average:\\s+(\\d+)"))
@@ -606,16 +687,16 @@
(adjload (* maxload numcpus))
(loadjmp (- first next)))
(cond
((and (> first adjload)
(> count 0))
- (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg ""))
+ (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg ""))
(thread-sleep! waitdelay)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))
((and (> loadjmp numcpus)
(> count 0))
- (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
+ (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
(thread-sleep! waitdelay)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))))))
(define (common:get-num-cpus)
(with-input-from-file "/proc/cpuinfo"
@@ -673,11 +754,11 @@
;; with free-space-script /path/to/some/script.sh
;;
(define (get-df path)
(if (configf:lookup *configdat* "setup" "free-space-script")
(with-input-from-pipe
- (configf:lookup *configdat* "setup" "free-space-script")
+ (conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
(lambda ()
(let ((res (read-line)))
(if (string? res)
(string->number res)))))
(get-unix-df path)))
@@ -720,11 +801,11 @@
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
(begin
- (debug:print 0 "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
+ (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
(exit 1)))))
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
@@ -733,20 +814,20 @@
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
- (if (common:low-noise-print 50 "disks not a dir " disk-num)
- (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
+ (if (common:low-noise-print 300 "disks not a dir " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
-1)
((not (file-write-access? dirpath))
- (if (common:low-noise-print 50 "disks not writeable " disk-num)
- (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
+ (if (common:low-noise-print 300 "disks not writeable " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
- (if (common:low-noise-print 50 "disks not a proper path " disk-num)
- (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
+ (if (common:low-noise-print 300 "disks not a proper path " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
-1)
(else
(get-df dirpath)))))
(if (> freespc bestsize)
(begin
@@ -836,15 +917,44 @@
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
+
+(define (common:run-a-command cmd)
+ (let ((fullcmd (conc (dtests:get-pre-command)
+ cmd
+ (dtests:get-post-command))))
+ (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
+ (common:without-vars fullcmd "MT_.*")))
;;======================================================================
-;; time and date nice to have stuff
+;; T I M E A N D D A T E
;;======================================================================
+;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5
+(define (common:hms-string->seconds tstr)
+ (let ((parts (string-split tstr))
+ (time-secs 0)
+ ;; s=seconds, m=minutes, h=hours, d=days
+ (trx (regexp "(\\d+)([smhd])")))
+ (for-each (lambda (part)
+ (let ((match (string-match trx part)))
+ (if match
+ (let ((val (string->number (cadr match)))
+ (unt (caddr match)))
+ (if val
+ (set! time-secs (+ time-secs (* val
+ (case (string->symbol unt)
+ ((s) 1)
+ ((m) 60)
+ ((h) (* 60 60))
+ ((d) (* 24 60 60))
+ (else 0))))))))))
+ parts)
+ time-secs))
+
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
(sec (- secs (* hrs 3600)(* min 60))))
(conc (if (> hrs 0)(conc hrs "hr ") "")
@@ -867,11 +977,15 @@
(time->string
(seconds->local-time sec) "%yww%V.%w"))
(define (seconds->year-work-week/day-time sec)
(time->string
- (seconds->local-time sec) "%yww%V.%w %H:%M"))
+ (seconds->local-time sec) "%Yww%V.%w %H:%M"))
+
+(define (seconds->year-week/day-time sec)
+ (time->string
+ (seconds->local-time sec) "%Yw%V.%w %H:%M"))
(define (seconds->quarter sec)
(case (string->number
(time->string
(seconds->local-time sec)
@@ -879,13 +993,49 @@
((1 2 3) 1)
((4 5 6) 2)
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
+
+;; given span of seconds tstart to tend
+;; find start time to mark and mark delta
+;;
+(define (common:find-start-mark-and-mark-delta tstart tend)
+ (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ...
+ (result #f)
+ (min 60)
+ (hr (* 60 60))
+ (day (* 24 hr))
+ (yr (* 365 day)) ;; year
+ (mo (/ yr 12))
+ (wk (* day 7)))
+ (for-each
+ (lambda (max-blks)
+ (for-each
+ (lambda (span) ;; 5 2 1
+ (if (not result)
+ (for-each
+ (lambda (timeunit timesym) ;; year month day hr min sec
+ (if (not result)
+ (let* ((time-blk (* span timeunit))
+ (num-blks (quotient deltat time-blk)))
+ (if (and (> num-blks 4)(< num-blks max-blks))
+ (let ((first (* (quotient tstart time-blk) time-blk)))
+ (set! result (list span timeunit time-blk first timesym))
+ )))))
+ (list yr mo wk day hr min 1)
+ '( y mo w d h m s))))
+ (list 8 6 5 2 1)))
+ '(5 10 15 20 30 40 50 500))
+ (if values
+ (apply values result)
+ (values 0 day 1 0 'd))))
+
+
;;======================================================================
-;; Colors
+;; C O L O R S
;;======================================================================
(define (common:name->iup-color name)
(case (string->symbol (string-downcase name))
((red) "223 33 49")
@@ -1130,20 +1280,37 @@
(tal (cdr launchers)))
(let ((patt (car hed))
(host-type (cadr hed)))
(if (tests:match patt testname itempath)
(begin
- (debug:print-info 0 "Have flexi-launcher match for " testname "/" itempath " = " host-type)
+ (debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
(let ((launcher (configf:lookup configdat "host-types" host-type)))
(if launcher
launcher
(begin
- (debug:print-info 0 "WARNING: no launcher found for host-type " host-type)
+ (debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
(if (null? tal)
fallback-launcher
(loop (car tal)(cdr tal)))))))
;; no match, try again
(if (null? tal)
fallback-launcher
(loop (car tal)(cdr tal))))))))
fallback-launcher)))
+;;======================================================================
+;; D A S H B O A R D U S E R V I E W S
+;;======================================================================
+
+;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists
+;;
+(define (common:load-views-config)
+ (let* ((view-cfgdat (make-hash-table))
+ (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config"))
+ (mthome-cfgfile (conc *toppath* "/.mtviews.config")))
+ (if (file-exists? mthome-cfgfile)
+ (read-config mthome-cfgfile view-cfgdat #t))
+ ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
+ (if (file-exists? home-cfgfile)
+ (read-config home-cfgfile view-cfgdat #t))
+ view-cfgdat))
+
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -8,10 +8,12 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;; (use trace)
+
+(include "altdb.scm")
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
@@ -27,10 +29,24 @@
(define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))
(define-syntax common:handle-exceptions
(syntax-rules ()
((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))
+
+;; iup callbacks are not dumping the stack, this is a work-around
+;;
+(define-simple-syntax (debug:catch-and-dump proc procname)
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain (current-error-port))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print ((condition-property-accessor 'exn 'message) exn))
+ (print "Callback error in " procname)
+ (print "Full condition info:\n" (condition->list exn)))))
+ (proc)))
(define (debug:calc-verbosity vstr)
(cond
((number? vstr) vstr)
((not (string? vstr)) 1)
@@ -79,32 +95,47 @@
(not (getenv "MT_DEBUG_MODE")))
(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
(string-intersperse (map conc *verbosity*) ",")
(conc *verbosity*))))))
+(define (debug:print n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ (if *logging*
+ (db:log-event (apply conc params))
+ (apply print params)
+ )))))
-(define (debug:print n . params)
+(define (debug:print-error n e . params)
+ ;; normal print
(if (debug:debug-mode n)
- (with-output-to-port (current-error-port)
+ (with-output-to-port (or e (current-error-port))
(lambda ()
(if *logging*
(db:log-event (apply conc params))
;; (apply print "pid:" (current-process-id) " " params)
- (apply print params)
- )))))
-
-(define (debug:print-info n . params)
- (if (debug:debug-mode n)
+ (apply print "ERROR: " params)
+ ))))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
(with-output-to-port (current-error-port)
(lambda ()
- (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
- (if *logging*
- (db:log-event res)
- ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
- (apply print "INFO: (" n ") " params) ;; res)
- ))))))
+ (apply print "ERROR: " params)
+ ))))
+
+(define (debug:print-info n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ (if *logging*
+ (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
+ (db:log-event res))
+ ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
+ (apply print "INFO: (" n ") " params) ;; res)
+ )))))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -14,10 +14,11 @@
;;======================================================================
(use regex regex-case) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
+(declare (uses env))
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
@@ -45,11 +46,11 @@
(define (config:eval-string-in-environment str)
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: problem evaluating \"" str "\" in the shell environment")
+ (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment")
#f)
(let ((cmdres (process:cmd-run->list (conc "echo " str))))
(if (null? cmdres) ""
(caar cmdres)))))
@@ -98,12 +99,12 @@
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
exn
(begin
- (debug:print 0 "WARNING: failed to process config input \"" l "\"")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print "exn=" (condition->list exn))
(set! result (conc "#{( " cmdtype ") " cmd"}")))
(if (or allow-system
(not (member cmdtype '("system" "shell"))))
(with-input-from-string fullcmd
@@ -112,12 +113,12 @@
(set! result (conc "#{(" cmdtype ") " cmd "}"))))
(case cmdsym
((system shell scheme)
(let ((delta (- (current-seconds) start-time)))
(if (> delta 2)
- (debug:print-info 0 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
- (debug:print-info 9 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
+ (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
(loop (conc prestr result poststr)))
res))
res)))
;; Run a shell command and return the output as a string
@@ -127,11 +128,11 @@
(status (cadr output)))
(if (equal? status 0)
(let ((outres (string-intersperse
res
"\n")))
- (debug:print-info 4 "shell result:\n" outres)
+ (debug:print-info 4 *default-log-port* "shell result:\n" outres)
outres)
(begin
(with-output-to-port (current-error-port)
(lambda ()
(print "ERROR: " cmd " returned bad exit code " status)))
@@ -179,15 +180,15 @@
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;;
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '()))
- (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
- (debug:print 9 "START: " path)
+ (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
+ (debug:print 9 *default-log-port* "START: " path)
(if (not (file-exists? path))
(begin
- (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory))
+ (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
#f) ;; (if (not ht)(make-hash-table) ht))
(let ((inp (open-input-file path))
(res (if (not ht)(make-hash-table) ht))
(metapath (if (or (debug:debug-mode 9)
@@ -195,16 +196,16 @@
path #f)))
(let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
(curr-section-name (if curr-section curr-section "default"))
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
- (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
(begin
(close-input-port inp)
(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
- (debug:print 9 "END: " path)
+ (debug:print 9 *default-log-port* "END: " path)
res)
(regex-case
inl
(configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
@@ -212,25 +213,25 @@
(hash-table-set! settings setting val)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
(configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (absolute-pathname? include-file)
include-file
- (nice-path
+ (common:nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(if (file-exists? full-conf)
(begin
;; (push-directory conf-dir)
- (debug:print 9 "Including: " full-conf)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
(read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
;; (pop-directory)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
- (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")")
- (debug:print 2 " " full-conf)
+ (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
(configf:section-rx ( x section-name ) (begin
;; call post-section-procs
(for-each
(lambda (dat)
@@ -251,18 +252,18 @@
(let* ((start-time (current-seconds))
(cmdres (process:cmd-run->list cmd))
(delta (- (current-seconds) start-time))
(status (cadr cmdres))
(res (car cmdres)))
- (debug:print-info 4 "" inl "\n => " (string-intersperse res "\n"))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
(if (not (eq? status 0))
(begin
- (debug:print 0 "ERROR: problem with " inl ", return code " status
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
" output: " cmdres)))
(if (> delta 2)
- (debug:print-info 0 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
- (debug:print-info 9 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
@@ -274,23 +275,23 @@
metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
(configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
- (debug:print 10 " setting: [" curr-section-name "] " key " = #t")
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
(safe-setenv key fval)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key fval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
(configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
- (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar (safe-setenv key realval))
- (debug:print 10 " setting: [" curr-section-name "] " key " = " val)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f)))
;; if a continued line
(configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '())))
@@ -305,11 +306,11 @@
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist var-flag newval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
- (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"")
+ (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))))))
;; pathenvvar will set the named var to the path of the config
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
@@ -318,11 +319,11 @@
(toppath (car configinfo))
(configfile (cadr configinfo))
(set-fields (lambda (curr-section next-section ht path)
(let ((field-names (if ht (keys:config-get-fields ht) '()))
(target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (debug:print-info 9 "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
+ (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
(if (not (null? field-names))(keys:target-set-args field-names target #f))))))
(if toppath (change-directory toppath))
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
@@ -352,11 +353,11 @@
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (setup)
- (let* ((configf (find-config))
+ (let* ((configf (find-config "megatest.config"))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
@@ -467,13 +468,13 @@
(set! new #f))
((not (equal? newval val))
(hash-table-set! sechash key newval)
(set! new (conc key " " newval)))
(else
- (debug:print 0 "ERROR: problem parsing line number " lnum "\"" hed "\"")))))
+ (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
(else
- (debug:print 0 "ERROR: Problem parsing line num " lnum " :\n " hed )))
+ (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
(if (not (null? tal))
(loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
;; drop to here when done processing, res contains modified list of lines
(set! fdat res)))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -235,11 +235,11 @@
;; if there is a submegatest create a button to launch dashboard in that area
;;
(define (submegatest-panel dbstruct keydat testdat runname testconfig)
(let* ((subarea (configf:lookup testconfig "setup" "submegatest"))
(area-exists (and subarea (file-exists? subarea))))
- ;; (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists)
+ ;; (debug:print-info 0 *default-log-port* "Megatest subarea=" subarea ", area-exists=" area-exists)
(if subarea
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:button
"Launch Dashboard"
@@ -424,11 +424,11 @@
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
(begin
- (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
+ (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f))
(test-registry (tests:get-all))
(keydat (if testdat (rmt:get-key-val-pairs run-id) #f))
(rundat (if testdat (rmt:get-run-info run-id) #f))
@@ -441,11 +441,11 @@
(logfile "/this/dir/better/not/exist")
(rundir (if testdat
(db:test-get-rundir testdat)
logfile))
;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found
- (teststeps (if testdat (tests:get-compressed-steps #f run-id test-id) '()))
+ (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '()))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
;; (tests:get-testconfig testdat testname 'return-procs))
(testmeta (if testdat
(let ((tm (rmt:testmeta-get-record testname)))
@@ -511,22 +511,22 @@
request-update))
(newtestdat (if need-update
;; NOTE: BUG HIDER, try to eliminate this exception handler
(handle-exceptions
exn
- (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn))
(rmt:get-test-info-by-id run-id test-id )))))
- ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
+ ;; (debug:print-info 0 *default-log-port* "need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
- (set! teststeps (tests:get-compressed-steps #f run-id test-id))
+ (set! teststeps (tests:get-compressed-steps run-id test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(set! testfullname (db:test-get-fullname testdat))
- ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
+ ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n "))
;; I don't see why this was implemented this way. Please comment it ...
;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
;; (set! db-mod-time (+ curr-mod-time 1))
;; (set! db-mod-time curr-mod-time))
@@ -575,16 +575,12 @@
;(mutex-unlock! mx1)
)))))
lbl))
(store-button store-label)
(command-proc (lambda (command-text-box)
- (let* ((cmd (iup:attribute command-text-box "VALUE"))
- (fullcmd (conc (dtests:get-pre-command)
- cmd
- (dtests:get-post-command))))
- (debug:print-info 02 "Running command: " fullcmd)
- (common:without-vars fullcmd "MT_.*"))))
+ (let* ((cmd (iup:attribute command-text-box "VALUE")))
+ (common:run-a-command cmd))))
(command-text-box (iup:textbox
#:expand "HORIZONTAL"
#:font "Courier New, -10"
#:action (lambda (obj cnum val)
;; (print "cnum=" cnum)
@@ -596,25 +592,26 @@
;; (lambda (x)
;; (let* ((cmd (iup:attribute command-text-box "VALUE"))
;; (fullcmd (conc (dtests:get-pre-command)
;; cmd
;; (dtests:get-post-command))))
- ;; (debug:print-info 02 "Running command: " fullcmd)
+ ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
;; (common:without-vars fullcmd "MT_.*")))))
(kill-jobs (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -set-state-status KILLREQ,n/a -testpatt %/% "
- " -state RUNNING"))))
+ " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
(run-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -run -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
+ " -clean-cache"
))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
@@ -629,10 +626,11 @@
item-path))
";megatest -target " keystring " -runname " runname
" -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
+ " -clean-cache"
)))
(common:without-vars
(conc (dtests:get-pre-command)
cmd
(dtests:get-post-command))
@@ -691,13 +689,13 @@
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
#:font "Courier New, -8"
#:expand "YES"
#:scrollbar "YES"
- #:numcol 6
- #:numlin 30
- #:numcol-visible 6
+ #:numcol 7
+ #:numlin 100
+ #:numcol-visible 7
#:numlin-visible 5
#:click-cb (lambda (obj lin col status)
;; (if (equal? col 6)
(let* ((mtrx-rc (conc lin ":" 6))
(fname (iup:attribute obj mtrx-rc))) ;; col))))
@@ -718,10 +716,11 @@
(iup:attribute-set! steps-matrix "WIDTH3" "50")
(iup:attribute-set! steps-matrix "0:4" "Status")
(iup:attribute-set! steps-matrix "WIDTH4" "50")
(iup:attribute-set! steps-matrix "0:5" "Duration")
(iup:attribute-set! steps-matrix "0:6" "Log File")
+ (iup:attribute-set! steps-matrix "0:7" "Comment")
(iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT")
;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1")
(iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES")
(let ((proc
(lambda (testdat)
@@ -740,11 +739,11 @@
#:font "Courier New, -10"
#:size "100x100")))
(hash-table-set! widgets "Test Data"
(lambda (testdat) ;;
(let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
- (fmtstr "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment
+ (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment
(newval (string-intersperse
(append
(list
(format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment")
(format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "======="))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -8,17 +8,18 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use format)
+
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
@@ -30,41 +31,50 @@
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
(declare (uses tree))
(declare (uses dcommon))
+(declare (uses vg))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+(include "task_records.scm")
(include "megatest-fossil-hash.scm")
+(include "vg_records.scm")
(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2016
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
+ -test run-id,test-id : control test identified by testid
+ -skip-version-check : skip the version check
Misc
- -rows N : set number of rows
+ -rows R : set number of rows
+ -cols C : set number of columns
"))
+
+;; -server host:port : connect to host:port instead of db access
+;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
+;; -guimonitor : control panel for runs
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
+ "-cols"
"-run"
"-test"
+ "-xterm"
"-debug"
"-host"
"-transport"
)
(list "-h"
@@ -72,11 +82,12 @@
"-guimonitor"
"-main"
"-v"
"-q"
"-use-local"
- )
+ "-skip-version-check"
+ )
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
@@ -86,129 +97,260 @@
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
-;; create a stuct for all the miscellaneous state
+;; data common to all tabs goes here
;;
-(defstruct d:alldat
- allruns
- allruns-by-id
- buttondat
- curr-tab-num
- dbdir
- dbfpath
- dbkeys
- dblocal
- header
- hide-empty-runs
- hide-not-hide ;; toggle for hide/not hide
- hide-not-hide-button
+(defstruct dboard:commondat
+ ((curr-tab-num 0) : number)
+ please-update
+ tabdats
+ update-mutex
+ updaters
+ updating
+ uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
- item-test-names
- keys
- last-db-update
- num-tests
- numruns
- please-update
- ro
- searchpatts
- start-run-offset
- start-test-offset
- state-ignore-hash
- status-ignore-hash
- tot-runs
- update-mutex
- updaters
- updating
- useserver
- )
-
-(define *alldat* (make-d:alldat
- header: #f
- allruns: '()
- allruns-by-id: (make-hash-table)
- buttondat: (make-hash-table)
- searchpatts: (make-hash-table)
- numruns: 16
- last-db-update: 0
- please-update: #t
- updating: #f
- update-mutex: (make-mutex)
- item-test-names: '()
- num-tests: 15
- start-run-offset: 0
- start-test-offset: 0
- status-ignore-hash: (make-hash-table)
- state-ignore-hash: (make-hash-table)
- hide-empty-runs: #f
- hide-not-hide: #t
- hide-not-hide-button: #f
- hide-not-hide-tabs: #f
- curr-tab-num: 0
- updaters: (make-hash-table)
- ))
-
-;; simple two dimentional sparse array
-;;
-(define (make-sparse-array)
- (let ((a (make-sparse-vector)))
- (sparse-vector-set! a 0 (make-sparse-vector))
- a))
-
-(define (sparse-array? a)
- (and (sparse-vector? a)
- (sparse-vector? (sparse-vector-ref a 0))))
-
-(define (sparse-array-ref a x y)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-ref row y)
- #f)))
-
-(define (sparse-array-set! a x y val)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-set! row y val)
- (let ((new-row (make-sparse-vector)))
- (sparse-vector-set! a x new-row)
- (sparse-vector-set! new-row y val)))))
-
-;; data for runs, tests etc
-;;
-(defstruct d:rundat
+ )
+
+(define (dboard:commondat-make)
+ (make-dboard:commondat
+ curr-tab-num: 0
+ tabdats: (make-hash-table)
+ please-update: #t
+ update-mutex: (make-mutex)
+ updaters: (make-hash-table)
+ updating: #f
+ hide-not-hide-tabs: #f
+ ))
+
+(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
+ (hash-table-ref/default
+ (dboard:commondat-tabdats commondat)
+ (or tab-num (dboard:commondat-curr-tab-num commondat))
+ #f))
+
+(define (dboard:common-set-tabdat! commondat tabnum tabdat)
+ (hash-table-set!
+ (dboard:commondat-tabdats commondat)
+ tabnum
+ tabdat))
+
+;; gets and calls updater based on curr-tab-num
+(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
+ (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
+ (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
+ (updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
+ tnum
+ '())))
+ (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
+ (for-each
+ (lambda (updater)
+ ;; (debug:print 3 *default-log-port* "Running " updater)
+ (updater))
+ updaters))))
+
+;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
+;;
+(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
+ (let* ((tnum (or tab-num
+ (dboard:commondat-curr-tab-num commondat)))
+ (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
+ (hash-table-set! (dboard:commondat-updaters commondat)
+ tnum
+ (cons updater curr-updaters))))
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x14")) : string) ;; was 12
+ ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f)
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update 0) : number) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+
+ tests-tree ;; used in newdashboard
+ )
+
+(define (dboard:tabdat-target-string vec)
+ (let ((targ (dboard:tabdat-target vec)))
+ (if (list? targ)(string-intersperse targ "/") "no-target-specified")))
+
+(define (dboard:tabdat-test-patts-use vec)
+ (let ((val (dboard:tabdat-test-patts vec)))(if val val "")))
+
+;; additional setters for dboard:data
+(define (dboard:tabdat-test-patts-set!-use vec val)
+ (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
+
+(define (dboard:tabdat-make-data)
+ (let ((dat (make-dboard:tabdat)))
+ (dboard:setup-tabdat dat)
+ (dboard:setup-num-rows dat)
+ dat))
+
+(define (dboard:setup-tabdat tabdat)
+ (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
+ (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
+
+ ;; HACK ALERT: this is a hack, please fix.
+ (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
+
+ (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
+ (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
+ (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
+ )
+
+;; data for runs, tests etc. was used in run summary?
+;;
+(defstruct dboard:runsdat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
matrix-dat ;; vector of vectors rows/cols
)
-(define (d:rundat-make-init)
- (make-d:rundat
+(define (dboard:runsdat-make-init)
+ (make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
-(defstruct d:testdat
+;; used to keep the rundata from rmt:get-tests-for-run
+;; in sync.
+;;
+(defstruct dboard:rundat
+ run
+ tests-drawn ;; list of id's already drawn on screen
+ tests-notdrawn ;; list of id's NOT already drawn
+ rowsused ;; hash of lists covering what areas used - replace with quadtree
+ hierdat ;; put hierarchial sorted list here
+ tests ;; hash of id => testdat
+ ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
+ key-vals
+ ((last-update 0) : fixnum) ;; last query to db got records from before last-update
+ ((data-changed #f) : boolean)
+ ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items
+ (db-path #f)
+ )
+
+(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
+ (make-dboard:rundat
+ run: run
+ tests: (or tests (make-hash-table))
+ key-vals: key-vals
+ ))
+
+(define (dboard:rundat-copy-tests-to-by-name rundat)
+ (let ((src-ht (dboard:rundat-tests rundat))
+ (trg-ht (dboard:rundat-tests-by-name rundat)))
+ (if (and (hash-table? src-ht)(hash-table? trg-ht))
+ (begin
+ (hash-table-clear! trg-ht)
+ (for-each
+ (lambda (testdat)
+ (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat))
+ (hash-table-values src-ht)))
+ (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht))))
+
+(defstruct dboard:testdat
id ;; testid
state ;; test state
status ;; test status
)
-(define (d:rundat-get-col-num dat target runname force-set)
- (let* ((runs-index (d:rundat-runs-index dat))
+(define (dboard:runsdat-get-col-num dat target runname force-set)
+ (let* ((runs-index (dboard:runsdat-runs-index dat))
(col-name (conc target "/" runname))
(res (hash-table-ref/default runs-index col-name #f)))
(if res
res
(if force-set
(let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index)))))
(hash-table-set! runs-index col-name max-col-num)
max-col-num)))))
-(define (d:rundat-get-row-num dat testname itempath force-set)
- (let* ((tests-index (d:rundat-runs-index dat))
+(define (dboard:runsdat-get-row-num dat testname itempath force-set)
+ (let* ((tests-index (dboard:runsdat-runs-index dat))
(row-name (conc testname "/" itempath))
(res (hash-table-ref/default runs-index row-name #f)))
(if res
res
(if force-set
@@ -216,51 +358,26 @@
(hash-table-set! runs-index row-name max-row-num)
max-row-num)))))
;; default is to NOT set the cell if the column and row names are not pre-existing
;;
-(define (d:rundat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
- (let* ((col-num (d:rundat-get-col-num dat target runname force-set))
- (row-num (d:rundat-get-row-num dat testname itempath force-set)))
+(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
+ (let* ((col-num (dboard:runsdat-get-col-num dat target runname force-set))
+ (row-num (dboard:runsdat-get-row-num dat testname itempath force-set)))
(if (and row-num col-num)
- (let ((tdat (d:testdat
+ (let ((tdat (dboard:testdat
id: test-id
state: state
status: status)))
- (sparse-array-set! (d:rundat-matrix-dat dat) col-num row-num tdat)
+ (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat)
tdat)
#f)))
-
-
-
-
-(d:alldat-useserver-set! *alldat* (cond
- ((args:get-arg "-use-local") #f)
- ((configf:lookup *configdat* "dashboard" "use-server")
- (let ((ans (config:lookup *configdat* "dashboard" "use-server")))
- (if (equal? ans "yes") #t #f)))
- (else #t)))
-
-(d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
-(d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*)
- local: #t))
-(d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0))
-
-;; HACK ALERT: this is a hack, please fix.
-(d:alldat-ro-set! *alldat* (not (file-read-access? (d:alldat-dbfpath *alldat*))))
-
-(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*)
- (rmt:get-keys)
- (db:get-keys (d:alldat-dblocal *alldat*))))
-(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname")))
-(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*)
- (rmt:get-num-runs "%")
- (db:get-num-runs (d:alldat-dblocal *alldat*) "%")))
-;;
-(define *exit-started* #f)
-;; *updaters* (make-hash-table))
+(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
+
+
+(define *exit-started* #f)
;; sorting global data (would apply to many testsuites so leave it global for now)
;;
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
@@ -293,11 +410,11 @@
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
(debug:setup)
-(define uidat #f)
+;; (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))
@@ -328,11 +445,11 @@
(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))))
-(define (compare-tests test1 test2)
+(define (dboard:compare-tests test1 test2)
(let* ((test-name1 (db:test-get-testname test1))
(item-path1 (db:test-get-item-path test1))
(eventtime1 (db:test-get-event_time test1))
(test-name2 (db:test-get-testname test2))
(item-path2 (db:test-get-item-path test2))
@@ -347,104 +464,200 @@
(string>? item-path1 item-path2)
test1-older)
(if same-time
(string>? test-name1 test-name2)
test1-older))))
-
-;; create a virtual table of all the tests
-;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
-(define (update-rundat runnamepatt numruns testnamepatt keypatts)
- (let* ((referenced-run-ids '())
- (allruns (if (d:alldat-useserver *alldat*)
- (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts)
- (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
- (d:alldat-start-run-offset *alldat*) keypatts)))
- (header (db:get-header allruns))
- (runs (db:get-rows allruns))
- (result '())
- (maxtests 0)
- (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))
- (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))
+
+;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
+;;
+;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
+;;
+;; NOTE: Yes, this is used
+;;
+(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
+ (let* ((num-to-get 100)
+ (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
+ (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(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)))
+ 'itempath))
+ ;; note: the rundat is normally created in "update-rundat".
+ (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
+ (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
+ rd)))
+ ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
+ (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3))
+ (db-path (or (dboard:rundat-db-path run-dat)
+ (let* ((db-dir (tasks:get-task-db-path))
+ (db-pth (conc db-dir "/" run-id ".db")))
+ (dboard:rundat-db-path-set! run-dat db-pth)
+ db-pth)))
+ (tmptests (if (or (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
+ (>= (file-modification-time db-path) last-update))
+ (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
+ (dboard:rundat-run-data-offset run-dat)
+ num-to-get
+ (dboard:tabdat-hide-not-hide tabdat) ;; no-in
+ sort-by ;; sort-by
+ sort-order ;; sort-order
+ #f ;; 'shortlist ;; qrytype
+ (if (dboard:tabdat-filters-changed tabdat)
+ 0
+ last-update) ;; last-update
+ *dashboard-mode*) ;; use dashboard mode
+ '()))
+ (use-new (dboard:tabdat-hide-not-hide tabdat))
+ (tests-ht (if (dboard:tabdat-filters-changed tabdat)
+ (let ((ht (make-hash-table)))
+ (dboard:rundat-tests-set! run-dat ht)
+ ht)
+ (dboard:rundat-tests run-dat)))
+ (start-time (current-seconds)))
+
+ ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
+ (dboard:rundat-run-data-offset-set!
+ run-dat
+ (if (< (length tmptests) num-to-get)
+ 0
+ (let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat))))
+ ;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval)
+ newval)))
+
+ (for-each
+ (lambda (tdat)
+ (let ((test-id (db:test-get-id tdat))
+ (state (db:test-get-state tdat)))
+ (dboard:rundat-data-changed-set! run-dat #t)
+ (if (equal? state "DELETED")
+ (hash-table-delete! tests-ht test-id)
+ (hash-table-set! tests-ht test-id tdat))))
+ tmptests)
+
+ ;; set last-update to 0 if still getting data incrementally
+
+ (if (> (dboard:rundat-run-data-offset run-dat) 0)
+ (begin
+ ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0")
+ (dboard:rundat-last-update-set! run-dat 0))
+ (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured.
+
+ ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht))
+ tests-ht))
+
+;; tmptests - new tests data
+;; prev-tests - old tests data
+;;
+;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests)
+;; (let* ((newdat (filter
+;; (lambda (x)
+;; (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
+;; (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat)
+;; tmptests
+;; (append tmptests prev-tests))
+;; (lambda (a b)
+;; (eq? (db:test-get-id a)(db:test-get-id b)))))))
+;; (print "Time took: " (- (current-seconds) start-time))
+;; (if (eq? *tests-sort-reverse* 3) ;; +event_time
+;; (sort newdat dboard:compare-tests)
+;; newdat)))
+
+;; this calls dboard:get-tests-for-run-duplicate for each run
+;;
+;; create a virtual table of all the tests
+;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
+;;
+(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
+ (let* ((keys (rmt:get-keys))
+ (last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
+ (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
+ (start-time (current-seconds))
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run header "id") run))
+ runs-tree) ;; (vector-ref runs-dat 1))
+ ht))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (dboard:tabdat-header-set! tabdat header)
;;
;; 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"))
- (key-vals (if (d:alldat-useserver *alldat*)
- (rmt:get-key-vals run-id)
- (db:get-key-vals (d:alldat-dblocal *alldat*) run-id)))
- (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f)))
- (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
- (prev-tests (vector-ref prev-dat 1))
- (last-update (vector-ref prev-dat 3))
- (tmptests (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id testnamepatt states statuses
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- sort-by
- sort-order
- 'shortlist
- last-update)
- (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- sort-by
- sort-order
- 'shortlist
- last-update)))
- (tests (let ((newdat (filter
- (lambda (x)
- (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
- (delete-duplicates (append tmptests prev-tests)
- (lambda (a b)
- (eq? (db:test-get-id a)(db:test-get-id b)))))))
- (if (eq? *tests-sort-reverse* 3) ;; +event_time
- (sort newdat compare-tests)
- newdat))))
- ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*)
- ;; (tests (bubble-up tmptests priority: bubble-type))
- ;; 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 (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set
- (not (null? tests)))
- (let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
- (hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct)
- (set! result (cons dstruct result))))))
- runs)
-
- (d:alldat-header-set! *alldat* header)
- (d:alldat-allruns-set! *alldat* result)
- (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs")
- maxtests))
+ (if (null? runs)
+ (begin
+ (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-all-test-names-set! tabdat '())
+ (dboard:tabdat-item-test-names-set! tabdat '())
+ (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
+ (let loop ((run (car runs))
+ (tal (cdr runs))
+ (res '())
+ (maxtests 0))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
+ (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
+ (key-vals (rmt:get-key-vals run-id))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
+ ;; dboard:get-tests-for-run-duplicate - returns a hash table
+ ;; (dboard:get-tests-dat tabdat run-id last-update))
+ (all-test-ids (hash-table-keys tests-ht))
+ (num-tests (length all-test-ids)))
+ ;; (print "run-struct: " run-struct)
+ ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
+ ;; (tests (bubble-up tmptests priority: bubble-type))
+ ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
+ ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
+ ;; Not sure this is needed?
+ (let* ((newmaxtests (max num-tests maxtests))
+ (last-update (- (current-seconds) 10))
+ (run-struct (or run-struct
+ (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals)))
+ (new-res (if (null? all-test-ids) res (cons run-struct res)))
+ (elapsed-time (- (current-seconds) start-time)))
+ (if (null? all-test-ids)
+ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
+ (if (or (null? tal)
+ (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
+ (begin
+ (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (if (> (dboard:rundat-run-data-offset run-struct) 0)
+ (loop run tal new-res newmaxtests) ;; not done getting data for this run
+ (loop (car tal)(cdr tal) new-res newmaxtests)))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (dboard:update-tree tabdat runs-hash header tb)))
(define *collapsed* (make-hash-table))
-; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
-(define (toggle-hide lnum) ; fulltestname)
+(define (toggle-hide lnum uidat) ; 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))
+ ;(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")
+ ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
(hash-table-delete! *collapsed* basetestname))
(begin
- ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
+ ;(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 "("))
@@ -453,11 +666,11 @@
(if (> (length splst) 1)
(vector-set! res 1 (car (string-split (cadr splst) ")"))))
res))
lst))
-(define (collapse-rows inlst)
+(define (collapse-rows tabdat 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
@@ -473,18 +686,18 @@
;(print "Removing " basetname " from items")
#f)
(else #t))))
inlst))
(vlst (run-item-name->vectors newlst))
- (vlst2 (bubble-up vlst priority: bubble-type)))
+ (vlst2 (bubble-up tabdat 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)
+
+(define (update-labels uidat alltestnames)
(let* ((rown 0)
(keycol (dboard:uidat-get-keycol uidat))
(lftcol (dboard:uidat-get-lftcol uidat))
(numcols (vector-length lftcol))
(maxn (- numcols 1))
@@ -491,11 +704,11 @@
(allvals (make-vector numcols "")))
(for-each (lambda (name)
(if (<= rown maxn)
(vector-set! allvals rown name)) ;)
(set! rown (+ 1 rown)))
- *alltestnamelst*)
+ alltestnames)
(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)))
@@ -523,11 +736,11 @@
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))
+(define (bubble-up tabdat 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
@@ -549,71 +762,92 @@
(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
- (d:alldat-item-test-names-set! *alldat* (append (if (null? tnames)
+ (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames)
'()
(filter (lambda (tname)
(let ((tlst (hash-table-ref tests tname)))
(and (list tlst)
(> (length tlst) 1))))
tnames))
- (d:alldat-item-test-names *alldat*)))
+ (dboard:tabdat-item-test-names tabdat)))
(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 (d:alldat-allruns *alldat*)) numruns)
- (take-right (d:alldat-allruns *alldat*) numruns)
- (pad-list (d:alldat-allruns *alldat*) numruns)))
+
+;; optimized to get runs constrained by what is visible on the screen
+;; - not appropriate for where all the runs are needed
+;;
+(define (update-buttons tabdat uidat numruns numtests)
+ (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns)
+ (take-right (dboard:tabdat-allruns tabdat) numruns)
+ (pad-list (dboard:tabdat-allruns tabdat) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
- (coln 0))
- (set! *alltestnamelst* '())
+ (coln 0)
+ (all-test-names (make-hash-table)))
+
;; 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 (d:alldat-hide-empty-runs *alldat*)
+ (if rundat
+ (let* ((testdats (dboard:rundat-tests rundat))
+ (testnames (map test:test-get-fullname (hash-table-values testdats))))
+ (dboard:rundat-copy-tests-to-by-name rundat)
+ ;; for the normalized list of testnames (union of all runs)
+ (if (not (and (dboard:tabdat-hide-empty-runs tabdat)
(null? testnames)))
(for-each (lambda (testname)
- (if (not (member testname *alltestnamelst*))
- (begin
- (set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
+ (hash-table-set! all-test-names testname #t))
testnames)))))
runs)
- (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
- (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (d:alldat-start-test-offset *alldat*))
- (drop *alltestnamelst* (d:alldat-start-test-offset *alldat*))
- '())))
- (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) ""))))
- (update-labels uidat)
+ ;; create the minimize list of testnames to be displayed. Sorting
+ ;; happens here *before* trimming
+ ;;
+ (dboard:tabdat-all-test-names-set!
+ tabdat
+ (collapse-rows
+ tabdat
+ (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here
+
+ ;; Trim the names list to fit the matrix of buttons
+ ;;
+ (dboard:tabdat-all-test-names-set!
+ tabdat
+ (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat))
+ (drop (dboard:tabdat-all-test-names tabdat)
+ (dboard:tabdat-start-test-offset tabdat))
+ '())))
+ (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
+ (update-labels uidat (dboard:tabdat-all-test-names tabdat))
(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) "") (d:alldat-keys *alldat*)))));; 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 (d:alldat-header *alldat*) "id"))
- (key-vals (append key-val-dat
- (list (let ((x (db:get-value-by-header run (d:alldat-header *alldat*) "runname")))
- (if x x "")))))
- (run-key (string-intersperse key-vals "\n")))
+ ;; if rundat is junk clobber it with a decent placeholder
+ (if (or (not rundat) ;; handle padded runs
+ (not (dboard:rundat-run rundat)))
+ (set! rundat (dboard:rundat-make-init
+ key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat)))))
+ (let* ((run (dboard:rundat-run rundat))
+ (testsdat-by-name (dboard:rundat-tests-by-name rundat))
+ (key-val-dat (dboard:rundat-key-vals rundat))
+ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
+ (key-vals (append key-val-dat
+ (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "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")))
@@ -620,36 +854,40 @@
(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 (d:alldat-buttondat *alldat*) (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))
+ (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f)))
+ (if (and buttondat
+ (hash-table? testsdat-by-name))
+ (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f)))
+ ;; (filter
+ ;; (lambda (x)(equal? (test:test-get-fullname x) testname))
+ ;; testsdat)))
+ (if (not matching)
+ (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
+ ;; (car matching))))
+ matching)))
+ (testname (db:test-get-testname testdat))
+ (itempath (db:test-get-item-path testdat))
+ (testfullname (test:test-get-fullname testdat))
+ (teststatus (db:test-get-status testdat))
+ (teststate (db:test-get-state testdat))
;;(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)))
+ (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))
@@ -657,40 +895,43 @@
(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 3 testdat)
(vector-set! buttondat 4 run-key)))
(set! rown (+ rown 1))))
- *alltestnamelst*))
+ (dboard:tabdat-all-test-names tabdat)))
(set! coln (+ coln 1))))
runs)))
(define (mkstr . x)
(string-intersperse (map conc x) ","))
-(define (set-bg-on-filter)
+(define (set-bg-on-filter commondat tabdat)
(let ((search-changed (not (null? (filter (lambda (key)
- (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%")))
- (hash-table-keys (d:alldat-searchpatts *alldat*))))))
- (state-changed (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))))
- (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*))))))
- (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR"
+ (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%")))
+ (hash-table-keys (dboard:tabdat-searchpatts tabdat))))))
+ (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))))
+ (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))))))
+ (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR"
(if (or search-changed
state-changed
status-changed)
"190 180 190"
"190 190 190"
- ))))
-
-(define (update-search x val)
- (hash-table-set! (d:alldat-searchpatts *alldat*) x val)
- (set-bg-on-filter))
-
-(define (mark-for-update)
- (d:alldat-last-db-update-set! *alldat* 0))
+ ))
+ (dboard:tabdat-filters-changed-set! tabdat #t)))
+
+(define (update-search commondat tabdat x val)
+ (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
+ (dboard:tabdat-filters-changed-set! tabdat #t)
+ (set-bg-on-filter commondat tabdat))
+
+(define (mark-for-update tabdat)
+ (dboard:tabdat-filters-changed-set! tabdat #t)
+ (dboard:tabdat-last-db-update-set! tabdat 0))
;;======================================================================
;; R U N C O N T R O L
;;======================================================================
@@ -734,55 +975,63 @@
(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))
+(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
- (db-target-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-targets)
- (db:get-targets (d:alldat-dblocal *alldat*))))
+ (key-lbs (dboard:tabdat-key-listboxes tabdat))
+ (db-target-dat (rmt:get-targets))
(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)))
+ (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
+ (list->vector
+ (take (append (string-split x "/")
+ (make-list (length header) "na"))
+ (length header)))))
+ (all-targets (append (list (munge-target (string-intersperse
+ (map (lambda (x) "%") header)
+ "/")))
+ db-targets
+ (map munge-target
+ runconf-targs)
+ ))
(key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
+ (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes))
(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"
+ #:size "x60"
#: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))
+ (debug:catch-and-dump action-proc "update-target-selector"))
+ #:caret_cb (lambda (obj a b c)
+ (debug:catch-and-dump action-proc "update-target-selector"))
))))
;; 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)))
+ (let* ((listboxes (append lbs (list lb)))
+ (res (list listboxes
+ (map (lambda (htxt lb)
+ (iup:vbox
+ (iup:label htxt)
+ lb))
+ header
+ listboxes))))
+ (dboard:tabdat-key-listboxes-set! tabdat res)
+ res)
(loop (car remkeys)
(cdr remkeys)
(append refvals (list selected-value))
(+ indx 1)
(append lbs (list lb))))))))
@@ -794,49 +1043,55 @@
(let ((alltgls (make-hash-table)))
(apply iup:vbox
(map (lambda (item)
(iup:toggle
item
+ #:fontsize 8
#: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)))))
+ (debug:catch-and-dump
+ (lambda ()
+ (if (eq? tstate 0)
+ (hash-table-delete! alltgls item)
+ (hash-table-set! alltgls item #t))
+ (let ((all (hash-table-keys alltgls)))
+ (proc all)))
+ "text-list-toggle-box"))))
items))))
-;; Extract the various bits of data from *data* and create the command line equivalent that will be displayed
+;; Extract the various bits of data from tabdat 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*)))
+(define (dashboard:update-run-command tabdat)
+ (let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
+ (cmd (dboard:tabdat-command tabdat))
+ (test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
(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*)))
+ (states (dboard:tabdat-states tabdat))
+ (statuses (dboard:tabdat-statuses tabdat))
+ (target (let ((targ-list (dboard:tabdat-target tabdat)))
(if targ-list (string-intersperse targ-list "/") "no-target-selected")))
- (run-name (dboard:data-get-run-name *data*))
+ (run-name (dboard:tabdat-run-name tabdat))
(states-str (if (or (not states)
(null? states))
""
- (conc " :state " (string-intersperse states ","))))
+ (conc " -state " (string-intersperse states ","))))
(statuses-str (if (or (not statuses)
(null? statuses))
""
- (conc " :status " (string-intersperse statuses ","))))
+ (conc " -status " (string-intersperse statuses ","))))
(full-cmd "megatest"))
(case (string->symbol cmd)
- ((runtests)
+ ((run)
(set! full-cmd (conc full-cmd
- " -runtests "
+ " -run"
+ " -testpatt "
test-patt
" -target "
target
" -runname "
run-name
+ " -clean-cache"
)))
((remove-runs)
(set! full-cmd (conc full-cmd
" -remove-runs -runname "
run-name
@@ -855,303 +1110,456 @@
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
(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 1)
- (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
- (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
- ;; set these
- (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- ))
+ ;; (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 1)
+ (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
+ (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
+ ;; set these
+ (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ ))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
-(define (dashboard:run-controls)
+
+(define (dboard:target-updater tabdat) ;; key-listboxes)
+ (let ((targ (map (lambda (x)
+ (iup:attribute x "VALUE"))
+ (car (dashboard:update-target-selector tabdat))))
+ (curr-runname (dboard:tabdat-run-name tabdat)))
+ (dboard:tabdat-target-set! tabdat targ)
+ ;; (if (dboard:tabdat-updater-for-runs tabdat)
+ ;; ((dboard:tabdat-updater-for-runs tabdat)))
+ (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
+ (equal? (dboard:tabdat-run-name tabdat) ""))
+ (dboard:tabdat-run-name-set! tabdat curr-runname))
+ (dashboard:update-run-command tabdat)))
+
+;; used by run-controls
+;;
+(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
+ (let* ((tb (dboard:tabdat-runs-tree tabdat))
+ (runconf-targs (common:get-runconfig-targets))
+ (db-target-dat (rmt:get-targets))
+ (header (vector-ref db-target-dat 0))
+ (db-targets (vector-ref db-target-dat 1))
+ (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
+ (take (append (string-split x "/")
+ (make-list (length header) "na"))
+ (length header))))
+ (all-targets (append (list (munge-target (string-intersperse
+ (map (lambda (x) "%") header)
+ "/")))
+ (map vector->list db-targets)
+ (map munge-target
+ runconf-targs)
+ )))
+ (for-each
+ (lambda (target)
+ (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name))
+ all-targets)))
+
+(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
(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")
+ (action "-run")
(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))))
+ ;;; (key-listboxes #f)
+ (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
+ (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
(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 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
- ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) 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 (if (d:alldat-useserver *alldat*)
- (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f)
- (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #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 test-records)
- (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 ((scalef (hash-table-ref tests-draw-state 'scalef)))
- (hash-table-set! tests-draw-state 'scalef (+ scalef
- (if (> step 0)
- (* scalef 0.01)
- (* scalef -0.01))))
- (if the-cnv
- (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
- ))
- ;; #:size "50x50"
- #:expand "YES"
- #:scrollbar "YES"
- #:posx "0.5"
- #:posy "0.5"
- #:button-cb (lambda (obj btn pressed x y status)
- ;; (print "obj: " obj ", pressed " pressed ", status " status)
- ; (print "canvas-origin: " (canvas-origin the-cnv))
- ;; (let-values (((xx yy)(canvas-origin the-cnv)))
- ;; (canvas-transform-set! the-cnv #f)
- ;; (print "canvas-origin: " xx " " yy " click at " x " " y))
- (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info))
- (selected-tests (hash-table-ref tests-draw-state 'selected-tests))
- (scalef (hash-table-ref tests-draw-state 'scalef))
- (sizey (hash-table-ref tests-draw-state 'sizey))
- (xoffset (dcommon:get-xoffset tests-draw-state #f #f))
- (yoffset (dcommon:get-yoffset tests-draw-state #f #f))
- (new-y (- sizey y)))
- ;; (print "xoffset=" xoffset ", yoffset=" yoffset)
- ;; (print "\tx\ty\tllx\tlly\turx\tury")
- (for-each (lambda (test-name)
- (let* ((rec-coords (hash-table-ref tests-info test-name))
- (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset))
- (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset))
- (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset))
- (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset)))
- ;; (if (eq? pressed 1)
- ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " "))
- (if (and (eq? pressed 1)
- (>= x llx)
- (>= new-y lly)
- (<= x urx)
- (<= new-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")))
- (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)))
-
- (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
-;; )))
+ ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
+ (let* ((result
+ (iup:vbox
+ (dcommon:command-execution-control tabdat)
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 200
+ ;;
+ ;; (iup:split
+ ;; #:value 300
+
+ ;; Target, testpatt, state and status input boxes
+ ;;
+ (iup:vbox
+ ;; Command to run, placed over the top of the canvas
+ (dcommon:command-action-selector commondat tabdat tab-num: tab-num)
+ (dboard:runs-tree-browser commondat tabdat)
+ (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
+ (dcommon:command-testname-selector commondat tabdat update-keyvals))
+ ;; key-listboxes))
+ (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:update-tree-selector tabdat))
+ tab-num: tab-num)
+ result)))
+
+ ;;(iup:frame
+ ;; #:title "Logs" ;; To be replaced with tabs
+ ;; (let ((logs-tb (iup:textbox #:expand "YES"
+ ;; #:multiline "YES")))
+ ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
+ ;; logs-tb))
+
+(define (dboard:runs-tree-browser commondat tabdat)
+ (let* ((tb (iup:treebox
+ #:value 0
+ #:name "Runs"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
+ (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (if (number? run-id)
+ (begin
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-view-changed-set! tabdat #t))
+ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+ "treebox"))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
+ (dboard:tabdat-runs-tree-set! tabdat tb)
+ tb))
+
+;;======================================================================
+;; R U N C O N T R O L S
+;;======================================================================
+;;
+;; A gui for launching tests
+;;
+(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
+ (let* ((drawing (vg:drawing-new))
+ (run-times-tab-updater (lambda ()
+ (debug:catch-and-dump
+ (lambda ()
+ (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (if tabdat
+ (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
+ (now-time (current-seconds)))
+ (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
+ (if (> (- now-time last-data-update) 5)
+ (if (not (dboard:tabdat-running-layout tabdat))
+ (begin
+ (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
+ (dboard:tabdat-last-data-update-set! tabdat now-time)
+ ;; this is threadified to return control to the gui for a redraw.
+ ;; it relies on the running-layout flag to prevent overlapping
+ ;; calls.
+ (thread-start! (make-thread
+ (lambda ()
+ (dboard:tabdat-running-layout-set! tabdat #t)
+ (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
+ (dboard:tabdat-running-layout-set! tabdat #f))
+ "run-times-tab-layout-updater")))
+ ))))))
+ "dashboard:run-times-tab-updater")))
+ (key-listboxes #f) ;;
+ (update-keyvals (lambda ()
+ (dboard:target-updater tabdat))))
+ (dboard:tabdat-drawing-set! tabdat drawing)
+ (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 150
+ (iup:vbox
+
+ (dboard:runs-tree-browser commondat tabdat)
+
+ (iup:hbox
+ (iup:toggle
+ "Compact layout"
+ #:fontsize 8
+ #:expand "HORIZONTAL"
+ #:value 1
+ #:action (lambda (obj tstate)
+ (debug:catch-and-dump
+ (lambda ()
+ (print "tstate: " tstate)
+ (if (eq? tstate 0)
+ (dboard:tabdat-compact-layout-set! tabdat #f)
+ (dboard:tabdat-compact-layout-set! tabdat #t))
+ (dboard:tabdat-last-filter-str-set! tabdat "")
+ )
+ "text-list-toggle-box"))))
+ (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
+ (dcommon:command-testname-selector commondat tabdat update-keyvals))
+ (iup:vbox
+ (let* ((cnv-obj (iup:canvas
+ ;; #:size "500x400"
+ #:expand "YES"
+ #:scrollbar "YES"
+ #:posx "0.5"
+ #:posy "0.5"
+ #:action (make-canvas-action
+ (lambda (c xadj yadj)
+ (debug:catch-and-dump
+ (lambda ()
+ (if (not (dboard:tabdat-cnv tabdat))
+ (let ((cnv (dboard:tabdat-cnv tabdat)))
+ (dboard:tabdat-cnv-set! tabdat c)
+ (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)
+ (dboard:tabdat-cnv tabdat))))
+ (let ((drawing (dboard:tabdat-drawing tabdat))
+ (old-xadj (dboard:tabdat-xadj tabdat))
+ (old-yadj (dboard:tabdat-yadj tabdat)))
+ (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj)))
+ (begin
+ ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5)))
+ (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5)))
+ ))))
+ "iup:canvas action")))
+ #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((drawing (dboard:tabdat-drawing tabdat))
+ (scalex (vg:drawing-scalex drawing)))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex)
+ (vg:drawing-scalex-set! drawing
+ (+ scalex
+ (if (> step 0)
+ (* scalex 0.02)
+ (* scalex -0.02))))))
+ "wheel-cb"))
+ )))
+ cnv-obj)))))
+
+;;======================================================================
+;; R U N
+;;======================================================================
+;;
+;; display and manage a single run at a time
+
+(define (tree-path->run-id tabdat path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
+ #f))
+
+(define (dboard:get-tests-dat tabdat run-id last-update)
+ (let* ((tdat (if run-id (rmt:get-tests-for-run run-id
+ (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
+ (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
+ #f #f ;; offset limit
+ (dboard:tabdat-hide-not-hide tabdat) ;; not-in
+ #f #f ;; sort-by sort-order
+ #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
+ (if (dboard:tabdat-filters-changed tabdat)
+ 0
+ last-update)
+ *dashboard-mode*)
+ '()))) ;; get 'em all
+ ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
+ (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)))))))
+
+
+(define (dashboard:safe-cadr-assoc name lst)
+ (let ((res (assoc name lst)))
+ (if (and res (> (length res) 1))
+ (cadr res)
+ #f)))
+
+(define (dboard:update-tree tabdat runs-hash runs-header tb)
+ (let* ((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)))))
+ (changed #f)
+ (last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (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))
+ (dboard:tabdat-keys tabdat)))
+ (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:tabdat-path-run-ids tabdat) run-path #f))
+ (begin
+ (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
+ ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
+ ;; (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:tabdat-path-run-ids tabdat) run-path run-id)
+ ;; (set! colnum (+ colnum 1))
+ ))))
+ run-ids)))
+
+(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)
+ (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (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)))
+ (dboard:update-tree tabdat runs-hash runs-header tb)
+ (if run-id
+ (let* (
+
+ (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0))
+ (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f)
+ (let* ((db-dir (tasks:get-task-db-path))
+ (db-pth (conc db-dir "/" run-id ".db")))
+ (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth)
+ db-pth)))
+ (tests-dat (if (or (not run-id)
+ (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
+ (not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id))
+ (>= (file-modification-time db-path) last-update))
+ (dboard:get-tests-dat tabdat run-id last-update)
+ (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id)))
+ (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 (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
+ (numrows 1)
+ (numcols 1)
+ (changed #f)
+ )
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
+ (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (let loop ((pass-num 0)
+ (changed #f))
+ ;; Update the runs tree
+ (dboard:update-tree tabdat runs-hash runs-header tb)
+
+ (if (eq? pass-num 1)
+ (begin ;; big reset
+ (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
+ (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
+ (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
+
+ (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
+ (iup:attribute-set! run-matrix "NUMCOL" max-col ))
+
+ (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
+ (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
+ (iup:attribute-set! run-matrix "NUMLIN" effective-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)
+ ;; (print "row-indices: " row-indices " col-indices: " col-indices)
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass
+
+ ;; Cell contents
+ (for-each (lambda (entry)
+ ;; (print "entry: " 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)
+ (if (<= num max-col)
+ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
+ col-indices)
+
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass due to column labels changing
+
+ ;; (debug:print 0 *default-log-port* "one-run-updater, changed: " changed " pass-num: " pass-num)
+ ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num)
+ (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
+
+ )
;;======================================================================
;; 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)))
+(define (dashboard:summary commondat tabdat #!key (tab-num #f))
+ (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)))
+ (changed #f))
(iup:vbox
(iup:split
#:value 500
(iup:frame
#:title "General Info"
@@ -1163,11 +1571,11 @@
(dcommon:keys-matrix rawconfig)
(dcommon:general-info)
)))
(iup:frame
#:title "Server"
- (dcommon:servers-table)))
+ (dcommon:servers-table commondat tabdat)))
(iup:frame
#:title "Megatest config settings"
(iup:hbox
(dcommon:section-matrix rawconfig "setup" "Varname" "Value")
(iup:vbox
@@ -1175,503 +1583,400 @@
;; (iup:frame
;; #:title "Disks Areas"
(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
(iup:frame
#:title "Run statistics"
- (dcommon:run-stats db)))))
+ (dcommon:run-stats commondat tabdat tab-num: tab-num)))))
+
+;;======================================================================
+;; H A N D L E U S E R C O N T R I B U T E D V I E W S
+;;======================================================================
+
+(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num)
+ (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load.
+ (source (configf:lookup views-cfgdat view-name "source"))
+ (viewgen (configf:lookup views-cfgdat view-name "viewgen"))
+ (updater (configf:lookup views-cfgdat view-name "updater"))
+ (result-child #f))
+ (if (and (file-exists? source)
+ (file-read-access? source))
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl")
+ (set! success #f))
+ (load source))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name)))
+ ;; now run the user supplied definition for the tab view
+ (if success
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen
+ ", with; tab-num=" tab-num ", view-name=" view-name
+ ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
+ (set! success #f))
+ (print "Adding tab " view-name " with proc " viewgen)
+ ;; (iup:child-add! tabs
+ (set! result-child
+ ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
+ ;; and finally set the updater
+ (if success
+ (dboard:commondat-add-updater commondat
+ (lambda ()
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater
+ "\", with; tabnum=" tabnum ", view-name=" view-name
+ ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
+ (set! success #f))
+ (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num)
+ ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*)))
+ tab-num: tab-num))
+ (if success
+ (begin
+ ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name)
+ (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data))))
+ result-child))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
-(define (tree-path->run-id data path)
- (if (not (null? path))
- (hash-table-ref/default (d:data-path-run-ids data) path #f)
- #f))
-
-(define dashboard:update-run-summary-tab #f)
-
;; This is the Run Summary tab
;;
-(define (dashboard:one-run db data)
- (let* ((tb (iup:treebox
+(define (dashboard:one-run commondat tabdat #!key (tab-num #f))
+ (let* ((update-mutex (dboard:commondat-update-mutex commondat))
+ (tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#: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 data (cdr run-path))))
- (if (number? run-id)
- (begin
- (d:data-curr-run-id-set! data run-id)
- (dashboard:update-run-summary-tab))
- (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
- ;; (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 " (d:data-curr-run-id data) "," test-id "&")))
- (system cmd)))))
- (updater (lambda ()
- (let* ((runs-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
- (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (run-id (d:data-curr-run-id data))
- (last-update 0) ;; fix me
- (tests-dat (let ((tdat (if run-id
- (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update) ;; get 'em all
- (db:get-tests-for-run db run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update))
- '()))) ;; 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 (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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))
- (d:alldat-keys *alldat*)))
- (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 (d:data-path-run-ids data) run-path #f))
- (begin
- (hash-table-set! (d:data-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! (d:data-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)
- (d:data-runs-tree-set! data tb)
- (iup:split
- tb
- run-matrix)))
-
-;; This is the New View tab
-;;
-(define (dashboard:new-view db data)
- (let* ((tb (iup:treebox
- #:value 0
- #:name "Runs"
- #:expand "YES"
- #:addexpanded "NO"
- #: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 data (cdr run-path))))
- (if (number? run-id)
- (begin
- (d:data-curr-run-id-set! data run-id)
- (dashboard:update-run-summary-tab))
- (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
+ (debug:catch-and-dump
+ (lambda ()
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ (if (number? run-id)
+ (begin
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ ;; (dashboard:update-run-summary-tab)
+ )
+ ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
+ )))
+ "selection-cb in one-run")
+ ;; (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 " (d:data-curr-run-id data) "," test-id "&")))
+ (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&")))
(system cmd)))))
- (updater (lambda ()
- (let* ((runs-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
- (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (run-id (d:data-curr-run-id data))
- (last-update 0) ;; fix me
- (tests-dat (let ((tdat (if run-id
- (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update) ;; get 'em all
- (db:get-tests-for-run db run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update))
- '()))) ;; 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 (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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))
- (d:alldat-keys *alldat*)))
- (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 (d:data-path-run-ids data) run-path #f))
- (begin
- (hash-table-set! (d:data-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! (d:data-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)
- (d:data-runs-tree-set! data tb)
- (iup:split
- tb
- run-matrix)))
+ (one-run-updater
+ (lambda ()
+ (mutex-lock! update-mutex)
+ (if (or (dashboard:database-changed? commondat tabdat)
+ (dboard:tabdat-view-changed tabdat))
+ (debug:catch-and-dump
+ (lambda () ;; check that run-matrix is initialized before calling the updater
+ (if run-matrix
+ (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)))
+ "dashboard:one-run-updater")
+ )
+ (mutex-unlock! update-mutex))))
+ (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num)
+ (dboard:tabdat-runs-tree-set! tabdat tb)
+ (iup:vbox
+ (iup:split
+ tb
+ run-matrix)
+ (dboard:make-controls commondat tabdat))))
;;======================================================================
;; R U N S
;;======================================================================
-(define (make-dashboard-buttons db nruns ntests keynames runs-sum-dat new-view-dat)
- (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)
- (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*)))
- (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE"))
- (mark-for-update)))
- (let ((hideit (iup:button "HideTests" #:action (lambda (obj)
- (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*)))
- (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide"))
- (mark-for-update)))))
- (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ...
- hideit))
- (iup:hbox
- (iup:button "Quit" #:action (lambda (obj)
- ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*)))
- (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))
- (d:alldat-item-test-names *alldat*))
- (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! (d:alldat-status-ignore-hash *alldat*) status #t)
- (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) 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! (d:alldat-state-ignore-hash *alldat*) state #t)
- (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) 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 (d:alldat-tot-runs *alldat*)))
- (d:alldat-start-run-offset-set! *alldat* val)
- (mark-for-update)
- (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
- (iup:attribute-set! obj "MAX" (* maxruns 10))))
+(define (dboard:make-controls commondat tabdat)
+ (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
+ (iup:hbox
+ (iup:vbox
+ (iup:frame
+ #:title "filter test and items"
+ (iup:hbox
+ (iup:vbox
+ (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
+ #:expand "NO"
+ #:action (lambda (obj unk val)
+ (debug:catch-and-dump
+ (lambda ()
+ (mark-for-update tabdat)
+ (update-search commondat tabdat "test-name" val))
+ "make-controls")))
+ (iup:hbox
+ (iup:button "Quit" #:action (lambda (obj)
+ ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat)))
+ (exit))
+ #:expand "NO" #:size "40x15")
+ (iup:button "Refresh" #:action (lambda (obj)
+ (mark-for-update tabdat))
+ #:expand "NO" #:size "40x15")
+ (iup:button "Collapse" #:action (lambda (obj)
+ (debug:catch-and-dump
+ (lambda ()
+ (let ((myname (iup:attribute obj "TITLE")))
+ (if (equal? myname "Collapse")
+ (begin
+ (for-each (lambda (tname)
+ (hash-table-set! *collapsed* tname #t))
+ (dboard:tabdat-item-test-names tabdat))
+ (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 tabdat))
+ "make-controls collapse button"))
+ #:expand "NO" #:size "40x15")))
+ (iup:vbox
+ ;; (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 tabdat)))
+
+ (let* ((hide #f)
+ (show #f)
+ (hide-empty #f)
+ (sel-color "180 100 100")
+ (nonsel-color "170 170 170")
+ (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
+ (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL"
+ #:size "80x15"
+ #:dropdown "YES"
+ #:action (lambda (obj val index lbstate)
+ (set! *tests-sort-reverse* index)
+ (mark-for-update tabdat))))
+ (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
+ (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
+
+ (set! hide-empty (iup:button "HideEmpty"
+ ;; #:expand HORIZONTAL"
+ #:expand "NO" #:size "80x15"
+ #:action (lambda (obj)
+ (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
+ (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
+ (mark-for-update tabdat))))
+ (set! hide (iup:button "Hide"
+ #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
+ ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
+ (iup:attribute-set! hide "BGCOLOR" sel-color)
+ (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ (mark-for-update tabdat))))
+ (set! show (iup:button "Show"
+ #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
+ (iup:attribute-set! show "BGCOLOR" sel-color)
+ (iup:attribute-set! hide "BGCOLOR" nonsel-color)
+ (mark-for-update tabdat))))
+ (iup:attribute-set! hide "BGCOLOR" sel-color)
+ (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
+ (iup:vbox
+ (iup:hbox hide show)
+ hide-empty sort-lb)))
+ )))
+ (iup:frame
+ #:title "state/status filter"
+ (iup:vbox
+ (apply
+ iup:hbox
+ (map (lambda (status)
+ (iup:toggle (conc status " ")
+ #:fontsize btn-fontsz ;; "10"
+ #:expand "HORIZONTAL"
+ #:action (lambda (obj val)
+ (mark-for-update tabdat)
+ (if (eq? val 1)
+ (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
+ (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
+ (set-bg-on-filter commondat tabdat))))
+ (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
+ (apply
+ iup:hbox
+ (map (lambda (state)
+ (iup:toggle (conc state " ")
+ #:fontsize btn-fontsz
#:expand "HORIZONTAL"
- #:max (* 10 (length (d:alldat-allruns *alldat*)))
- #:min 0
- #:step 0.01)))
- ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1))))
- ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0))))
- )
- )
+ #:action (lambda (obj val)
+ (mark-for-update tabdat)
+ (if (eq? val 1)
+ (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
+ (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
+ (set-bg-on-filter commondat tabdat))))
+ (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 (dboard:tabdat-tot-runs tabdat)))
+ (dboard:tabdat-start-run-offset-set! tabdat val)
+ (mark-for-update tabdat)
+ (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
+ (iup:attribute-set! obj "MAX" (* maxruns 10))))
+ #:expand "HORIZONTAL"
+ #:max (* 10 (length (dboard:tabdat-allruns tabdat)))
+ #:min 0
+ #:step 0.01)))
+ ;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
+ ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
+ )))
+
+(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt)
+ (iup:menu
+ (iup:menu-item
+ "Run"
+ (iup:menu
+ (iup:menu-item
+ (conc "Rerun " testpatt)
+ #:action
+ (lambda (obj)
+ ;;(print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt)
+ (common:run-a-command
+ (conc "megatest -run -target " target
+ " -runname " runname
+ " -testpatt " testpatt
+ " -preclean -clean-cache")
+ )))
+ (iup:menu-item
+ "Rerun Complete Run"
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
+ " -runname " runname
+ " -testpatt % "
+ " -preclean -clean-cache"))))
+ (iup:menu-item
+ "Clean Complete Run"
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -remove-runs -target " target
+ " -runname " runname
+ " -testpatt % "))))))
+ (iup:menu-item
+ "Test"
+ (iup:menu
+ (iup:menu-item
+ (conc "Rerun " test-name)
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
+ " -runname " runname
+ " -testpatt " test-name
+ " -preclean -clean-cache"))))
+ (iup:menu-item
+ (conc "Kill " test-name)
+ #:action
+ (lambda (obj)
+ ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
+ (common:run-a-command
+ (conc "megatest -set-state-status KILLREQ,n/a -target " target
+ " -runname " runname
+ " -testpatt " test-name
+ " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
+ (iup:menu-item
+ (conc "Clean " test-name)
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -remove-runs -target " target
+ " -runname " runname
+ " -testpatt " test-name))))
+ (iup:menu-item
+ "Start xterm"
+ #:action
+ (lambda (obj)
+ (dcommon:examine-xterm run-id test-id)))
+ ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
+ ;; (system cmd))))
+ (iup:menu-item
+ "Edit testconfig"
+ #:action
+ (lambda (obj)
+ (let* ((all-tests (tests:get-all))
+ (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex")
+ "\\b(vim?|nano|pico)\\b"))
+ (editor (or (configf:lookup *configdat* "setup" "editor")
+ (get-environment-variable "VISUAL")
+ (get-environment-variable "EDITOR") "vi"))
+ (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
+ (cmd (conc (if (string-search editor-rx editor)
+ (conc "xterm -e " editor)
+ editor)
+ " " tconfig " &")))
+ (system cmd))))
+ ))))
+
+(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
+ (let* ((stats-dat (dboard:tabdat-make-data))
+ (runs-dat (dboard:tabdat-make-data))
+ (onerun-dat (dboard:tabdat-make-data))
+ (runcontrols-dat (dboard:tabdat-make-data))
+ (runtimes-dat (dboard:tabdat-make-data))
+ (nruns (dboard:tabdat-numruns runs-dat))
+ (ntests (dboard:tabdat-num-tests runs-dat))
+ (keynames (dboard:tabdat-dbkeys runs-dat))
+ (nkeys (length keynames))
+ (runsvec (make-vector nruns))
+ (header (make-vector nruns))
+ (lftcol (make-vector ntests))
+ (keycol (make-vector ntests))
+ (controls (dboard:make-controls commondat runs-dat)) ;; '())
+ (lftlst '())
+ (hdrlst '())
+ (bdylst '())
+ (result '())
+ (i 0)
+ (btn-height (dboard:tabdat-runs-btn-height runs-dat))
+ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
+ (cell-width (dboard:tabdat-runs-cell-width runs-dat)))
+ ;; controls (along bottom)
+ ;; (set! controls (dboard:make-controls commondat runs-dat))
;; 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"
+ (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL")
+ (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL"
#:action (lambda (obj unk val)
- (mark-for-update)
- (update-search x val))))))
+ (mark-for-update runs-dat)
+ (update-search commondat runs-dat x val))))))
(set! i (+ i 1))
res))
keynames)))))
(let loop ((testnum 0)
(res '()))
@@ -1680,37 +1985,37 @@
;; 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*))))
- (d:alldat-please-update-set! *alldat* #t)
- (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10))))
- (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax)
+ (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
+ (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " 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 ""
+ (let ((labl (iup:button "" ;; the testname labels
#:flat "YES"
#:alignment "ALEFT"
; #:image img1
; #:impress img2
- #:size "x15"
- #:expand "HORIZONTAL"
- #:fontsize "10"
+ #:size (conc cell-width btn-height)
+ #:expand "HORIZONTAL"
+ #:fontsize btn-fontsz
#:action (lambda (obj)
- (mark-for-update)
- (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
+ (mark-for-update runs-dat)
+ (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE"))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
- ;;
+ ;; These are the headers for each row
(let loop ((runnum 0)
(keynum 0)
(keyvec (make-vector nkeys))
(res '()))
(cond ;; nb// no else for this approach.
@@ -1718,11 +2023,11 @@
((>= 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"
+ (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "NO"))) ;; #:expand "HORIZONTAL" "60x15"
(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)
@@ -1734,149 +2039,847 @@
(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 (d:alldat-buttondat *alldat*) 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! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f))
+ (butn (iup:button
+ "" ;; button-key
+ #:size (conc cell-width btn-height )
+ #:expand "NO"
+ #:fontsize btn-fontsz
+ #:button-cb
+ (lambda (obj a pressed x y btn . rem)
+ ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
+ (if (substring-index "3" btn)
+ (if (eq? pressed 1)
+ (let* ((toolpath (car (argv)))
+ (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
+ (test-id (db:test-get-id (vector-ref buttndat 3)))
+ (run-id (db:test-get-run_id (vector-ref buttndat 3)))
+ (run-info (rmt:get-run-info run-id))
+ (target (rmt:get-target run-id))
+ (runname (db:get-value-by-header (db:get-rows run-info)
+ (db:get-header run-info) "runname"))
+ (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
+ (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
+ (if tlast
+ (let ((tpatt (tasks:task-get-testpatt tlast)))
+ (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
+ "%"
+ tpatt))
+ "%"))))
+ (iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ ;; (print "got here")
+ ))
+ (if (eq? pressed 0)
+ (let* ((toolpath (car (argv)))
+ (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) 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 "&")))
+ (system cmd)))
+ )))))
+ (hash-table-set! (dboard:tabdat-buttondat runs-dat) 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))
- (data (d:data-init (make-d:data)))
- (tabs (iup:tabs
- #:tabchangepos-cb (lambda (obj curr prev)
- (d:alldat-please-update-set! *alldat* #t)
- (d:alldat-curr-tab-num-set! *alldat* curr))
- (dashboard:summary db)
- runs-view
- (dashboard:one-run db runs-sum-dat)
- (dashboard:new-view db new-view-dat)
- (dashboard:run-controls)
- )))
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 150
+ (dboard:runs-tree-browser commondat runs-dat)
+ (iup:split
+ ;; left most block, including row names
+ (apply iup:vbox lftlst)
+ ;; right hand block, including cells
+ (iup:vbox
+ ;; the header
+ (apply iup:hbox (reverse hdrlst))
+ (apply iup:hbox (reverse bdylst)))))
+ controls
+ ))
+ (views-cfgdat (common:load-views-config))
+ (additional-tabnames '())
+ (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
+ ;; (data (dboard:tabdat-init (make-d:data)))
+ (additional-views ;; process views-dat
+ (let ((tab-num tab-start-num)
+ (result '()))
+ (for-each
+ (lambda (view-name)
+ (debug:print 0 *default-log-port* "Adding view " view-name)
+ (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
+ (if (not (string? cfgtype))
+ (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
+ "\" is missing needed sections. Please consult the documenation and update ~/.mtviews.config or " *toppath* "/.mtviews.config")
+ (case (string->symbol cfgtype)
+ ;; user supplied source for a tab
+ ;;
+ ((external)
+ (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) ;; was tabs
+ (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
+ (set! tab-num (+ tab-num 1))
+ (set! result (append result (list tab-content)))))))))
+ (sort (hash-table-keys views-cfgdat) (lambda (a b)
+ (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
+ (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
+ (> order-a order-b)))))
+ result))
+ (tabs (apply iup:tabs
+ #:tabchangepos-cb (lambda (obj curr prev)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
+ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (dboard:tabdat-layout-update-ok-set! tabdat #f))
+ (dboard:commondat-curr-tab-num-set! commondat curr)
+ (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
+ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-layout-update-ok-set! tabdat #t)))
+ "tabchangepos"))
+ (dashboard:summary commondat stats-dat tab-num: 0)
+ runs-view
+ (dashboard:one-run commondat onerun-dat tab-num: 2)
+ ;; (dashboard:new-view db data new-view-dat tab-num: 3)
+ (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
+ (dashboard:run-times commondat runtimes-dat tab-num: 4)
+ additional-views)))
;; (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" "New View")
- (iup:attribute-set! tabs "TABTITLE4" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE3" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE4" "Run Times")
+ ;; (iup:attribute-set! tabs "TABTITLE3" "New View")
+ ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
+
+ ;; set the tab names for user added tabs
+ (for-each
+ (lambda (tab-info)
+ (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
+ additional-tabnames)
+
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
- (d:alldat-hide-not-hide-tabs-set! *alldat* tabs)
- tabs)))
+ ;; make the iup tabs object available (for changing color for example)
+ (dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
+ ;; now set up the tabdat lookup
+ (dboard:common-set-tabdat! commondat 0 stats-dat)
+ (dboard:common-set-tabdat! commondat 1 runs-dat)
+ (dboard:common-set-tabdat! commondat 2 onerun-dat)
+ (dboard:common-set-tabdat! commondat 3 runcontrols-dat)
+ (dboard:common-set-tabdat! commondat 4 runtimes-dat)
+
+ (iup:vbox
+ tabs
+ ;; controls
+ ))))
(vector keycol lftcol header runsvec)))
-(if (or (args:get-arg "-rows")
- (get-environment-variable "DASHBOARDROWS" ))
- (begin
- (d:alldat-num-tests-set! *alldat* (string->number
- (or (args:get-arg "-rows")
- (get-environment-variable "DASHBOARDROWS"))))
- (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
- (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))
-
+(define (dboard:setup-num-rows tabdat)
+ (dboard:tabdat-num-tests-set! tabdat (string->number
+ (or (args:get-arg "-rows")
+ (get-environment-variable "DASHBOARDROWS")
+ "15"))))
+
(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...
-;;
-(d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
-(define (dashboard:been-changed)
- (> (file-modification-time (d:alldat-dbfpath *alldat*)) (d:alldat-last-db-update *alldat*)))
+(define (dashboard:been-changed tabdat)
+ (> (file-modification-time (dboard:tabdat-dbfpath tabdat)) (dboard:tabdat-last-db-update tabdat)))
-(define (dashboard:set-db-update-time)
- (d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))))
+(define (dashboard:set-db-update-time tabdat)
+ (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat))))
(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 (d:alldat-dbdir *alldat*) "/monitor.db"))
+;; (define *monitor-db-path* #f)
(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)
+(define (dashboard:get-youngest-run-db-mod-time tabdat)
(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))
+ (debug:print 0 *default-log-port* "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 (d:alldat-dbdir *alldat*) "/*.db"))))))
-
-(define (dashboard:run-update x)
- (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*)))
- (monitor-modtime (if (file-exists? *monitor-db-path*)
- (file-modification-time *monitor-db-path*)
- -1))
- (run-update-time (current-seconds))
- (recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*))))
- (if (and (eq? (d:alldat-curr-tab-num *alldat*) 0)
+ (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
+
+(define (dashboard:monitor-changed? commondat tabdat)
+ (let* ((run-update-time (current-seconds))
+ (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
+ (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
+ (file-modification-time monitor-db-path)
+ -1)))
+ (if (and (eq? (dboard:commondat-curr-tab-num commondat) 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 (d:alldat-curr-tab-num *alldat*)
- ((0)
- (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
- ((1) ;; The runs table is active
- (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%")
- (let ((res '()))
- (for-each (lambda (key)
- (if (not (equal? key "runname"))
- (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f)))
- (if val (set! res (cons (list key val) res))))))
- (d:alldat-dbkeys *alldat*))
- res))
- (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*)))
- ((2)
- (dashboard:update-run-summary-tab))
- ((3)
- (dashboard:update-run-summary-tab))
- (else
- (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*)
- (d:alldat-curr-tab-num *alldat*) #f)))
- (if updater (updater)))))
- (d:alldat-please-update-set! *alldat* #f)
- (d:alldat-last-db-update-set! *alldat* modtime)
- (set! *last-recalc-ended-time* (current-milliseconds))))))
+ #t)
+ #f)))
+
+(define (dashboard:database-changed? commondat tabdat)
+ (let* ((run-update-time (current-seconds))
+ (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!!
+ (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat))))
+ (dboard:commondat-please-update-set! commondat #f)
+ recalc))
+
+;; point inside line
+;;
+(define-inline (dashboard:px-between px lx1 lx2)
+ (and (< lx1 px)(> lx2 px)))
+
+;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing
+;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
+;;
+(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
+ (let ((lastrow (if num-rows (+ rownum num-rows) rownum)))
+ (let loop ((i 0)
+ (rowdat (hash-table-ref/default rowhash rownum '())))
+ (if (null? rowdat)
+ #f
+ (let rowloop ((bar (car rowdat))
+ (tal (cdr rowdat)))
+ (let ((bx1 (car bar))
+ (bx2 (cdr bar)))
+ (cond
+ ;; newbar x1 inside bar
+ ((dashboard:px-between x1 bx1 bx2) #t)
+ ((dashboard:px-between x2 bx1 bx2) #t)
+ ((and (<= x1 bx1)(>= x2 bx2)) #t)
+ (else (if (null? tal)
+ (if (< i lastrow)
+ (loop (+ i 1)
+ (hash-table-ref/default rowhash (+ rownum i) '()))
+ #f)
+ (rowloop (car tal)(cdr tal)))))))))))
+
+(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0))
+ (let loop ((i 0))
+ (hash-table-set! rowhash
+ (+ i rownum)
+ (cons (cons x1 x2)
+ (hash-table-ref/default rowhash (+ i rownum) '())))
+ (if (< i num-rows)
+ (loop (+ i 1)))))
+
+;; get min or max, use > for max and < for min, this works around the limits on apply
+;;
+(define (dboard:min-max comp lst)
+ (if (null? lst)
+ #f ;; better than an exception for my needs
+ (fold (lambda (a b)
+ (if (comp a b) a b))
+ (car lst)
+ lst)))
+
+;; sort a list of test-ids by the event _time using a hash table of id => testdat
+;;
+(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht)
+ (sort test-ids
+ (lambda (a b)
+ (< (db:test-get-event_time (hash-table-ref tests-ht a))
+ (db:test-get-event_time (hash-table-ref tests-ht b))))))
+
+;; first group items into lists, then sort by time
+;; finally sort by first item time
+;;
+;; NOTE: we are returning lists of lists of ids!
+;;
+(define (dboard:tests-sort-by-time-group-by-item testsdat)
+ (let ((test-ids (hash-table-keys testsdat)))
+ (if (null? test-ids)
+ test-ids
+ ;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ...
+ (let* ((test-ids-by-name
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (tdat)
+ (let ((testname (db:test-get-testname tdat))
+ (test-id (db:test-get-id tdat)))
+ (hash-table-set!
+ ht
+ testname
+ (cons test-id (hash-table-ref/default ht testname '())))))
+ (hash-table-values testsdat))
+ ht)))
+ ;; remove toplevel tests from iterated tests, sort tests in the list by event time
+ (for-each
+ (lambda (testname)
+ (let ((tests-id-lst (hash-table-ref test-ids-by-name testname)))
+ (if (> (length tests-id-lst) 1) ;; must be iterated
+ (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests
+ (let ((tdat (hash-table-ref testsdat tid)))
+ (not (equal? (db:test-get-item-path tdat) ""))))
+ tests-id-lst)))
+ (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition
+ (hash-table-set! test-ids-by-name
+ testname
+ (dboard:sort-testsdat-by-event-time item-tests testsdat)))))))
+ (hash-table-keys test-ids-by-name))
+ ;; finally sort by the event time of the first test
+ (sort (hash-table-values test-ids-by-name)
+ (lambda (a b)
+ (< (db:test-get-event_time (hash-table-ref testsdat (car a)))
+ (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
+
+;; run times tab data updater
+;;
+(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
+ (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (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)))))
+ (tb (dboard:tabdat-runs-tree tabdat))
+ (num-runs (length (hash-table-keys runs-hash)))
+ (update-start-time (current-seconds))
+ (inc-mode #f))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ ;; fill in the tree
+ (if (and tb
+ (not inc-mode))
+ (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))
+ (dboard:tabdat-keys tabdat)))
+ (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:tabdat-path-run-ids tabdat) run-path #f))
+ (begin
+ (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
+ ;; 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:tabdat-path-run-ids tabdat) run-path run-id)
+ ;; (set! colnum (+ colnum 1))
+ ))))
+ run-ids))
+ ;; (print "Updating rundat")
+ (if (dboard:tabdat-keys tabdat) ;; have keys yet?
+ (let* ((num-keys (length (dboard:tabdat-keys tabdat)))
+ (targpatt (map (lambda (k v)
+ (list k v))
+ (dboard:tabdat-keys tabdat)
+ (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
+ '("%" "%"))
+ (make-list num-keys "%"))
+ num-keys)
+ ))
+ (runpatt (if (dboard:tabdat-target tabdat)
+ (last (dboard:tabdat-target tabdat))
+ "%"))
+ (testpatt (or (dboard:tabdat-test-patts tabdat) "%"))
+ (filtrstr (conc targpatt "/" runpatt "/" testpatt)))
+ ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt)
+
+ (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
+ (let ((dwg (dboard:tabdat-drawing tabdat)))
+ (print "reseting drawing")
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (vg:drawing-libs-set! dwg (make-hash-table))
+ (vg:drawing-insts-set! dwg (make-hash-table))
+ (vg:drawing-cache-set! dwg '())
+ (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
+ ;; (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-max-row-set! tabdat 0)
+ (dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
+ (update-rundat tabdat
+ runpatt
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
+ 10 ;; (dboard:tabdat-numruns tabdat)
+ testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
+
+ targpatt
+
+ ;; old method
+ ;; (let ((res '()))
+ ;; (for-each (lambda (key)
+ ;; (if (not (equal? key "runname"))
+ ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
+ ;; (if val (set! res (cons (list key val) res))))))
+ ;; (dboard:tabdat-dbkeys tabdat))
+ ;; res)
+ )))))
+
+;; run times canvas updater
+;;
+(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
+ (let ((cnv (dboard:tabdat-cnv tabdat))
+ (dwg (dboard:tabdat-drawing tabdat))
+ (mtx (dboard:tabdat-runs-mutex tabdat))
+ (vch (dboard:tabdat-view-changed tabdat)))
+ (if (and cnv dwg vch)
+ (begin
+ (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
+ (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
+ (mutex-lock! mtx)
+ (canvas-clear! cnv)
+ (vg:draw dwg tabdat)
+ (mutex-unlock! mtx)
+ (dboard:tabdat-view-changed-set! tabdat #f)))))
+
+;; doesn't work.
+;;
+;;(define (gotoescape tabdat escape)
+;; (or (dboard:tabdat-layout-update-ok tabdat)
+;; (escape #t)))
+
+(define (dboard:graph-db-open dbstr)
+ (let* ((parts (string-split dbstr ":"))
+ (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
+ dbstr
+ (if (equal? (car parts) "sqlite3")
+ (cadr parts)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
+ #f)))))
+ (if (and dbpth (file-read-access? dbpth))
+ (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ db)
+ #f)))
+
+;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
+;;
+(define (dboard:graph-read-data cmdstring tstart tend)
+ (let* ((parts (string-split cmdstring))) ;; spaces not allowed
+ (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ...
+ (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring)
+ (let* ((dbdef (list-ref parts 0))
+ (tablen (list-ref parts 1))
+ (timef (list-ref parts 2))
+ (varfn (list-ref parts 3))
+ (valfn (list-ref parts 4))
+ (fields (cdr (cddddr parts)))
+ (db (dboard:graph-db-open dbdef))
+ (res-ht (make-hash-table)))
+ (if db
+ (begin
+ (for-each
+ (lambda (fieldname) ;; fields
+ (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC"))
+ (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
+ (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res t var val)
+ (cons (vector t var val) res))
+ '() db all-dat-qrystr)))
+ (let ((zeropt (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-row db all-dat-qrystr))))
+ (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
+ (hash-table-set! res-ht
+ fieldname
+ (cons
+ (apply vector tstart (cdr zeropt))
+ (hash-table-ref/default res-ht fieldname '())))))))
+ fields)
+ res-ht)
+ #f)))))
+
+;; graph data
+;; tsc=timescale, tfn=function; time->x
+;;
+(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin)
+ (let* ((dwg (dboard:tabdat-drawing tabdat))
+ (lib (vg:get/create-lib dwg "runslib"))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (dur (- tstart tend)) ;; time duration
+ (cmp (vg:get-component dwg "runslib" compname))
+ (cfg (configf:get-section *configdat* "graph"))
+ (stdcolor (vg:rgb->number 120 130 140))
+ (delta-y (- uly lly)))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj llx lly ulx uly))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart)))
+ (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend)))
+ (let loop ((mark first)
+ (count 0))
+ (let* ((smark (tfn mark)) ;; scale the mark
+ (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark
+ (label (conc (* count span) timesym))) ;; was mark-delta
+ (if (> count 2)
+ (begin
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- smark 1)(- lly 10) label))))
+ (if (< mark (- tend time-blk))
+ (loop (+ mark time-blk)(+ count 1))))))
+ (for-each
+ (lambda (cf)
+ (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend)))
+ (if alldat
+ (for-each
+ (lambda (fieldn)
+ (let* ((dat (hash-table-ref alldat fieldn))
+ (vals (map (lambda (x)(vector-ref x 2)) dat)))
+ (if (not (null? vals))
+ (let* ((maxval (apply max vals))
+ (minval (min 0 (apply min vals)))
+ (yoff (- minval lly)) ;; minval))
+ (deltaval (- maxval minval))
+ (yscale (/ delta-y (if (zero? deltaval) 1 deltaval)))
+ (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale))))
+ (graph-color (vg:generate-color)))
+ ;; (print (car cf) "; maxval: " maxval " minval: " minval " deltaval: " deltaval " yscale: " yscale)
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval)))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval)))
+ (fold
+ (lambda (next prev) ;; #(time ? val) #(time ? val)
+ (if prev
+ (let* ((yval (vector-ref prev 2))
+ (yval-next (vector-ref next 2))
+ (last-tval (tfn (vector-ref prev 0)))
+ (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2))))
+ (next-yval (yfunc yval-next))
+ (curr-tval (tfn (vector-ref next 0))))
+ (if (>= curr-tval last-tval)
+ (begin
+ (vg:add-obj-to-comp
+ cmp
+ ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ (vg:make-line-obj last-tval last-yval curr-tval last-yval
+ line-color: graph-color))
+ (vg:add-obj-to-comp
+ cmp
+ ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ (vg:make-line-obj curr-tval last-yval curr-tval next-yval
+ line-color: graph-color)))
+ (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
+ next)
+ ;; for init create vector tstart,0
+ #f ;; (vector tstart minval minval)
+ dat)
+
+ ;; (for-each
+ ;; (lambda (dpt)
+ ;; (let* ((tval (vector-ref dpt 0))
+ ;; (yval (vector-ref dpt 2))
+ ;; (stval (tfn tval))
+ ;; (syval (yfunc yval)))
+ ;; (vg:add-obj-to-comp
+ ;; cmp
+ ;; (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ ;; fill-color: stdcolor))))
+ ;; dat)
+ )))) ;; for each data point in the series
+ (hash-table-keys alldat)))))
+ cfg)))
+
+;; run times tab
+;;
+(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
+ ;; each test is an object in the run component
+ ;; each run is a component
+ ;; all runs stored in runslib library
+ (let escapeloop ((escape #f))
+ (if (and (not escape)
+ tabdat)
+ (let* ((canvas-margin 10)
+ (not-done-runs (dboard:tabdat-not-done-runs tabdat))
+ (mtx (dboard:tabdat-runs-mutex tabdat))
+ (drawing (dboard:tabdat-drawing tabdat))
+ (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
+ (allruns (dboard:tabdat-allruns tabdat))
+ (num-runs (length allruns))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (compact-layout (dboard:tabdat-compact-layout tabdat))
+ (row-height (if compact-layout 2 10))
+ (graph-height 120)
+ (run-to-run-margin 25))
+ (dboard:tabdat-layout-update-ok-set! tabdat #t)
+ (if (canvas? cnv)
+ (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
+ ((originx originy) (canvas-origin cnv))
+ ((calc-y) (lambda (rownum)
+ (- (/ sizey 2)
+ (* rownum row-height))))
+ ((fixed-originx) (if (dboard:tabdat-originx tabdat)
+ (dboard:tabdat-originx tabdat)
+ (begin
+ (dboard:tabdat-originx-set! tabdat originx)
+ originx)))
+ ((fixed-originy) (if (dboard:tabdat-originy tabdat)
+ (dboard:tabdat-originy tabdat)
+ (begin
+ (dboard:tabdat-originy-set! tabdat originy)
+ originy))))
+ ;; (print "allruns: " allruns)
+ (let runloop ((rundat (car allruns))
+ (runtal (cdr allruns))
+ (run-num 1)
+ (doneruns '()))
+ (let* ((run (dboard:rundat-run rundat))
+ (rowhash (make-hash-table)) ;; store me in tabdat
+ (key-val-dat (dboard:rundat-key-vals rundat))
+ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
+ (key-vals (append key-val-dat
+ (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
+ (if x x "")))))
+ (run-key (string-intersperse key-vals "\n"))
+ (run-full-name (string-intersperse key-vals "/"))
+ (curr-run-start-row (dboard:tabdat-max-row tabdat)))
+ ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
+ (if (not (vg:lib-get-component runslib run-full-name))
+ (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible.
+ (not (dboard:rundat-hierdat rundat)))
+ (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids
+ (dboard:rundat-hierdat-set! rundat hd)
+ hd)
+ (dboard:rundat-hierdat rundat)))
+ (tests-ht (dboard:rundat-tests rundat))
+ (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
+ (testsdat (hash-table-values tests-ht))
+ (runcomp (vg:comp-new));; new component for this run
+ (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
+ ;; (row-height 4)
+ (run-start (dboard:min-max < (map db:test-get-event_time testsdat)))
+ (run-end (let ((re (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))))
+ (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero
+ (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start))
+ (run-duration (- run-end run-start))
+ (timescale (/ (- sizex (* 2 canvas-margin))
+ (if (> run-duration 0)
+ run-duration
+ (current-seconds)))) ;; a least lously guess
+ (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
+ (num-tests (length hierdat))
+ (tot-tests (length testsdat))
+ (width (* timescale run-duration))
+ (graph-lly (calc-y (/ -50 row-height)))
+ (graph-uly (- (calc-y 0) canvas-margin))
+ (sec-per-50pt (/ 50 timescale))
+ )
+ ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt)
+ ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
+ (mutex-lock! mtx)
+ (vg:add-comp-to-lib runslib run-full-name runcomp)
+ ;; Have to keep moving the instantiated box as it is anchored at the lower left
+ ;; this should have worked for x in next statement? (maptime run-start)
+ ;; add 60 to make room for the graph
+ (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
+ (mutex-unlock! mtx)
+ ;; (set! run-start-row (+ max-row 2))
+ ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
+ ;; get tests in list sorted by event time ascending
+ (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
+ (tests-tal (cdr hierdat))
+ (test-num 1))
+ (let ((iterated (> (length test-ids) 1))
+ (first-rownum #f)
+ (num-items (length test-ids)))
+ (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items
+ (tidstal (cdr test-ids))
+ (item-num 1)
+ (test-objs '()))
+ (let* ((testdat (hash-table-ref tests-ht test-id))
+ (event-time (maptime (db:test-get-event_time testdat)))
+ (test-duration (* timescale (db:test-get-run_duration testdat)))
+ (end-time (+ event-time test-duration))
+ (test-name (db:test-get-testname testdat))
+ (item-path (db:test-get-item-path testdat))
+ (state (db:test-get-state testdat))
+ (status (db:test-get-status testdat))
+ (test-fullname (conc test-name "/" item-path))
+ (name-color (gutils:get-color-for-state-status state status))
+ (new-test-objs
+ (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1)))
+ (if (dashboard:row-collision rowhash rownum event-time end-time)
+ (loop (+ rownum 1))
+ (let* ((title (if iterated (if compact-layout #f item-path) test-name))
+ (lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
+ (uly (+ lly row-height))
+ (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on
+ (obj (vg:make-rect-obj event-time lly use-end uly
+ fill-color: (vg:iup-color->number (car name-color))
+ text: title
+ font: "Helvetica -10"))
+ (bar-end (max use-end
+ (+ event-time
+ (if compact-layout
+ 1
+ (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter
+ ;; (if iterated
+ ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
+ ;; (if (not first-rownum)
+ ;; (begin
+ ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
+ ;; (set! first-rownum rownum)))
+ (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
+ (dboard:tabdat-max-row tabdat))) ;; track the max row used
+ ;; bar-end has some margin for text - accounting for text in extents not yet working.
+ (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5))
+ (vg:add-obj-to-comp runcomp obj)
+ ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (cons obj test-objs))))))
+ ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time)
+ ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
+ (if (> item-num 50)
+ (if (eq? 0 (modulo item-num 50))
+ (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
+ ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? tidstal)
+ (if iterated
+ (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
+ (llx (- (car xtents) 10))
+ (lly (- (cadr xtents) 10))
+ (ulx (+ 5 (caddr xtents)))
+ (uly (+ 10 (cadddr xtents))))
+ ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items)
+ ;; This is the box around the tests of an iterated test
+ (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
+ text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
+ line-color: (vg:rgb->number 0 0 255 a: 128)
+ font: "Helvetica -10"))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ )))))
+ ;; If it is an iterated test put box around it now.
+ (if (not (null? tests-tal))
+ (if #f ;; (> (- (current-seconds) update-start-time) 5)
+ (print "drawing runs taking too long")
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ )))))
+ ;; placeholder box
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
+ ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
+ ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
+ ;; instantiate the component
+ (let* ((extents (vg:components-get-extents drawing runcomp))
+ (new-xtnts (apply vg:grow-rect 5 5 extents))
+ (llx (list-ref new-xtnts 0))
+ (lly (list-ref new-xtnts 1))
+ (ulx (list-ref new-xtnts 2))
+ (uly (list-ref new-xtnts 3))
+ (outln (vg:make-rect-obj -5 lly ulx uly
+ text: run-full-name
+ line-color: (vg:rgb->number 255 0 255 a: 128))))
+ ; (vg:components-get-extents d1 c1)))
+ ;; this is the box around the run
+ (mutex-lock! mtx)
+ (vg:add-obj-to-comp runcomp outln)
+ (mutex-unlock! mtx)
+ ;; this is where we have enough info to place the graph
+ (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ ))
+ ;; end of the run handling loop
+ (if (not (dboard:tabdat-layout-update-ok tabdat))
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? runtal)
+ (begin
+ (dboard:rundat-data-changed-set! rundat #f)
+ (dboard:tabdat-not-done-runs-set! tabdat '())
+ (dboard:tabdat-done-runs-set! tabdat allruns))
+ (if #f ;; (> (- (current-seconds) update-start-time) 5)
+ (begin
+ (print "drawing runs taking too long.... have " (length runtal) " remaining")
+ ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
+ ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
+ (dboard:tabdat-not-done-runs-set! tabdat runtal))
+ (begin
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ ))))))))) ;; new-run-start-row
+ )))
+ (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
+
+(define (dashboard:runs-tab-updater commondat tab-num)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
+ (dbkeys (dboard:tabdat-dbkeys tabdat)))
+ (update-rundat tabdat
+ (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
+ (dboard:tabdat-numruns tabdat)
+ (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
+ (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
+ ;; (print "dbkeys: " dbkeys)
+ (let ((fres (if (dboard:tabdat-target tabdat)
+ (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
+ (map (lambda (k v)(list k v)) dbkeys ptparts))
+ (let ((res '()))
+ ;; (print "target: " (dboard:tabdat-target tabdat))
+ (for-each (lambda (key)
+ (if (not (equal? key "runname"))
+ (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
+ (if val (set! res (cons (list key val) res))))))
+ dbkeys)
+ res))))
+ ;; (debug:print 0 *default-log-port* "fres: " fres)
+ fres)))
+ (let ((uidat (dboard:commondat-uidat commondat)))
+ (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
+ ))
+ "dashboard:runs-tab-updater"))
+
+;; ((2)
+;; (dashboard:update-run-summary-tab))
+;; ((3)
+;; (dashboard:update-new-view-tab))
+;; (else
+;; (dboard:common-run-curr-updater commondat)))
+;; (set! *last-recalc-ended-time* (current-milliseconds))))))))
;;======================================================================
;; The heavy lifting starts here
;;======================================================================
@@ -1884,23 +2887,14 @@
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
- (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab
- (new-view-dat (d:data-init (make-d:data))))
+ (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
+ (let* ((commondat (dboard:commondat-make)))
+ ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(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 (d:alldat-dblocal *alldat*) 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 (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
(if (> (length d) 1)
d
(list #f #f))))
@@ -1909,42 +2903,60 @@
(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"))
+ (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
- ((args:get-arg "-guimonitor")
- (gui-monitor (d:alldat-dblocal *alldat*)))
+ ;; ((args:get-arg "-guimonitor")
+ ;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
(else
- (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*)
- (d:alldat-numruns *alldat*)
- (d:alldat-num-tests *alldat*)
- (d:alldat-dbkeys *alldat*)
- runs-sum-dat new-view-dat))
+ (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
+ ;; (dboard:tabdat-numruns tabdat)
+ ;; (dboard:tabdat-num-tests tabdat)
+ ;; (dboard:tabdat-dbkeys tabdat)
+ ;; runs-sum-dat new-view-dat))
+ ;; legacy setup of updaters for summary tab and runs tab
+ ;; summary tab
+ ;; (dboard:commondat-add-updater
+ ;; commondat
+ ;; (lambda ()
+ ;; (dashboard:summary-tab-updater commondat 0))
+ ;; tab-num: 0)
+ ;; runs tab
+ (dboard:commondat-curr-tab-num-set! commondat 0)
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:runs-tab-updater commondat 1))
+ tab-num: 1)
(iup:callback-set! *tim*
"ACTION_CB"
- (lambda (x)
- (let ((update-is-running #f))
- (mutex-lock! (d:alldat-update-mutex *alldat*))
- (set! update-is-running (d:alldat-updating *alldat*))
- (if (not update-is-running)
- (d:alldat-updating-set! *alldat* #t))
- (mutex-unlock! (d:alldat-update-mutex *alldat*))
- (if (not update-is-running)
- (begin
- (dashboard:run-update x)
- (mutex-lock! (d:alldat-update-mutex *alldat*))
- (d:alldat-updating-set! *alldat* #f)
- (mutex-unlock! (d:alldat-update-mutex *alldat*)))))
+ (lambda (time-obj)
+ (let ((update-is-running #f))
+ (mutex-lock! (dboard:commondat-update-mutex commondat))
+ (set! update-is-running (dboard:commondat-updating commondat))
+ (if (not update-is-running)
+ (dboard:commondat-updating-set! commondat #t))
+ (mutex-unlock! (dboard:commondat-update-mutex commondat))
+ (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update
+ (begin
+ (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
+ (mutex-lock! (dboard:commondat-update-mutex commondat))
+ (dboard:commondat-updating-set! commondat #f)
+ (mutex-unlock! (dboard:commondat-update-mutex commondat)))
+ ))
1))))
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
- (d:alldat-please-update-set! *alldat* #t)
- (dashboard:run-update 1)) "update buttons once"))
+ (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
+ ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now.
+ ;; (dashboard:run-update commondat)
+ ) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
- (thread-start! th1)
+ ;; (thread-start! th1)
(thread-start! th2)
(thread-join! th2))))
(main)
+
Index: datashare-testing/.sretrieve.config
==================================================================
--- datashare-testing/.sretrieve.config
+++ datashare-testing/.sretrieve.config
@@ -1,8 +1,8 @@
[settings]
base-dir /tmp/delme_data
allowed-users matt
allowed-chars [0-9a-zA-Z\-\.]+
-
+allowed-sub-paths [0-9a-zA-Z\-\.]+
[database]
location #{scheme (create-directory "/tmp/#{getenv USER}" #t)}
Index: datashare.scm
==================================================================
--- datashare.scm
+++ datashare.scm
@@ -231,11 +231,11 @@
(dbexists (file-exists? dbpath))
(handler (make-busy-timeout 136000)))
(handle-exceptions
exn
(begin
- (debug:print 2 "ERROR: problem accessing db " dbpath
+ (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath
((condition-property-accessor 'exn 'message) exn))
(exit))
(set! db (sqlite3:open-database dbpath)))
(if *db-write-access* (sqlite3:set-busy-handler! db handler))
(if (not dbexists)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -36,15 +36,15 @@
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
-(define (db:general-sqlite-error-dump exn stmt run-id params)
+(define (db:general-sqlite-error-dump exn stmt . params)
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
(print "err-status: " err-status)
- (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))))
;; convert to -inline
(define (db:first-result-default db stmt default . params)
(handle-exceptions
@@ -52,11 +52,11 @@
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
(if (eq? err-status 'done)
default
(begin
- (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
;; Get/open a database
@@ -111,11 +111,11 @@
(db (db:dbdat-get-db dbdat)))
(db:delay-if-busy dbdat)
(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))
+ (debug:print-error 0 *default-log-port* "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)))
(let ((res (apply proc db params)))
(if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
res))))
@@ -152,11 +152,11 @@
(if (eq? run-id 0) "main.db" (conc run-id ".db"))
#f)))
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Couldn't create path to " dbdir)
+ (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
(if fname
(conc dbdir "/" fname)
dbdir)))
@@ -192,11 +192,11 @@
(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
(if (not file-exists)(initproc db))
;; (release-dot-lock fname)
db)
(begin
- (debug:print 2 "WARNING: opening db in non-writable dir " fname)
+ (debug:print 2 *default-log-port* "WARNING: opening 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*)))
@@ -218,11 +218,11 @@
(handle-exceptions
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)
+ (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
(db:open-rundb dbstruct 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');"
@@ -319,11 +319,11 @@
(maindb (dbr:dbstruct-get-main dbstruct))
(refdb (dbr:dbstruct-get-refdb dbstruct))
(olddb (dbr:dbstruct-get-olddb dbstruct))
;; (runid (dbr:dbstruct-get-run-id dbstruct))
)
- (debug:print-info 4 "Syncing for run-id: " run-id)
+ (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
;; (mutex-lock! *http-mutex*)
(if (eq? run-id 0)
;; runid equal to 0 is main.db
(if maindb
(if (or (not (number? mtime))
@@ -339,11 +339,11 @@
0))
(begin
;; this can occur when using local access (i.e. not in a server)
;; need a flag to turn it off.
;;
- (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized")
+ (debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized")
0))
;; any other runid is a run
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
@@ -386,39 +386,11 @@
(let ((locdbs (dbr:dbstruct-get-locdbs dbstruct)))
(if (hash-table? locdbs)
(for-each (lambda (run-id)
(db:close-run-db dbstruct 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
- ;; (for-each
- ;; (lambda (dbdat)
- ;; (let ((db (db:dbdat-get-db dbdat)))
- ;; (if (sqlite3:database? db)
- ;; (begin
- ;; (sqlite3:interrupt! db)
- ;; (sqlite3:finalize! db #t)))))
- ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized
- ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct))))
- ;; (thread-sleep! 3)
- ;; (if (and rundb
- ;; (sqlite3:database? rundb))
- ;; (handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db")
- ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (debug:print 0 " db: " rundb)
- ;; (print-call-chain (current-error-port))
- ;; #f)
- ;; (sqlite3:interrupt! rundb)
- ;; (sqlite3:finalize! rundb #t))))
- ;; ;; (mutex-unlock! *db-sync-mutex*)
- )
+ (hash-table-keys locdbs)))))
(define (db:open-inmem-db)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
@@ -509,16 +481,16 @@
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath))
(fnamejnl (conc fname "-journal"))
(tmpname (conc fname "." (current-process-id)))
(tmpjnl (conc fnamejnl "." (current-process-id))))
- (debug:print 0 "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"")
+ (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
(system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
(system (conc "rm -f " dbpath))
(if (file-exists? fnamejnl)
(begin
- (debug:print 0 "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl)
+ (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
(system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
(system (conc "rm -f " dbdir "/" fnamejnl))))
;; attempt to recreate database
(system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
@@ -527,14 +499,14 @@
;;
(define (db:repair-db dbdat #!key (numtries 1))
(let* ((dbpath (db:dbdat-get-path dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath)))
- (debug:print-info 0 "Checking db " dbpath " for errors.")
+ (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
(cond
((not (file-write-access? dbdir))
- (debug:print 0 "WARNING: can't write to " dbdir ", can't fix " fname)
+ (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
#f)
;; handle special cases, megatest.db and monitor.db
;;
;; NOPE: apply this same approach to all db files
@@ -545,12 +517,12 @@
(begin
;; (db:move-and-recreate-db dbdat)
(if (> numtries 0)
(db:repair-db dbdat numtries: (- numtries 1))
#f)
- (debug:print 0 "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
- (debug:print 0
+ (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
+ (debug:print 0 *default-log-port*
" check the following:\n"
" 1. full directories, look in ~/ /tmp and " dbdir "\n"
" 2. write access to " dbdir "\n\n"
" if the automatic recovery failed you may be able to recover data by doing \""
(if (member fname '("megatest.db" "monitor.db"))
@@ -583,22 +555,22 @@
(mutex-lock! *db-sync-mutex*)
(handle-exceptions
exn
(begin
(mutex-unlock! *db-sync-mutex*)
- (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
+ (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
- (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (debug:print 0 " src db: " (db:dbdat-get-path fromdb))
+ (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
(for-each (lambda (dbdat)
(let ((dbpath (db:dbdat-get-path dbdat)))
- (debug:print 0 " dbpath: " dbpath)
+ (debug:print 0 *default-log-port* " dbpath: " dbpath)
(if (not (db:repair-db dbdat))
(begin
- (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.")
+ (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
(exit)))))
(cons todb slave-dbs))
0)
;; (if *server-run* ;; we are inside a server, throw a sync-failed error
@@ -609,16 +581,16 @@
;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die.
;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
;; (portlogger:open-run-close portlogger:set-port port "released")
;; (exit 1)))
(cond
- ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1)
- ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2)
+ ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1)
+ ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2)
((not (sqlite3:database? (db:dbdat-get-db fromdb)))
- (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
+ (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3)
((not (sqlite3:database? (db:dbdat-get-db todb)))
- (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
+ (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4)
(else
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
@@ -663,11 +635,11 @@
;; tack on remaining records in fromdat
(if (not (null? fromdat))
(set! fromdats (cons fromdat fromdats)))
(if (common:low-noise-print 120 "sync-records")
- (debug:print-info 4 "found " totrecords " records to sync"))
+ (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
;; read the target table
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
@@ -707,18 +679,18 @@
(sqlite3:finalize! stmth)))
(append (list todb) slave-dbs))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate.
- (if should-print (debug:print 3 "INFO: db sync, total run time " runtime " ms"))
+ (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))
(if (> count 0)
- (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count))))))
+ (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count))))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
tot-count)))
(mutex-unlock! *db-sync-mutex*)))
;; options:
@@ -775,11 +747,11 @@
(for-each
(lambda (run-id)
(db:delay-if-busy mtdb)
(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")
+ (debug:print 0 *default-log-port* "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)))))
run-ids)))
;; now ensure all newdb data are synced to megatest.db
@@ -792,11 +764,11 @@
(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)
+ (debug:print 0 *default-log-port* "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))))
;; (db:delay-if-busy frundb)
;; (db:delay-if-busy mtdb)
@@ -811,11 +783,11 @@
;; remove all these some time after september 2016 (added in v1.6031
;;
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "Column last_update already added to runs table")
+ (debug:print 0 *default-log-port* "Column last_update already added to runs table")
(db:general-sqlite-error-dump exn "alter table runs ..." run-id "none"))
(sqlite3:execute
maindb
"ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0"))
;; these schema changes don't need exception handling
@@ -844,60 +816,67 @@
(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))
;;
- ;; Feb 18, 2016: add field last_update to tests
+ ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "Column last_update already added to tests table")
- (db:general-sqlite-error-dump exn "alter table tests ..." #f "none"))
- (sqlite3:execute
- frundb
- "ALTER TABLE tests ADD COLUMN last_update INTEGER DEFAULT 0"))
- (sqlite3:execute
- frundb
- "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ (for-each
+ (lambda (table-name)
+ (handle-exceptions
+ exn
+ (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
+ (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
+ (sqlite3:execute
+ frundb
+ (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
+ (sqlite3:execute
+ frundb
+ (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
+ (sqlite3:execute
+ frundb
+ (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
FOR EACH ROW
BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'));
- END;")
- ))))
+ UPDATE " table-name " SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;"))
+ )
+ '("tests" "test_steps" "test_data"))))))
all-run-ids)
;; removed deleted runs
(let ((dbdir (tasks:get-task-db-path)))
(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)
+ (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname)
(delete-file fullname)))))
dead-runs))))
;; (db:close-all dbstruct)
;; (sqlite3:finalize! mdb)
))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
- (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
+ (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
(let* ((db (cond
((pair? idb) (db:dbdat-get-db idb))
((sqlite3:database? idb) idb)
- ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
+ ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
- (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
+ (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! dbstruct))
- (debug:print-info 11 "open-run-close-no-exception-handling END" )
+ (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
@@ -906,17 +885,17 @@
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
((busy)
(thread-sleep! sleep-time))
(else
- (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
- (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
+ (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))
(thread-sleep! sleep-time)
- (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
+ (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
(apply open-run-close-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close open-run-close-exception-handling)
@@ -1036,12 +1015,12 @@
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
CONSTRAINT metadat_constraint UNIQUE (var));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
;; Must do this *after* running patch db !! No more.
;; cannot use db:set-var since it will deadlock, hardwire the code here
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version)
- (debug:print-info 11 "db:initialize END")))))
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
+ (debug:print-info 11 *default-log-port* "db:initialize END")))))
;;======================================================================
;; R U N S P E C I F I C D B
;;======================================================================
@@ -1087,20 +1066,19 @@
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'n/a',
event_time TIMESTAMP,
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data
- ;; (id INTEGER PRIMARY KEY,
- ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')),
- ;; iterated TEXT DEFAULT '',
- ;; avg_runtime REAL DEFAULT -1,
- ;; avg_disk REAL DEFAULT -1,
- ;; tags TEXT DEFAULT '',
- ;; jobgroup TEXT DEFAULT 'default',
- ;; CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -1108,13 +1086,19 @@
tol REAL,
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- ;; Why use FULL here? This data is not that critical
- ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
test_id INTEGER,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
@@ -1324,11 +1308,11 @@
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
(begin
(set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
db
"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)
@@ -1344,11 +1328,11 @@
(set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
db
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
run-id)
- (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.")
+ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
(if (and (null? incompleted)
(null? oldlaunched)
(null? toplevels))
#f
#t)))
@@ -1383,11 +1367,11 @@
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
(begin
(set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
db
"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)
@@ -1403,11 +1387,11 @@
(set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
db
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
run-id)
- (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.")
+ (debug:print-info 18 *default-log-port* "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)
(let* (;; (min-incompleted (filter (lambda (x)
@@ -1419,11 +1403,11 @@
;; incompleted))
(min-incompleted-ids (map car incompleted)) ;; do 'em all
(all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
- (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
+ (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
(sqlite3:execute
db
(conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN ("
(string-intersperse (map conc all-ids) ",")
");")))))
@@ -1452,11 +1436,11 @@
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up dbdat)
- ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+ ;; (debug:print 0 *default-log-port* "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)+(SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
@@ -1475,15 +1459,15 @@
(db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count before clean: " tot))
+ (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count after clean: " tot))
+ (debug:print-info 0 *default-log-port* "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)
@@ -1499,11 +1483,11 @@
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-rundb dbdat)
- ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+ ;; (debug:print 0 *default-log-port* "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)
(sqlite3:prepare db stmt))
@@ -1516,15 +1500,15 @@
(db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count before clean: " tot))
+ (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count after clean: " tot))
+ (debug:print-info 0 *default-log-port* "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)
@@ -1540,11 +1524,11 @@
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-maindb dbdat)
- ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+ ;; (debug:print 0 *default-log-port* "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)
(sqlite3:prepare db stmt))
@@ -1563,15 +1547,15 @@
(db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count before clean: " tot))
+ (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 "Records count after clean: " tot))
+ (debug:print-info 0 *default-log-port* "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)
@@ -1583,35 +1567,36 @@
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
-;; Operates on megatestdb
-;;
(define (db:get-var dbstruct var)
(let* ((res #f)
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
- ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
- ;; scale by 10, average with current value.
+ res))
+
+;; This was part of db:get-var. It was used to estimate the load on
+;; the database files.
+;;
+;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; (if throttle throttle 0.01)))
;; 2))
;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; (begin
-;; (debug:print-info 4 "launch throttle factor=" *global-delta*)
+;; (debug:print-info 4 *default-log-port* "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))
(db (db:dbdat-get-db dbdat)))
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))
@@ -1642,11 +1627,12 @@
(set! *db-keys* res)
res)))
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
- (if (null? header) #f
+ (if (or (null? header) (not row))
+ #f
(let loop ((hed (car header))
(tal (cdr header))
(n 0))
(if (equal? hed field)
(vector-ref row n)
@@ -1724,12 +1710,12 @@
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(allvals (append (list runname state status user) (map cadr keyvals)))
(qryvals (append (list runname) (map cadr keyvals)))
(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")
+ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
+ (debug:print 2 *default-log-port* "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)
(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)
@@ -1737,18 +1723,18 @@
(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)
+ ;(debug:print 4 *default-log-port* "qry: " qry)
qry)
qryvals)
(db:delay-if-busy dbdat)
(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")
+ (debug:print-error 0 *default-log-port* "Called without all necessary keys")
#f))))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
@@ -1778,20 +1764,20 @@
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
""))))
- (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+ (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
)))
- (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+ (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
@@ -1804,59 +1790,14 @@
(map (lambda (dbfile)
(let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
(if res
(string->number (cadr res))
(begin
- (debug:print 2 "WARNING: Failed to process " dbfile " for run-id")
+ (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
0))))
changed))))
-;; db:get-runs-by-patt
-;; get runs by list of criteria
-;; 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
-;;
-;; 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-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 '())
-;; (key-patt "")
-;; (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
-;; (qry-str #f)
-;; (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
-;; (for-each (lambda (keyval)
-;; (let* ((key (car keyval))
-;; (patt (cadr keyval))
-;; (fulkey (conc ":" key))
-;; (wildtype (if (substring-index "%" patt) "like" "glob")))
-;; (if patt
-;; (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
-;; (begin
-;; (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
-;; (exit 6)))))
-;; keyvals)
-;; (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.
-;; (lambda (db)
-;; (sqlite3:for-each-row
-;; (lambda (a . r)
-;; (set! res (cons (list->vector (cons a r)) res)))
-;; (db:get-db dbstruct #f)
-;; qry-str
-;; runnamepatt)))
-;; (vector header res)))
-
;; Get all targets from the db
;;
(define (db:get-targets dbstruct)
(let* ((res '())
(keys (db:get-keys dbstruct))
@@ -1876,11 +1817,11 @@
(begin
(hash-table-set! seen targ #t)
(set! res (cons (apply vector targ) res))))))
db
qrystr)
- (debug:print-info 11 "db:get-targets END qrystr: " qrystr )
+ (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
(vector header res)))))
;; just get count of runs
(define (db:get-num-runs dbstruct runpatt)
(db:with-db
@@ -1887,17 +1828,17 @@
dbstruct
#f
#f
(lambda (db)
(let ((numruns 0))
- (debug:print-info 11 "db:get-num-runs START " runpatt)
+ (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
db
"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
- (debug:print-info 11 "db:get-num-runs END " runpatt)
+ (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
numruns))))
;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
;;
(define (db:get-raw-run-stats dbstruct run-id)
@@ -2021,11 +1962,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 fields) ;; test-name)
+(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
@@ -2038,18 +1979,22 @@
(fulkey (conc ":" key))
(wildtype (if (substring-index "%" patt) "like" "glob")))
(if patt
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
- (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
+ (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
- (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt
+ (if last-update
+ (conc " AND last_update >= " last-update " ")
+ " ")
+ " 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)
+ (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(db:with-db dbstruct #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)))
@@ -2068,19 +2013,19 @@
(keys (db:get-keys dbstruct))
(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)
+ (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
run-id)
- (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+ (debug:print-info 11 *default-log-port* "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)
@@ -2125,11 +2070,11 @@
"unlocked"
"locked")))) ;; semi-failsafe
(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)))))
+ (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
(let* ((dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
(db:delay-if-busy dbdat)
@@ -2222,14 +2167,17 @@
;; 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 last-update)
+;; mode:
+;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
+;;
+(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
(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)
+ (debug:print 4 *default-log-port* "WARNING: call to db:get-tests-for-run with bad run-id=" run-id)
;; (print-call-chain (current-error-port))
'())
(let* ((qryvalstr (case qryvals
((shortlist) "id,run_id,testname,item_path,state,status")
((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
@@ -2237,39 +2185,58 @@
(res '())
;; if states or statuses are null then assume match all when not-in is false
(states-qry (if (null? states)
#f
(conc " state "
- (if not-in
- " NOT IN ('"
- " IN ('")
+ (if (eq? mode 'dashboard)
+ " IN ('"
+ (if not-in
+ " NOT IN ('"
+ " IN ('"))
(string-intersperse states "','")
"')")))
(statuses-qry (if (null? statuses)
#f
(conc " status "
- (if not-in
- " NOT IN ('"
- " IN ('")
+ (if (eq? mode 'dashboard)
+ " IN ('"
+ (if not-in
+ " NOT IN ('"
+ " IN ('") )
(string-intersperse statuses "','")
"')")))
+ (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
+ (if states-qry
+ (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
+ "")))
(states-statuses-qry
(cond
((and states-qry statuses-qry)
- (conc " AND ( " states-qry " AND " statuses-qry " ) "))
+ (case mode
+ ((dashboard)
+ (if not-in
+ (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
+ " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
+ (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
+ " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
+ (else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
(states-qry
- (conc " AND " states-qry))
+ (case mode
+ ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
+ (else (conc " AND " states-qry))))
(statuses-qry
- (conc " AND " statuses-qry))
+ (case mode
+ ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
+ (else (conc " AND " statuses-qry))))
(else "")))
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT " qryvalstr
" FROM tests WHERE run_id=? "
(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
states-statuses-qry
(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (if last-update (conc " AND last_update > " last-update " ") "")
+ (if last-update (conc " AND last_update >= " last-update " ") "")
(case sort-by
((rundir) " ORDER BY length(rundir) ")
((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
((event_time) " ORDER BY event_time ")
@@ -2279,11 +2246,11 @@
(if sort-order sort-order " ")
(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)
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
(db:with-db dbstruct 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)))
@@ -2311,11 +2278,11 @@
(define (db:get-tests-for-run-state-status dbstruct 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)
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
(db:with-db dbstruct 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
@@ -2338,20 +2305,13 @@
test-id)))
res))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
-;;
-(define (db:get-tests-for-runs-mindata dbstruct 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" #f))
+ (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" 0 #f))
;; do not use.
;;
(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
;; (db:delay-if-busy)
@@ -2358,11 +2318,11 @@
(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 run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
(if run-ids
run-ids
(db:get-all-run-ids dbstruct)))
res))
@@ -2393,11 +2353,11 @@
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
-;; (debug:print 0 "QRY: " qry)
+;; (debug:print 0 *default-log-port* "QRY: " qry)
;; (db:delay-if-busy)
;;
;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
;;
(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
@@ -2621,17 +2581,17 @@
(db:with-db dbstruct run-id #t
(lambda (db)
(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
(qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
(qry (sqlite3:prepare db qrystr)))
- (debug:print 0 "INFO: migrating test records for run with id " run-id)
+ (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (rec)
- ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
+ ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
(apply sqlite3:execute qry (vector->list rec)))
testrecs)))
(sqlite3:finalize! qry)))))
;; map a test-id into the proper range
@@ -2649,17 +2609,17 @@
new-id)
;; if test-id-found then need to try again
(if test-id-found
(loop (+ new-id 1))
(begin
- (debug:print-info 0 "New test id " new-id " selected for test with id " test-id)
+ (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
;; move test ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
- (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id)
+ (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
(let ((min-test-id (* run-id 30000)))
(for-each
(lambda (testrec)
(let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
(db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
@@ -2763,14 +2723,14 @@
run-id
#f
(lambda (db)
(let* ((res '()))
(sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile)
- (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ (lambda (id test-id stepname state status event-time logfile comment)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
db
- "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-id)
(reverse res)))))
(define (db:get-steps-data dbstruct run-id test-id)
(db:with-db
@@ -2813,21 +2773,100 @@
;; Now rollup the counts to the central megatest.db
(db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id))
;; if the test is not FAIL then set status based on the fail and pass counts.
(db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id))))
-;; NOT USED!?
+;; each section is a rule except "final" which is the final result
+;;
+;; [rule-5]
+;; operator in
+;; section LogFileBody
+;; desc Output voltage
+;; status OK
+;; expected 1.9
+;; measured 1.8
+;; type +/-
+;; tolerance 0.1
+;; pass 1
+;; fail 0
+;;
+;; [final]
+;; exit-code 6
+;; exit-status SKIP
+;; message If flagged we are asking for this to exit with code 6
;;
+;; recorded in steps table:
+;; category: stepname
+;; variable: rule-N
+;; value: measured
+;; expected: expected
+;; tol: tolerance
+;; units: -
+;; comment: desc or message
+;; status: status
+;; type: type
+;;
+(define (db:logpro-dat->csv dat stepname)
+ (let ((res '()))
+ (for-each
+ (lambda (entry-name)
+ (if (equal? entry-name "final")
+ (set! res (append
+ res
+ (list
+ (list stepname
+ entry-name
+ (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value
+ 0 ;; 1 ;; Expected
+ 0 ;; 2 ;; Tolerance
+ "n/a" ;; 3 ;; Units
+ (configf:lookup dat entry-name "message") ;; 4 ;; Comment
+ (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status
+ "logpro" ;; 6 ;; Type
+ ))))
+ (let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
+ (expected (or (configf:lookup dat entry-name "expected") "n/a"))
+ (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a"))
+ (comment (or (configf:lookup dat entry-name "comment")
+ (configf:lookup dat entry-name "desc") "n/a"))
+ (status (or (configf:lookup dat entry-name "status") "n/a"))
+ (type (or (configf:lookup dat entry-name "expected") "n/a")))
+ (set! res (append
+ res
+ (list (list stepname
+ entry-name
+ value ;; 0
+ expected ;; 1
+ tolerance ;; 2
+ "n/a" ;; 3 Units
+ comment ;; 4
+ status ;; 5
+ type ;; 6
+ )))))))
+ (hash-table-keys dat))
+ res))
+
+;; $MT_MEGATEST -load-test-data << EOF
+;; foo,bar, 1.2, 1.9, >
+;; foo,rab, 1.0e9, 10e9, 1e9
+;; foo,bla, 1.2, 1.9, <
+;; foo,bal, 1.2, 1.2, < , ,Check for overload
+;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
+;; foo,abl, 1.2, 1.3, 0.1
+;; foo,bra, 1.2, pass, silly stuff
+;; faz,bar, 10, 8mA, , ,"this is a comment"
+;; EOF
+
(define (db:csv->test-data dbstruct run-id test-id csvdata)
- (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
+ (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
(let* ((dbdat (db:get-db dbstruct 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)))
- (for-each
+ (for-each
(lambda (csvrow)
(let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
(category (list-ref padded-row 0))
(variable (list-ref padded-row 1))
(value (any->number-if-possible (list-ref padded-row 2)))
@@ -2840,11 +2879,11 @@
(string-match (regexp "^n/a$") s)))
#f
s))) ;; if specified on the input then use, else calculate
(type (list-ref padded-row 8)))
;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value
+ (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
(if (and (or (not expected)(equal? expected ""))
(or (not tol) (equal? expected ""))
(or (not units) (equal? expected "")))
@@ -2851,28 +2890,28 @@
(let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
(set! expected new-expected)
(set! tol new-tol)
(set! units new-units)))
- (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value
+ (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
;; calculate status if NOT specified
(if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
(if (number? tol) ;; if tol is a number then we do the standard comparison
(let* ((max-val (+ expected tol))
(min-val (- expected tol))
(result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
+ (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
(set! status (if result "pass" "fail")))
(set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
(case (string->symbol tol) ;; tol should be >, <, >=, <=
((>) (if (> value expected) "pass" "fail"))
((<) (if (< value expected) "pass" "fail"))
((>=) (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
+ (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
(db:delay-if-busy dbdat)
(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)))
@@ -2905,11 +2944,11 @@
keynames
(string-split target "/"))
" AND "))
;; (testqry (tests:match->sqlqry testpatt))
(runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
- ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
+ ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
(sqlite3:for-each-row
(lambda (rid)
(set! row-ids (cons rid row-ids)))
runsqry)
(sqlite3:finalize! runsqry)
@@ -2975,11 +3014,11 @@
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t)))
(lambda ()(deserialize)))
(begin
- (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.")
+ (debug:print-error 0 *default-log-port* "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)
@@ -3032,12 +3071,12 @@
;; (let ((path (sdb:qry 'getstr path-id))
;; (final_logf (sdb:qry 'getstr final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
- (debug:print 2 "Found path: " path)
- (debug:print 2 "No such path: " path))) ;; )
+ (debug:print 2 *default-log-port* "Found path: " path)
+ (debug:print 2 *default-log-port* "No such path: " path))) ;; )
db
"SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';"
test-name)
res))))
@@ -3287,17 +3326,17 @@
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
+ (debug:print 4 *default-log-port* "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 hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f)))
- (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
+ (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
+ (debug:print 4 *default-log-port* "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)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
@@ -3320,11 +3359,11 @@
(db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
(dbfj (conc dbpath "-journal")))
(if (handle-exceptions
exn
(begin
- (debug:print-info 0 "WARNING: failed to test for existance of " dbfj)
+ (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj)
(thread-sleep! 1)
(db:delay-if-busy count (- count 1)))
(file-exists? dbfj))
(case count
((6)
@@ -3344,11 +3383,11 @@
(db:delay-if-busy count: 1))
((1)
(thread-sleep! 6.4)
(db:delay-if-busy count: 0))
(else
- (debug:print-info 0 "delaying db access due to high database load.")
+ (debug:print-info 0 *default-log-port* "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)
@@ -3421,24 +3460,24 @@
;; patha and pathb must be strings or this will fail
;;
;; path-b is waiting on path-a
;;
(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
- (debug:print-info 6 "ITEMMAPS: " itemmaps)
+ (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
(let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
(if itemmap
(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
- (debug:print-info 6 "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
(equal? path-a path-b-mapped))
(equal? path-b path-a))))
;; A routine to convert test/itempath using a itemmap
;; NOTE: to process only an itempath (i.e. no prepended testname)
;; just call db:multi-pattern-apply
;;
(define (db:convert-test-itempath path-in itemmap)
- (debug:print-info 6 "ITEMMAP is " itemmap)
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
(let* ((path-parts (string-split path-in "/"))
(test-name (if (null? path-parts) "" (car path-parts)))
(item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
(conc test-name "/"
(db:multi-pattern-apply item-path itemmap))))
@@ -3459,11 +3498,11 @@
(patt (car parts))
(repl (if (> (length parts) 1)(cadr parts) ""))
(newr (if (and patt repl)
(string-substitute patt repl res)
(begin
- (debug:print 0 "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+ (debug:print 0 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
res))))
(if (null? tal)
newr
(loop (car tal)(cdr tal) newr)))))))
@@ -3594,11 +3633,11 @@
tm.owner,reviewed,
diskfree,uname,rundir,
host,cpuload
FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
WHERE runname LIKE ? AND " keyqry ";")))
- (debug:print 2 "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
+ (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
"\n mainqry: " mainqry)
;; "Expected Value"
;; "Value Found"
;; "Tolerance"
(apply sqlite3:for-each-row
@@ -3618,11 +3657,11 @@
(testname (vector-ref vb (+ 2 numkeys)))
(item-path (vector-ref vb (+ 3 numkeys)))
(final-log (vector-ref vb (+ 7 numkeys)))
(run-dir (vector-ref vb (+ 18 numkeys)))
(log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
- (debug:print 4 "log: " log-fpath " exists: " (file-exists? log-fpath))
+ (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (file-exists? log-fpath))
(vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath)
(let ((newpath (conc pathmod "/"
(string-intersperse keyvals "/")
"/" runname "/" testname "/"
(if (string=? item-path "") "" (conc "/" item-path))
@@ -3636,11 +3675,11 @@
(vector->list vb))
b)))))
db
mainqry
runspatt (map cadr keypatt-alist))
- (debug:print 2 "Found " (length test-ids) " records")
+ (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
(set! results (list (cons "Runs" results)))
;; now, for each test, collect the test_data info and add a new sheet
(for-each
(lambda (test-id)
(let ((test-data (list testdata-header))
@@ -3662,35 +3701,14 @@
(ods:list->ods
tempdir
(if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
outputfile
(begin
- (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory")
+ (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
(conc (current-directory) "/" outputfile)))
results)
;; brutal clean up
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
-;; This is a list of all procs that write to the db
-;;
-;; (define *db:all-write-procs*
-;; (list
-;; db:set-var
-;; db:del-var
-;; db:register-run
-;; db:set-comment-for-run
-;; db:delete-run
-;; db:update-run-event_time
-;; db:lock/unlock-run
-;; db:delete-test-step-records
-;; db:delete-test-records
-;; db:delete-tests-for-run
-;; db:delete-old-deleted-test-records
-;; db:set-tests-state-status
-;; db:test-set-state-status-by-id
-;; db:test-set-state-status-by-run-id-testname
-;; db:testmeta-add-record
-;; db:csv->test-data
-;; ))
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -186,17 +186,19 @@
(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2))
(define-inline (tdb:step-get-state vec) (vector-ref vec 3))
(define-inline (tdb:step-get-status vec) (vector-ref vec 4))
(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5))
(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define-inline (tdb:step-get-comment vec) (vector-ref vec 7))
(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val))
(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val))
;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -11,10 +11,11 @@
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
+(import canvas-draw-iup)
(use regex defstruct)
(declare (unit dcommon))
(declare (uses megatest-version))
@@ -32,87 +33,10 @@
;;======================================================================
;; 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.
-;;
-(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))
-
-(defstruct d:data runs tests runs-matrix tests-tree run-keys
- curr-test-ids updaters path-run-ids curr-run-id runs-tree test-patts
- states statuses logs-textbox command command-tb target run-name
- runs-listbox)
-
-(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 (d:data-init dat)
- (d:data-run-keys-set! dat (make-hash-table))
- (d:data-curr-test-ids-set! dat (make-hash-table))
- (d:data-path-run-ids-set! dat (make-hash-table))
- dat)
;;======================================================================
;; D O T F I L E
;;======================================================================
@@ -140,26 +64,40 @@
;; 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))
+
+;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise
+;;
+(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
+ (let ((curr-val (iup:attribute mtrx cell-name)))
+ (if (not (equal? curr-val new-val))
+ (begin
+ (iup:attribute-set! mtrx cell-name col-name)
+ #t) ;; need a re-draw
+ prev-changed)))
+
;; 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
+;;
+;; NOTE: Used in newdashboard
;;
;; 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
+ (changed #f)
(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*)))
+ (test-ids (hash-table-values (dboard:tabdat-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)
'()))
@@ -185,12 +123,13 @@
(> 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)
+ (rownum 0)
+ (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
+;; (debug:print 0 *default-log-port* "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
@@ -203,24 +142,24 @@
(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! (dboard:tabdat-run-keys data) run-id run-path)
+ ;; modify cell - but only if changed
+ (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
(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))
+ (tree:add-node (dboard:tabdat-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))
+ (let* ((run-path (hash-table-ref (dboard:tabdat-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))))
@@ -255,50 +194,74 @@
(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*)))
+ (tb (dboard:tabdat-tests-tree data)))
(print "INFONOTE: run-path: " run-path)
- (tree:add-node (dboard:data-get-tests-tree *data*) "Runs"
+ (tree:add-node (dboard:tabdat-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)
+ (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
+
+ (set! changed (dcommon:modifiy-if-different
+ tb
+ (conc "COLOR" node-num)
+ color changed))
+
+ ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
+ )
+ (hash-table-set! (dboard:tabdat-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! changed (dcommon:modifiy-if-different
+ (dboard:tabdat-runs-matrix data)
+ (conc rownum ":" 0)
+ dispname
+ changed))
+ ;; (iup:attribute-set! (dboard:tabdat-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)))
+ ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
+ (set! changed (dcommon:modifiy-if-different
+ (dboard:tabdat-runs-matrix data)
+ (conc rownum ":" colnum)
+ (if (member state '("ARCHIVED" "COMPLETED"))
+ status
+ state)
+ changed))
+ ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
+ ;; (conc rownum ":" colnum)
+ ;; (if (member state '("ARCHIVED" "COMPLETED"))
+ ;; status
+ ;; state))
+ (set! changed (dcommon:modifiy-if-different
+ (dboard:tabdat-runs-matrix data)
+ (conc "BGCOLOR" rownum ":" colnum)
+ (car (gutils:get-color-for-state-status state status))
+ changed))
+ ;; (iup:attribute-set! (dboard:tabdat-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)))
+ (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) 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)
+ (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
+ ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
+ ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
(list run-changes all-test-changes)))
;;======================================================================
;; TESTS DATA
;;======================================================================
@@ -309,20 +272,45 @@
(if (null? tests-dat)
'()
(let loop ((hed (car tests-dat))
(tal (cdr tests-dat))
(res '()))
- (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations
- (test-name (vector-ref hed 1))
- (item-path (vector-ref hed 2))
- (state (vector-ref hed 3))
- (status (vector-ref hed 4))
+ (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations
+ (test-name (db:test-get-testname hed))
+ (item-path (db:test-get-item-path hed))
+ (state (db:test-get-state hed))
+ (status (db:test-get-status hed))
(newitem (list test-name item-path (list test-id state status))))
(if (null? tal)
(reverse (cons newitem res))
(loop (car tal)(cdr tal)(cons newitem res)))))))
-
+
+(define (dcommon:examine-xterm run-id test-id)
+ (let* ((testdat (rmt:get-test-info-by-id run-id test-id)))
+ (if (not testdat)
+ (begin
+ (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
+ (exit 1))
+ (let*
+ ((rundir (if testdat
+ (db:test-get-rundir testdat)
+ logfile))
+ (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
+ (xterm (lambda ()
+ (if (directory-exists? rundir)
+ (let* ((shell (if (get-environment-variable "SHELL")
+ (conc "-e " (get-environment-variable "SHELL"))
+ ""))
+ (command (conc "cd " rundir
+ ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
+ (print "Command =" command)
+ (common:without-vars
+ command
+ "MT_.*"))
+ (message-window (conc "Directory " rundir " not found"))))))
+ (xterm)
+ (print "Adding xterm code")))))
;;======================================================================
;; D A T A T A B L E S
;;======================================================================
@@ -363,11 +351,11 @@
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
#:numcol 1
#:numlin (length key-vals)
#:numcol-visible 1
- #:numlin-visible (length key-vals)
+ #:numlin-visible (min 10 (length key-vals))
#:scrollbar "YES")))
(iup:attribute-set! section-matrix "0:0" varcolname)
(iup:attribute-set! section-matrix "0:1" valcolname)
(iup:attribute-set! section-matrix "WIDTH1" "200")
;; fill in keys
@@ -407,75 +395,77 @@
(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))
-(define (dcommon:run-stats dbstruct)
+(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(changed #f)
- (updater (lambda ()
- (let* ((run-stats (db:get-run-stats dbstruct))
- (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell))
- (row-indices (car indices))
- (col-indices (cadr indices))
- (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices))))
- (max-col (if (null? col-indices) 1
- (apply max (map cadr col-indices))))
- (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3))
- (max-col-vis (if (> max-col 10) 10 max-col))
- (numrows 1)
- (numcols 1))
- (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
- (iup:attribute-set! stats-matrix "NUMCOL" max-col )
- (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
- (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
- (iup:attribute-set! stats-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 stats-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! stats-matrix key name)))))
- row-indices)
-
- ;; Col labels
- (for-each (lambda (ind)
- (let* ((name (car ind))
- (num (cadr ind))
- (key (conc "0:" num)))
- (if (not (equal? (iup:attribute stats-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! stats-matrix key name)))))
- col-indices)
-
- ;; Cell contents
- (for-each (lambda (entry)
- (let* ((row-name (car entry))
- (col-name (cadr entry))
- (value (caddr entry))
- (row-num (cadr (assoc row-name row-indices)))
- (col-num (cadr (assoc col-name col-indices)))
- (key (conc row-num ":" col-num)))
- (if (not (equal? (iup:attribute stats-matrix key) value))
- (begin
- (set! changed #t)
- (iup:attribute-set! stats-matrix key value)))))
- run-stats)
- (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))))
- (updater)
- (set! dashboard:update-summary-tab updater)
+ (stats-updater (lambda ()
+ (if (dashboard:database-changed? commondat tabdat)
+ (let* ((run-stats (rmt:get-run-stats))
+ (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell))
+ (row-indices (car indices))
+ (col-indices (cadr indices))
+ (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices))))
+ (max-col (if (null? col-indices) 1
+ (apply max (map cadr col-indices))))
+ (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3))
+ (max-col-vis (if (> max-col 10) 10 max-col))
+ (numrows 1)
+ (numcols 1))
+ (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
+ (iup:attribute-set! stats-matrix "NUMCOL" max-col )
+ (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
+ (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
+ (iup:attribute-set! stats-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 stats-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! stats-matrix key name)))))
+ row-indices)
+
+ ;; Col labels
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (if (not (equal? (iup:attribute stats-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! stats-matrix key name)))))
+ col-indices)
+
+ ;; Cell contents
+ (for-each (lambda (entry)
+ (let* ((row-name (car entry))
+ (col-name (cadr entry))
+ (value (caddr entry))
+ (row-num (cadr (assoc row-name row-indices)))
+ (col-num (cadr (assoc col-name col-indices)))
+ (key (conc row-num ":" col-num)))
+ (if (not (equal? (iup:attribute stats-matrix key) value))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! stats-matrix key value)))))
+ run-stats)
+ (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))))
+ (stats-updater)
+ (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num)
+ ;; (set! dashboard:update-summary-tab updater)
(iup:attribute-set! stats-matrix "WIDTHDEF" "40")
(iup:vbox
;; (iup:label "Run statistics" #:expand "HORIZONTAL")
stats-matrix)))
-(define (dcommon:servers-table)
+(define (dcommon:servers-table commondat tabdat)
(let* ((tdbdat (tasks:open-db))
(colnum 0)
(rownum 0)
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
@@ -482,84 +472,86 @@
#: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))))
- (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)
- ;; (set! colnum (+ 1 colnum)))
- ;; colnames)
- (set! rownum 1)
- (for-each
- (lambda (server)
- (set! colnum 0)
- (let* ((vals (list (vector-ref server 0) ;; Id
- (vector-ref server 9) ;; MT-Ver
- (vector-ref server 1) ;; Pid
- (vector-ref server 2) ;; Hostname
- (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
- (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
- ;; (vector-ref server 5) ;; Pubport
- ;; (vector-ref server 10) ;; Last beat
- ;; (vector-ref server 6) ;; Start time
- ;; (vector-ref server 7) ;; Priority
- ;; (vector-ref server 8) ;; State
- (vector-ref server 8) ;; State
- (vector-ref server 12) ;; RunId
- )))
- (for-each (lambda (val)
- (let* ((row-col (conc rownum ":" colnum))
- (curr-val (iup:attribute servers-matrix row-col)))
- (if (not (equal? (conc val) curr-val))
- (begin
- (iup:attribute-set! servers-matrix row-col val)
- (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
- (set! colnum (+ 1 colnum))))
- vals)
- (set! rownum (+ rownum 1)))
- (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
- servers)))))
+ (if (dashboard:monitor-changed? commondat tabdat)
+ (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat))))
+ (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)
+ ;; (set! colnum (+ 1 colnum)))
+ ;; colnames)
+ (set! rownum 1)
+ (for-each
+ (lambda (server)
+ (set! colnum 0)
+ (let* ((vals (list (vector-ref server 0) ;; Id
+ (vector-ref server 9) ;; MT-Ver
+ (vector-ref server 1) ;; Pid
+ (vector-ref server 2) ;; Hostname
+ (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
+ (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
+ ;; (vector-ref server 5) ;; Pubport
+ ;; (vector-ref server 10) ;; Last beat
+ ;; (vector-ref server 6) ;; Start time
+ ;; (vector-ref server 7) ;; Priority
+ ;; (vector-ref server 8) ;; State
+ (vector-ref server 8) ;; State
+ (vector-ref server 12) ;; RunId
+ )))
+ (for-each (lambda (val)
+ (let* ((row-col (conc rownum ":" colnum))
+ (curr-val (iup:attribute servers-matrix row-col)))
+ (if (not (equal? (conc val) curr-val))
+ (begin
+ (iup:attribute-set! servers-matrix row-col val)
+ (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
+ (set! colnum (+ 1 colnum))))
+ vals)
+ (set! rownum (+ rownum 1)))
+ (iup:attribute-set! servers-matrix "REDRAW" "ALL"))
+ servers))))))
(set! colnum 0)
(for-each (lambda (colname)
(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
(set! colnum (+ colnum 1)))
colnames)
- (set! dashboard:update-servers-table updater)
+ ;; (set! dashboard:update-servers-table updater)
+ (dboard:commondat-add-updater commondat updater)
;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
- ;; (iup:hbox
- ;; (iup:vbox
- ;; (iup:button "Start"
- ;; ;; #:size "50x"
- ;; #:expand "YES"
- ;; #:action (lambda (obj)
- ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- ;; "megatest -server - &")))
- ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- ;; (system cmd))))
- ;; (iup:button "Stop"
- ;; #:expand "YES"
- ;; ;; #:size "50x"
- ;; #:action (lambda (obj)
- ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- ;; "megatest -stop-server 0 &")))
- ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- ;; (system cmd))))
- ;; (iup:button "Restart"
- ;; #:expand "YES"
- ;; ;; #:size "50x"
- ;; #:action (lambda (obj)
- ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- ;; "megatest -stop-server 0;megatest -server - &")))
- ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- ;; (system cmd)))))
- ;; servers-matrix
- ;; )))
+ ;; (iup:hbox
+ ;; (iup:vbox
+ ;; (iup:button "Start"
+ ;; ;; #:size "50x"
+ ;; #:expand "YES"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Stop"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0 &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Restart"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0;megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd)))))
+ ;; servers-matrix
+ ;; )))
servers-matrix
))
;; The main menu
(define (dcommon:main-menu)
@@ -685,12 +677,12 @@
(lambda (waiton)
(let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f))
(waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info))))
(dcommon:draw-arrow cnv test-box-center waiton-center)))
waitons)
- ;; (debug:print 0 "test-box-info=" test-box-info)
- ;; (debug:print 0 "test-record=" test-record)
+ ;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info)
+ ;; (debug:print 0 *default-log-port* "test-record=" test-record)
))
(define (dcommon:estimate-scale sizex sizey originx originy nodes)
;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes)
(let* ((maxx 1)
@@ -874,17 +866,232 @@
(dcommon:draw-edges cnv xoffset yoffset scalef edges)
(if (not (null? tal))
;; leave a column of space to the right to list items
(loop (car tal)
(cdr tal))))))))
+
+;;======================================================================
+;; RUN CONTROLS
+;;======================================================================
+
+(define (dcommon:command-execution-control data)
+ ;; 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:tabdat-command-tb-set! data tb)
+ tb)
+ (iup:button "Execute" #:size "50x"
+ #:action (lambda (obj)
+ (let ((cmd (conc "xterm -geometry 180x20 -e \""
+ (iup:attribute (dboard:tabdat-command-tb data) "VALUE")
+ ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ (system cmd)))))))
+
+(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
+ (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 '("run" "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:tabdat-command-set! tabdat val)
+ (dashboard:update-run-command tabdat))))
+ (default-cmd (car cmds-list)))
+ (iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
+ (dboard:tabdat-command-set! tabdat default-cmd)
+ lb))))
+
+(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data)
+ (iup:frame
+ #:title "Runname"
+ (let* ((default-run-name (seconds->work-week/day (current-seconds)))
+ (tb (iup:textbox #:expand "HORIZONTAL"
+ #:action (lambda (obj val txt)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; (print "obj: " obj " val: " val " unk: " unk)
+ (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
+ (dashboard:update-run-command tabdat))
+ "command-runname-selector tb action"))
+ #:value (or default-run-name (dboard:tabdat-run-name tabdat))))
+ (lb (iup:listbox #:expand "HORIZONTAL"
+ #:dropdown "YES"
+ #:action (lambda (obj val index lbstate)
+ (debug:catch-and-dump
+ (lambda ()
+ (if (not (equal? val ""))
+ (begin
+ (iup:attribute-set! tb "VALUE" val)
+ (dboard:tabdat-run-name-set! tabdat val)
+ (dashboard:update-run-command tabdat))))
+ "command-runname-selector lb action"))))
+ (refresh-runs-list (lambda ()
+ (if (dashboard:database-changed? commondat tabdat)
+ (let* ((target (dboard:tabdat-target-string tabdat))
+ (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f 0))
+ (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))))))
+ ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list)
+ (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num)
+ (refresh-runs-list)
+ (dboard:tabdat-run-name-set! tabdat default-run-name)
+ (iup:hbox
+ tb
+ lb))))
+
+(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;; key-listboxes)
+ (iup:vbox
+ ;; Text box for test patterns
+ (iup:frame
+ #:title "Test patterns (one per line)"
+ (let ((tb (iup:textbox #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ (dboard:tabdat-test-patts-set!-use
+ tabdat
+ (dboard:lines->test-patt b))
+ (dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #:expand "YES"
+ #:size "10x30"
+ #:multiline "YES")))
+ (set! test-patterns-textbox tb)
+ tb))
+;; (iup:frame
+;; #:title "Target"
+;; ;; Target selectors
+;; (apply iup:hbox
+;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals))
+;; (key-lb (car dat))
+;; (combos (cadr dat)))
+;; 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:tabdat-states-set! tabdat all)
+ (dashboard:update-run-command tabdat))))
+ ;; 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:tabdat-statuses-set! tabdat all)
+ (dashboard:update-run-command tabdat)))))))
+
+(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)
+ (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 test-records)
+ (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 ((scalef (hash-table-ref tests-draw-state 'scalef)))
+ (hash-table-set! tests-draw-state 'scalef (+ scalef
+ (if (> step 0)
+ (* scalef 0.01)
+ (* scalef -0.01))))
+ (if the-cnv
+ (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
+ ))
+ ;; #:size "50x50"
+ #:expand "YES"
+ #:scrollbar "YES"
+ #:posx "0.5"
+ #:posy "0.5"
+ #:button-cb (lambda (obj btn pressed x y status)
+ ;; (print "obj: " obj ", pressed " pressed ", status " status)
+ ; (print "canvas-origin: " (canvas-origin the-cnv))
+ ;; (let-values (((xx yy)(canvas-origin the-cnv)))
+ ;; (canvas-transform-set! the-cnv #f)
+ ;; (print "canvas-origin: " xx " " yy " click at " x " " y))
+ (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info))
+ (selected-tests (hash-table-ref tests-draw-state 'selected-tests))
+ (scalef (hash-table-ref tests-draw-state 'scalef))
+ (sizey (hash-table-ref tests-draw-state 'sizey))
+ (xoffset (dcommon:get-xoffset tests-draw-state #f #f))
+ (yoffset (dcommon:get-yoffset tests-draw-state #f #f))
+ (new-y (- sizey y)))
+ ;; (print "xoffset=" xoffset ", yoffset=" yoffset)
+ ;; (print "\tx\ty\tllx\tlly\turx\tury")
+ (for-each (lambda (test-name)
+ (let* ((rec-coords (hash-table-ref tests-info test-name))
+ (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset))
+ (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset))
+ (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset))
+ (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset)))
+ ;; (if (eq? pressed 1)
+ ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " "))
+ (if (and (eq? pressed 1)
+ (>= x llx)
+ (>= new-y lly)
+ (<= x urx)
+ (<= new-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")))
+ (iup:attribute-set! obj "REDRAW" "ALL")
+ (hash-table-set! selected-tests test-name selected)
+ (iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
+ (dboard:tabdat-test-patts-set!-use data (dboard:lines->test-patt newpatt))
+ (dashboard:update-run-command data)
+ (if updater (updater last-xadj last-yadj)))))))
+ (hash-table-keys tests-info)))))))
+ canvas-obj)))
;;======================================================================
;; S T E P S
;;======================================================================
(define (dcommon:populate-steps teststeps steps-matrix)
- (let ((max-row 0))
+ (let ((max-row 0)
+ (max-col 7))
(if (null? teststeps)
(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")
(let loop ((hed (car teststeps))
(tal (cdr teststeps))
(rownum 1)
@@ -891,30 +1098,30 @@
(colnum 1))
(if (> rownum max-row)(set! max-row rownum))
(let ((val (vector-ref hed (- colnum 1)))
(mtrx-rc (conc rownum ":" colnum)))
(iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) ""))
- (if (< colnum 6)
+ (if (< colnum max-col)
(loop hed tal rownum (+ colnum 1))
(if (not (null? tal))
(loop (car tal)(cdr tal)(+ rownum 1) 1))))))
(if (> max-row 0)
(begin
;; we are going to speculatively clear rows until we find a row that is already cleared
(let loop ((rownum (+ max-row 1))
(colnum 0)
(deleted #f))
- ;; (debug:print-info 0 "cleaning " rownum ":" colnum)
- (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum))
- (next-col (if (eq? colnum 6) 1 (+ colnum 1)))
+ ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum)
+ (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum))
+ (next-col (if (eq? colnum max-col) 1 (+ colnum 1)))
(mtrx-rc (conc rownum ":" colnum))
(curr-val (iup:attribute steps-matrix mtrx-rc)))
- ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val)
+ ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum " currval= " curr-val)
(if (and (string? curr-val)
(not (equal? curr-val "")))
(begin
(iup:attribute-set! steps-matrix mtrx-rc "")
(loop next-row next-col #t))
- (if (eq? colnum 6) ;; not done, didn't get a full blank row
+ (if (eq? colnum max-col) ;; not done, didn't get a full blank row
(if deleted (loop next-row next-col #f)) ;; exit on this not met
(loop next-row next-col deleted)))))
(iup:attribute-set! steps-matrix "REDRAW" "ALL")))))
ADDED debugger.scm
Index: debugger.scm
==================================================================
--- /dev/null
+++ debugger.scm
@@ -0,0 +1,73 @@
+(use iup)
+
+(define *debugger-control* #f)
+(define *debugger-rownum* 0)
+(define *debugger-matrix* #f)
+(define *debugger* #f)
+
+(define (debugger)
+ (if (not *debugger*)
+ (set! *debugger*
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (show
+ (dialog
+ (let ((pause #f)
+ (mtrx (matrix
+ #:expand "YES"
+ #:numlin 30
+ #:numcol 3
+ #:numlin-visible 20
+ #:numcol-visible 2
+ #:alignment1 "ALEFT"
+ )))
+ (set! pause (button "Pause"
+ #:action (lambda (obj)
+ (set! *debugger-control* (not *debugger-control*))
+ (attribute-set! pause "BGCOLOR" (if *debugger-control*
+ "200 0 0"
+ "0 0 200")))))
+ (set! *debugger-matrix* mtrx)
+ (attribute-set! mtrx "WIDTH1" "300")
+ (vbox
+ mtrx
+ (hbox
+ pause)))))
+ (main-loop)))))))
+
+(define (debugger-start #!key (start 2))
+ (set! *debugger-rownum* start))
+
+(define (debugger-trace-var varname varval)
+ (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1")))
+ (newval (conc varval)))
+ (if (not (equal? oldval newval))
+ (begin
+ ;; (print "DEBUG: " varname " = " newval)
+ (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname)
+ (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval))
+ ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1")
+ ))
+ (set! *debugger-rownum* (+ *debugger-rownum* 1))))
+
+
+(define (debugger-pauser)
+ (debugger)
+ (attribute-set! *debugger-matrix* "REDRAW" "ALL")
+ (let loop ()
+ (if *debugger-control*
+ (begin
+ (print "PAUSED!")
+ (thread-sleep! 1)
+ (loop))
+ ;;(thread-sleep! 0.01)
+ )))
+
+;; ;; lets use the debugger eh?
+;; (debugger-start)
+;; (debugger-trace-var "can-run-more" can-run-more)
+;; (debugger-trace-var "hed" hed)
+;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met))
+;; (debugger-pauser)
+
Index: docs/Makefile
==================================================================
--- docs/Makefile
+++ docs/Makefile
@@ -1,6 +1,14 @@
-all : html/megatest.html megatest.pdf
+ASCPATH = $(shell which asciidoc)
+EXEPATH = $(shell readlink -f $(ASCPATH))
+BINPATH = $(shell dirname $(EXEPATH))
+DISPATH = $(shell dirname $(BINPATH))
+
+api.html : api.txt
+ asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 api.txt
+
+# all : html/megatest.html megatest.pdf
html/megatest.html : megatest.lyx
elyxer megatest.lyx html/megatest.html
fossil add html/*
ADDED docs/api.html
Index: docs/api.html
==================================================================
--- /dev/null
+++ docs/api.html
@@ -0,0 +1,1019 @@
+
+
+
+
+
+Megatest Web App API Specificiation
+
+
+
+
+
+
+
+
+
+
+-
+
+See runs
+
+
+-
+
+Manage jobs
+
+
+-
+
+Debug
+
+
+
+
+
+
+
Example Abstract
+
+
The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.
+
+
+
+
1. Common
+
+
This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.
+
+
+
+
All API errors are returned in the following format:
+
+
+
{ "error" : "Error message" }
+
+
+
+
1.2. Get List of Runs
+
+
+
Filter Params: target, testpatt, offset, limit
+
+
+
+
[
+ {
+ "run_id" : "1",
+ "name" : "runname1",
+ "target" : "target1",
+ "tests" :
+ [
+ "test":
+ [
+ {"id": 1, "name":test1, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS#"}
+ {"id": 2, "name":test2, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test2", "final_logf": "megatest-rollup-test2.html", "status": "PASS"}
+ {"id": 3, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target1/runname1/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+ ]
+ },
+ {
+ "run_id" : "2",
+ "name" : "runname2",
+ "target" : "target2",
+ "tests" :
+ [
+ "test:
+ [
+ {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+ {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"}
+ {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+ ]
+ }
+]
+
+
+
+
1.3. Trigger a new Run
+
+
+
+
+
+
{"target": "target_value", "runname" : "runname", "test_pattern": "optional test pattern"}
+
+
+
+
+
+
{ "error" : "Error message" }
+
+
If Success returns the results of the run
+
+
+
[
+ {
+ "run_id" : "2",
+ "name" : "runname2",
+ "target" : "target2",
+ "tests" :
+ [
+ "test:
+ [
+ {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+ {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"}
+ {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+ ]
+ }
+]
+
+
+
+
1.4. Get perticular Run
+
+
+
+
+
+
+
[
+ {
+ "run_id" : "2",
+ "name" : "runname2",
+ "target" : "target2",
+ "tests" :
+ [
+ "test":
+ [
+ {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+ {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"}
+ {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+ ]
+ }
+]
+
+
+
+
1.5. Re-execute a run
+
+
+
Request Params: {"testpatt" : "pattern"}
+
+
+
+
[
+ {
+ "run_id" : "2",
+ "name" : "runname2",
+ "target" : "target2",
+ "tests" :
+ [
+ "test":
+ [
+ {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+ {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"}
+ {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+ ]
+ }
+]
+
+
+
+
1.6. Get List of tests within a run
+
URL: <base>/runs/:id/tests
+
+
+
+
+
[
+ "tests" :
+ [
+ {"id": 4, "name":[blue]test1, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+ {"id": 5, "name":[blue]test2, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test2", "final_logf": "megatest-rollup-test2.html", "status": "FAIL"}
+ {"id": 6, "name":test3, "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test3", "final_logf": "megatest-rollup-test3.html", "status": "PASS"}
+ ]
+]
+
+
+
+
1.7. Re-execute a test within a run
+
URL: <base>/runs/:id/tests/:id
+
+
+
+
+
{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+
+
+
+
1.8. Get perticular test that belongs to a Runs
+
URL: <base>/runs/:id/tests/:id
+
+
+
+
+
{"id": "4", "name":"test1", "item_path": "", "shortdir": "/temp/foo/bar/target2/runname2/test1", "final_logf": "megatest-rollup-test1.html", "status": "PASS"}
+
+
+
+
+
+
2. Notes
+
+
+
+-
+
+blah
+
+
+-
+
+baz
+
+
+
+
+
+
+
+
+
+
ADDED docs/api.txt
Index: docs/api.txt
==================================================================
--- /dev/null
+++ docs/api.txt
@@ -0,0 +1,242 @@
+Megatest Web App API Specificiation
+===================================
+Matt Welland
+v1.0, 2013-12
+
+Megatest Web App
+
+. See runs
+. Manage jobs
+. Debug
+
+:numbered!:
+[abstract]
+Example Abstract
+----------------
+
+The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.
+
+:numbered:
+
+Common
+------
+
+This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.
+
+Endpoint: http://kiatoa.com/cgi-bin/megatest
+
+Error format response
+~~~~~~~~~~~~~~~~~~~~~
+All API errors are returned in the following format:
+
+===================
+{ "[blue]#error#" : "[red]#Error message#" }
+===================
+
+Get List of Runs
+~~~~~~~~~~~~~~~~
+
+URL: /runs
+
+Method: GET
+
+Filter Params: target, testpatt, offset, limit
+
+Response:
+
+
+==================
+[
+ {
+ "[red]#run_id#" : "1",
+ "[red]#name#" : "runname1",
+ "[red]#target#" : "target1",
+ "[red]#tests#" :
+ [
+ "[green]#test#":
+ [
+ {"[blue]#id#": 1, "[blue]#name#":test1, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS#"}
+ {"[blue]#id#": 2, "[blue]#name#":test2, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 3, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target1/runname1/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+ ]
+ },
+ {
+ "[red]#run_id#" : "2",
+ "[red]#name#" : "runname2",
+ "[red]#target#" : "target2",
+ "[red]#tests#" :
+ [
+ "[green]#test#:
+ [
+ {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"}
+ {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+ ]
+ }
+]
+==================
+
+
+Trigger a new Run
+~~~~~~~~~~~~~~~~~~
+
+URL: /runs
+
+Method: POST
+
+Request Params:
+==================
+{"[blue]#target#": "target_value", "[blue]#runname#" : "runname", "[blue]#test_pattern#": "optional test pattern"}
+==================
+
+Response:
+
+If Error
+===================
+{ "[blue]#error#" : "[red]#Error message#" }
+===================
+
+If Success returns the results of the run
+
+==================
+[
+ {
+ "[red]#run_id#" : "2",
+ "[red]#name#" : "runname2",
+ "[red]#target#" : "target2",
+ "[red]#tests#" :
+ [
+ "[green]#test#:
+ [
+ {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"}
+ {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+ ]
+ }
+]
+==================
+
+
+
+Get perticular Run
+~~~~~~~~~~~~~~~~~~~
+
+URL: /runs/:id
+
+Method: GET
+
+Filter Params: testpatt
+
+Response:
+
+==================
+[
+ {
+ "[red]#run_id#" : "2",
+ "[red]#name#" : "runname2",
+ "[red]#target#" : "target2",
+ "[red]#tests#" :
+ [
+ "[green]#test#":
+ [
+ {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"}
+ {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+ ]
+ }
+]
+==================
+
+
+Re-execute a run
+~~~~~~~~~~~~~~~~~
+
+URL: /runs/:id
+
+Method: PUT/PATCH
+
+Request Params: {"testpatt" : "pattern"}
+
+Response:
+
+==================
+[
+ {
+ "[red]#run_id#" : "2",
+ "[red]#name#" : "runname2",
+ "[red]#target#" : "target2",
+ "[red]#tests#" :
+ [
+ "[green]#test#":
+ [
+ {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"}
+ {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+ ]
+ }
+]
+==================
+
+
+
+Get List of tests within a run
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+URL: /runs/:id/tests
+
+Method: GET
+
+Response:
+==================
+[
+ "[red]#tests#" :
+ [
+ {"[blue]#id#": 4, "[blue]#name#":[blue]#test1#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+ {"[blue]#id#": 5, "[blue]#name#":[blue]#test2#, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test2", "[blue]#final_logf#": "megatest-rollup-test2.html", "[blue]#status#": "FAIL"}
+ {"[blue]#id#": 6, "[blue]#name#":test3, "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test3", "[blue]#final_logf#": "megatest-rollup-test3.html", "[blue]#status#": "PASS"}
+ ]
+]
+==================
+
+
+Re-execute a test within a run
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+URL: /runs/:id/tests/:id
+
+Method: PUT/PATCH
+
+Response:
+
+==================
+{"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+==================
+
+
+Get perticular test that belongs to a Runs
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+URL: /runs/:id/tests/:id
+
+Method: GET
+
+Response:
+
+==================
+{"[blue]#id#": "4", "[blue]#name#":"test1", "[blue]#item_path#": "", "[blue]#shortdir#": "/temp/foo/bar/target2/runname2/test1", "[blue]#final_logf#": "megatest-rollup-test1.html", "[blue]#status#": "PASS"}
+==================
+
+
+
+Notes
+-----
+
+Misc ...
+
+ 1. blah
+ 2. baz
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual