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,24 +1,24 @@
# 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 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 vg.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
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
@@ -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
@@ -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
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,11 @@
(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->quarter sec)
(case (string->number
(time->string
(seconds->local-time sec)
@@ -881,11 +991,11 @@
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;;======================================================================
-;; 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 +1240,20 @@
(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)))
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
@@ -45,11 +45,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 +98,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 +112,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 +127,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 +179,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 +195,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 +212,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 +251,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 +274,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 +305,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 +318,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 +352,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 +467,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,11 +592,11 @@
;; (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
@@ -611,10 +607,11 @@
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
@@ -30,41 +30,48 @@
(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
"))
+
+;; -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"
"-run"
"-test"
+ "-xterm"
"-debug"
"-host"
"-transport"
)
(list "-h"
@@ -72,11 +79,12 @@
"-guimonitor"
"-main"
"-v"
"-q"
"-use-local"
- )
+ "-skip-version-check"
+ )
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
@@ -86,129 +94,282 @@
(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
+(defstruct dboard:commondat
curr-tab-num
+ please-update
+ tabdats
+ update-mutex
+ updaters
+ updating
+ uidat ;; needs to move to tabdat at some time
+ hide-not-hide-tabs
+ )
+
+(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 of dboard:rundat records
+ allruns-by-id ;; hash of run-id -> dboard:rundat records
+ done-runs ;; list of runs already drawn
+ not-done-runs ;; list of runs not yet drawn
+ header ;; header for decoding the run records
+ keys ;; keys for this run (i.e. target components)
+ numruns
+ tot-runs
+ last-data-update ;; last time the data in allruns was updated
+ runs-mutex ;; use to prevent parallel access to draw objects
+
+ ;; Runs view
+ buttondat
+ item-test-names
+ run-keys
+ runs-matrix ;; used in newdashboard
+ start-run-offset ;; left-right slider value
+ start-test-offset ;; up-down slider value
+
+ ;; Canvas and drawing data
+ cnv
+ cnv-obj
+ drawing
+ draw-cache ;;
+ start-row
+ run-start-row
+ max-row
+ running-layout
+ originx
+ originy
+
+ ;; Controls used to launch runs etc.
+ command
+ command-tb
+ 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 ;; to to indicate that the user changed filters for this tab
+ hide-empty-runs
+ hide-not-hide ;; toggle for hide/not hide empty runs
+ hide-not-hide-button
+ searchpatts
+ state-ignore-hash ;; hash of STATE => #t/#f for display control
+ status-ignore-hash ;; hash of STATUS => #t/#f
+ target
+ test-patts
+
+ ;; db info to file the .db files for the area
dbdir
dbfpath
dbkeys
- dblocal
- header
- hide-empty-runs
- hide-not-hide ;; toggle for hide/not hide
- hide-not-hide-button
- 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
+ last-db-update ;; last db file timestamp
+ monitor-db-path ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ num-tests ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ path-run-ids ;; path (target / runname) => id
+ runs-tree
+
+ ;; tab data
+ last-update ;; last time this tab was updated
+ view-changed
+ xadj ;; x slider number (if using canvas)
+ yadj ;; 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
+ allruns-by-id: (make-hash-table)
+ allruns: '() ;; list of run records (vectors)
+ buttondat: (make-hash-table)
+ curr-test-ids: (make-hash-table)
+ dbdir: #f
+ filters-changed: #f
+ header: #f
+ hide-empty-runs: #f
+ hide-not-hide-button: #f
+ hide-not-hide: #t
+ item-test-names: '()
+ last-db-update: 0
+ last-data-update: 0
+ not-done-runs: '()
+ done-runs: '()
+ num-tests: 15
+ numruns: 16
+ originx: #f
+ originy: #f
+ path-run-ids: (make-hash-table)
+ run-ids: (make-hash-table)
+ run-keys: (make-hash-table)
+ running-layout: #f
+ searchpatts: (make-hash-table)
+ start-run-offset: 0
+ start-test-offset: 0
+ state-ignore-hash: (make-hash-table)
+ status-ignore-hash: (make-hash-table)
+ xadj: 0
+ yadj: 0
+ view-changed: #t
+ run-start-row: 0
+ max-row: 0
+ runs-mutex: (make-mutex)
+ )))
+ (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
+ tests ;; hash of id => testdat
+ tests-by-name ;; hash of testfullname => testdat
+ key-vals
+ last-update ;; last query to db got records from before last-update
+ )
+
+(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100))
+ (make-dboard:rundat
+ run: run
+ tests: (or tests (make-hash-table))
+ tests-by-name: (make-hash-table)
+ key-vals: key-vals
+ last-update: last-update)) ;; -100 is before time began
+
+(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))
+ (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 +377,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 +429,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 +464,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 +483,135 @@
(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* ((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))
+ (run-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
+ (if rec rec (dboard:rundat-make-init run: run key-vals: key-vals))))
+ ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
+ (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
+ (tmptests (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
+ #f #f ;; offset limit
+ (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 (dboard:rundat-tests run-dat))
+ (start-time (current-seconds)))
+ (for-each
+ (lambda (tdat)
+ (let ((test-id (db:test-get-id tdat))
+ (state (db:test-get-state tdat)))
+ (if (equal? state "DELETED")
+ (hash-table-delete! tests-ht test-id)
+ (hash-table-set! tests-ht test-id tdat))))
+ tmptests)
+ (dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
+ 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* ((allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns))
+ (start-time (current-seconds)))
+ (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 (not (null? runs))
+ (let loop ((run (car runs))
+ (tal (cdr runs))
+ (res '())
+ (maxtests 0))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (key-vals (rmt:get-key-vals run-id))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ (all-test-ids (hash-table-keys tests-ht))
+ (num-tests (length all-test-ids)))
+ ;; 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?
+ (if (not (null? all-test-ids))
+ (let* ((newmaxtests (max num-tests maxtests))
+ (last-update (- (current-seconds) 10))
+ (run-struct (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals
+ last-update: last-update))
+ (new-res (cons run-struct res))
+ (elapsed-time (- (current-seconds) start-time)))
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)
+ (if (or (null? tal)
+ (> elapsed-time 5)) ;; 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 5)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (loop (car tal)(cdr tal) new-res newmaxtests)))))))))
(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 +620,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,17 +640,17 @@
;(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)
(let* ((rown 0)
(keycol (dboard:uidat-get-keycol uidat))
(lftcol (dboard:uidat-get-lftcol uidat))
(numcols (vector-length lftcol))
@@ -523,11 +690,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,69 +716,77 @@
(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* '())
;; 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)))
+ (alltests-by-name (make-hash-table)))
+ (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))))))
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*))
+ ;; need alltestnames to enable lining up all tests from all runs
+ (set! *alltestnamelst* (collapse-rows tabdat *alltestnamelst*)) ;;; argh. please clean up this sillyness
+ (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (dboard:tabdat-start-test-offset tabdat))
+ (drop *alltestnamelst* (dboard:tabdat-start-test-offset tabdat))
'())))
- (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) ""))))
+ (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
(update-labels uidat)
(for-each
(lambda (rundat)
(if (not rundat) ;; handle padded runs
;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
- (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") (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")))
+ (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)
@@ -624,32 +799,35 @@
;; 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 +835,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*))
(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
;;======================================================================
@@ -736,13 +917,11 @@
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
- (db-target-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-targets)
- (db:get-targets (d:alldat-dblocal *alldat*))))
+ (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
@@ -764,12 +943,13 @@
#: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
@@ -796,47 +976,52 @@
(map (lambda (item)
(iup:toggle
item
#:expand "YES"
#:action (lambda (obj tstate)
- (if (eq? tstate 0)
- (hash-table-delete! alltgls item)
- (hash-table-set! alltgls item #t))
- (let ((all (hash-table-keys alltgls)))
- (proc all)))))
+ (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 +1040,483 @@
(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 (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))))
+ (car (dashboard:update-target-selector key-listboxes))))
+ (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))))
(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
+ ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) 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
+ (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
- (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
-;; )))
+ ;; Command to run, placed over the top of the canvas
+ (dcommon:command-action-selector commondat tabdat tab-num: tab-num)
+ (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))
+
+ ;;(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))
+ )))
+
+;;======================================================================
+;; 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)
+ (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"))))
+ (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 200
+ (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))))
+ (print "run-path: " run-path)
+ (if (number? run-id)
+ (begin
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-view-changed-set! tabdat #t))
+ (debug:print-error 0 *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)
+ (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)))))
+
+;;======================================================================
+;; S U M M A R Y
+;;======================================================================
+;;
+;; General info about the run(s) and megatest area
+(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"
+ (iup:vbox
+ (iup:hbox
+ (iup:label "Area Path")
+ (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
+ (iup:hbox
+ (dcommon:keys-matrix rawconfig)
+ (dcommon:general-info)
+ )))
+ (iup:frame
+ #:title "Server"
+ (dcommon:servers-table commondat tabdat)))
+ (iup:frame
+ #:title "Megatest config settings"
+ (iup:hbox
+ (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
+ (iup:vbox
+ (dcommon:section-matrix rawconfig "server" "Varname" "Value")
+ ;; (iup:frame
+ ;; #:title "Disks Areas"
+ (dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
+ (iup:frame
+ #:title "Run statistics"
+ (dcommon:run-stats commondat tabdat tab-num: tab-num)))))
+
+;;======================================================================
+;; 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 dashboard:update-run-summary-tab #f)
+;; (define dashboard:update-new-view-tab #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 (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)
+ (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (last-update 0) ;; fix me
+ (tests-dat (dboard:get-tests-dat tabdat run-id last-update))
+ (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)
+ (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))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (let loop ((pass-num 0)
+ (changed #f))
+ ;; (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))
+ (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)
+ (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")
+ (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 (and (eq? pass-num 0) changed))
+ (set! changed (dcommon:modify-if-different run-matrix key name changed)))))
+ 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)
+ (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 (let ((res (gutils:get-color-for-state-status state status)))
+ (if (and (list? res)
+ (> (length res) 1))
+ res
+ #f)))) ;; (list "n/a" "256 256 256"))))
+ (print "value: " value " row-name: " (cadr value) " row-color: " (car value))
+ (print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices))
+ (if value
+ (let* ((row-name (cadr value))
+ (row-color (car value))
+ (row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices)))
+ (col-num (dashboard:safe-cadr-assoc col-name col-indices))
+ (key (conc row-num ":" col-num)))
+ (if (and row-num col-num)
+ (begin
+ (hash-table-set! cell-lookup key test-id)
+ (set! changed (dcommon:modify-if-different run-matrix key row-name changed))
+ (set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed)))
+ (print "ERROR: row-num=" row-num " col-num=" col-num))))
+ ))
+ tests-mindat)
+
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass due to contents changing
+
+ ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
+
+ (for-each (lambda (ind)
+ (print "ind: " ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (set! changed (dcommon:modify-if-different run-matrix key name changed))
+ (if changed (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-debug-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")))))
+
+;; This is the Run Summary tab
+;;
+(define (dashboard:one-run commondat tabdat #!key (tab-num #f))
+ (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 tabdat (cdr run-path))))
+ (if (number? run-id)
+ (begin
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ ;; (dashboard:update-run-summary-tab)
+ )
+ (debug:print-error 0 *default-log-port* "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 " (dboard:tabdat-curr-run-id tabdat) "," test-id "&")))
+ (system cmd)))))
+ (one-run-updater (lambda ()
+ (print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
+ (if (dashboard:database-changed? commondat tabdat)
+ (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)))))
+ (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num)
+ (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))
+ (dboard:tabdat-cnv-set! tabdat c))
+ (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 (* -500 (- xadj 0.5)))
+ (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5)))
+ ))))
+ "iup:canvas action dashboard:one-run")))
+ #: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))))))
+ "dashboard:one-run wheel-cb"))
+ )))
+ cnv-obj))))
;;======================================================================
;; 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 +1528,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,491 +1540,578 @@
;; (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)))))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
-(define (tree-path->run-id data path)
+(define (tree-path->run-id tabdat path)
(if (not (null? path))
- (hash-table-ref/default (d:data-path-run-ids data) path #f)
+ (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
-(define dashboard:update-run-summary-tab #f)
+;; (define dashboard:update-run-summary-tab #f)
+;; (define dashboard:update-new-view-tab #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 (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)
+ (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (last-update 0) ;; fix me
+ (tests-dat (dboard:get-tests-dat tabdat run-id last-update))
+ (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)
+ (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))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (let loop ((pass-num 0)
+ (changed #f))
+ ;; (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))
+ (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)
+ (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")
+ (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 (and (eq? pass-num 0) changed))
+ (set! changed (dcommon:modify-if-different run-matrix key name changed)))))
+ 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)
+ (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 (let ((res (gutils:get-color-for-state-status state status)))
+ (if (and (list? res)
+ (> (length res) 1))
+ res
+ #f)))) ;; (list "n/a" "256 256 256"))))
+ (print "value: " value " row-name: " (cadr value) " row-color: " (car value))
+ (print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices))
+ (if value
+ (let* ((row-name (cadr value))
+ (row-color (car value))
+ (row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices)))
+ (col-num (dashboard:safe-cadr-assoc col-name col-indices))
+ (key (conc row-num ":" col-num)))
+ (if (and row-num col-num)
+ (begin
+ (hash-table-set! cell-lookup key test-id)
+ (set! changed (dcommon:modify-if-different run-matrix key row-name changed))
+ (set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed)))
+ (print "ERROR: row-num=" row-num " col-num=" col-num))))
+ ))
+ tests-mindat)
+
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass due to contents changing
+
+ ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
+
+ (for-each (lambda (ind)
+ (print "ind: " ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (set! changed (dcommon:modify-if-different run-matrix key name changed))
+ (if changed (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-debug-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")))))
;; This is the Run Summary tab
;;
-(define (dashboard:one-run db data)
+(define (dashboard:one-run commondat tabdat #!key (tab-num #f))
(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))))
+ (run-id (tree-path->run-id tabdat (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)
- )))
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ ;; (dashboard:update-run-summary-tab)
+ )
+ (debug:print-error 0 *default-log-port* "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 "&")))
+ (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)
+ (one-run-updater (lambda ()
+ (print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!")
+ (if (dashboard:database-changed? commondat tabdat)
+ (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)))))
+ (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num)
+ (dboard:tabdat-runs-tree-set! tabdat tb)
(iup:split
tb
run-matrix)))
;; This is the New View tab
;;
-(define (dashboard:new-view db data)
+(define (dashboard:new-view db commondat tabdat #!key (tab-num #f))
(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))))
+ (run-id (tree-path->run-id tabdat (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)
- )))
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ ;; (dashboard:update-new-view-tab)
+ )
+ (debug:print-error 0 *default-log-port* "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 "&")))
+ (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)
+ (new-view-updater (lambda ()
+ (if (dashboard:database-changed? commondat tabdat)
+ (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (last-update 0) ;; fix me
+ (tests-dat (dboard:get-tests-dat tabdat run-id last-update))
+ (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)
+ (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))
+ (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)
+ (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")))))))
+ (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num)
+ (dboard:tabdat-runs-tree-set! tabdat tb)
(iup:split
tb
run-matrix)))
;;======================================================================
;; 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
+(define (dboard:make-controls commondat tabdat)
(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:vbox
+ (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
+ #: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)))
+ (iup:button "Refresh" #:action (lambda (obj)
+ (mark-for-update tabdat)))
+ (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"))))
+ )
+ (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 "HORIZONTAL"
+ #: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 "YES"
+ #: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 "YES"
+ #: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 "YES"
+ #: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 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))))
+ (iup:toggle (conc status " ")
+ #: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 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))))
+ (iup:toggle (conc state " ")
+ #: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 (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)
+ (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 (d:alldat-allruns *alldat*)))
+ #:max (* 10 (length (dboard:tabdat-allruns tabdat)))
#: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))))
- )
- )
+ ;(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)
+ (common:run-a-command
+ (conc "megatest -run -target " target
+ " -runname " runname
+ " -testpatt " testpatt
+ " -preclean -clean-cache")
+ )))))
+ (iup:menu-item
+ "Test"
+ (iup:menu
+ (iup:menu-item
+ (conc "Rerun " test-name)
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -run -target " target
+ " -runname " runname
+ " -testpatt " test-name
+ " -preclean -clean-cache"))))
+ (iup:menu-item
+ "Start xterm"
+ #:action
+ (lambda (obj)
+ (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 '())
+ (lftlst '())
+ (hdrlst '())
+ (bdylst '())
+ (result '())
+ (i 0))
+ ;; 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
@@ -1666,12 +2118,12 @@
(map (lambda (x)
(let ((res (iup:hbox #:expand "HORIZONTAL"
(iup:label x #:size "x15" #:fontsize "10" #:expand "HORIZONTAL")
(iup:textbox #:size "x15" #:fontsize "10" #:value "%" #:expand "HORIZONTAL"
#:action (lambda (obj unk val)
- (mark-for-update)
- (update-search x val))))))
+ (mark-for-update runs-dat)
+ (update-search commondat runs-dat x val))))))
(set! i (+ i 1))
res))
keynames)))))
(let loop ((testnum 0)
(res '()))
@@ -1681,13 +2133,13 @@
(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)
+ (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"
@@ -1702,12 +2154,12 @@
; #:impress img2
#:size "x15"
#:expand "HORIZONTAL"
#:fontsize "10"
#:action (lambda (obj)
- (mark-for-update)
- (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
+ (mark-for-update tabdat)
+ (toggle-hide testnum uidat))))) ;; (iup:attribute obj "TITLE"))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;;
(let loop ((runnum 0)
(keynum 0)
@@ -1734,23 +2186,51 @@
(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 "60x15"
+ #:expand "HORIZONTAL"
+ #:fontsize "10"
+ #: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
@@ -1762,121 +2242,509 @@
(list
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
- controls))
- (data (d:data-init (make-d:data)))
+ ;; controls
+ ))
+ ;; (data (dboard:tabdat-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)
+ (debug:catch-and-dump
+ (lambda ()
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:commondat-curr-tab-num-set! commondat curr))
+ "tabchangepos"))
+ (dashboard:summary commondat stats-dat tab-num: 0)
runs-view
- (dashboard:one-run db runs-sum-dat)
- (dashboard:new-view db new-view-dat)
- (dashboard:run-controls)
+ (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)
)))
;; (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")
(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)
+ (if (or (args:get-arg "-rows")
+ (get-environment-variable "DASHBOARDROWS" ))
+ (begin
+ (dboard:tabdat-num-tests-set! tabdat (string->number
+ (or (args:get-arg "-rows")
+ (get-environment-variable "DASHBOARDROWS"))))
+ (update-rundat tabdat "%" (dboard:tabdat-numruns tabdat) "%/%" '()))
+ (dboard:tabdat-num-tests-set! tabdat (min (max (update-rundat tabdat "%" (dboard:tabdat-numruns tabdat) "%/%" '()) 8) 20))))
+
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
-;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
-;;
-(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*)))
+ (> (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*))))
+ (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* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (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))
+ ;; 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")
+ (update-rundat tabdat
+ "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
+ 100 ;; (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 ((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)))))
+
+;; 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
+ (if tabdat
+ (let* ((canvas-margin 10)
+ (row-height 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
+ (layout-start (current-milliseconds))
+ (allruns (dboard:tabdat-allruns tabdat))
+ (num-runs (length allruns))
+ (cnv (dboard:tabdat-cnv tabdat)))
+ (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 (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
+ (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 (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))
+ (timeoffset (- (+ 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))
+ )
+ (print "Testing. (maptime run-start=" run-start "): " (maptime run-start) " (maptime run-end=" run-end "): " (maptime run-end) " run-duration: " run-duration)
+ ;; (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)
+ (vg:instantiate drawing "runslib" run-full-name run-full-name fixed-originx (calc-y curr-run-start-row)) ;; 0) ;; (calc-y (dboard:tabdat-max-row tabdat)))
+ (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 item-path test-name))
+ (lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
+ (uly (+ lly row-height))
+ (use-end (if (< (- end-time event-time) 3)(+ event-time 3) 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 (+ 5 (max use-end (+ 3 event-time (* (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) 5))
+ (lly (- (cadr xtents) 10))
+ (ulx (+ 5 (caddr xtents)))
+ (uly (+ 0 (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
+ (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)))))
+ ;; 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")
+ (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
+ ;; 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 llx 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)
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ ))
+ ;; end of the run handling loop
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? runtal)
+ (begin
+ (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
+ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))) ;; new-run-start-row
+ )
+ (print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
+ (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)))
+ (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 ((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))
+ (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 +2752,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 +2768,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)
+ ;; this next call is working and doing what it should
+ (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)
+ ;; (dashboard:run-update commondat)
+ ) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(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)))
@@ -1724,12 +1709,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 +1722,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 +1763,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 +1789,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 +1816,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 +1827,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)
@@ -2038,18 +1978,18 @@
(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 "
(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 +2008,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 +2065,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 +2162,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 +2180,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 +2241,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 +2273,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 +2300,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 +2313,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 +2348,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 +2576,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 +2604,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 +2718,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 +2768,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 +2874,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 +2885,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 +2939,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 +3009,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 +3066,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 +3321,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 +3354,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 +3378,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 +3455,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 +3493,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 +3628,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 +3652,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 +3670,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 +3696,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:modify-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 new-val)
+ #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:modify-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:modify-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:modify-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:modify-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:modify-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
;;======================================================================
@@ -318,11 +281,36 @@
(status (vector-ref hed 4))
(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,226 @@
(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)
+ ;; (print "obj: " obj " val: " val " unk: " unk)
+ (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
+ (dashboard:update-run-command tabdat))
+ #:value (or default-run-name (dboard:tabdat-run-name tabdat))))
+ (lb (iup:listbox #:expand "HORIZONTAL"
+ #:dropdown "YES"
+ #:action (lambda (obj val index lbstate)
+ (if (not (equal? val ""))
+ (begin
+ (iup:attribute-set! tb "VALUE" val)
+ (dboard:tabdat-run-name-set! tabdat val)
+ (dashboard:update-run-command tabdat))))))
+ (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))
+ (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: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:tabdat-test-patts-set!-use
+ tabdat
+ (dboard:lines->test-patt b))
+ (dashboard:update-run-command tabdat))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #: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: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 +1092,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)
+
ADDED docs/waiton-analysis.gnumeric
Index: docs/waiton-analysis.gnumeric
==================================================================
--- /dev/null
+++ docs/waiton-analysis.gnumeric
cannot compute difference between binary files
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -206,6 +206,6 @@
(begin
(print "# Changed vars")
(map (lambda (dat)(print (car dat) " " (cdr dat)))
(hash-table->alist changed)))))
(else
- (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]")))))
+ (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -41,14 +41,14 @@
(let loop ((count 5))
(if (file-exists? test-run-dir)
(push-directory test-run-dir)
(if (> count 0)
(begin
- (debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
+ (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
(sleep 3)
(loop (- count 1))))))
- (debug:print-info 0 "Running in directory " test-run-dir)
+ (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
(if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
;; if ezsteps was defined then we are sure to have at least one step but check anyway
(if (not (> (length ezstepslst) 0))
(message-window "ERROR: You can only re-run steps defined via ezsteps")
(begin
@@ -72,19 +72,19 @@
(if (equal? stepname start-step-name)
(set! runflag #t) ;; and continue
(if (not (null? tal))
(loop (car tal)(cdr tal) stepname #f))))
- (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
+ (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
" stepparms: " stepparms " stepcmd: " stepcmd)
(if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
- (debug:print 4 "script: " script)
+ (debug:print 4 *default-log-port* "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
@@ -115,11 +115,11 @@
(next-status (cond
((eq? overall-status 'pass) this-step-status)
((eq? overall-status 'warn)
(if (eq? this-step-status 'fail) 'fail 'warn))
(else 'fail))))
- (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
+ (debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
@@ -135,11 +135,11 @@
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
(loop (car tal) (cdr tal) stepname runflag))))
- (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))
+ (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
;; Once done with step/steps update the test record
;;
(let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
(testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
@@ -157,11 +157,11 @@
((eq? rollup-status 1) "FAIL")
((eq? rollup-status 2)
;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
(else "FAIL")))) ;; (db:test-get-status testinfo)))
- (debug:print-info 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
+ (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
(tests:test-set-status! test-id
new-state
new-status
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ fs-transport.scm
@@ -37,8 +37,8 @@
;;
(define (fs:process-queue-item packet)
(if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called
(set! *megatest-db* (open-db)))
- (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
+ (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
(db:process-queue-item *megatest-db* packet))
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -48,11 +48,11 @@
;;
(define *db:process-queue-mutex* (make-mutex))
(define (http-transport:run hostn run-id server-id)
- (debug:print 2 "Attempting to start the server ...")
+ (debug:print 2 *default-log-port* "Attempting to start the server ...")
(let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
@@ -59,11 +59,11 @@
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (configf:lookup *configdat* "setup" "linktree")))
;; (set! db *inmemdb*)
- (debug:print-info 0 "portlogger recommended port: " start-port)
+ (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
(handle-exception (lambda (exn chain)
@@ -112,22 +112,22 @@
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
(let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
(tdbdat (tasks:open-db)))
- (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
+ (debug:print-info 0 *default-log-port* "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 64000)
(begin
- (debug:print 0 "WARNING: attempt to start server failed. Trying again ...")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "exn=" (condition->list exn))
(portlogger:open-run-close portlogger:set-failed portnum)
- (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
+ (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
;; get_next_port goes here
(http-transport:try-start-server run-id
ipaddrstr
@@ -140,11 +140,11 @@
(set! *server-info* (list ipaddrstr portnum))
(tasks:server-set-interface-port
(db:delay-if-busy tdbdat)
server-id
ipaddrstr portnum)
- (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum)
+ (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
(start-server port: portnum bind-address: (if (equal? config-hostname "-")
@@ -151,11 +151,11 @@
ipaddrstr
config-hostname))
(start-server port: portnum))
;; (portlogger:open-run-close portlogger:set-port portnum "released")
(tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server")
- (debug:print 1 "INFO: server has been stopped"))))
+ (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -183,11 +183,11 @@
(mutex-lock! *http-mutex*)
(set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
;; Use this opportunity to slow things down iff there are too many requests in flight
(if (> *http-requests-in-progress* 5)
(begin
- (debug:print-info 0 "Whoa there buddy, ease up...")
+ (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
(thread-sleep! 1)))
(mutex-unlock! *http-mutex*))
(define (http-transport:dec-requests-count proc)
(mutex-lock! *http-mutex*)
@@ -201,11 +201,11 @@
(if (> *http-requests-in-progress* 0)
(if (> etime (current-seconds))
(begin
(thread-sleep! 0.05)
(loop etime))
- (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
+ (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
(close-all-connections!)))
(set! *http-connections-next-cleanup* (+ (current-seconds) 10))
(mutex-unlock! *http-mutex*))
(define (http-transport:inc-requests-and-prep-to-close-all-connections)
@@ -216,11 +216,11 @@
;;
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3))
(let* ((fullurl (if (vector? serverdat)
(http-transport:server-dat-get-api-req serverdat)
(begin
- (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
+ (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1))))
(res #f)
(success #t)
(sparams (db:obj->string params transport: 'http)))
;; (condition-case
@@ -230,20 +230,20 @@
;; (begin
;; (mutex-unlock! *http-mutex*)
;; (thread-sleep! 1)
;; (handle-exceptions
;; exn
-;; (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead")
+;; (debug:print 0 *default-log-port* "WARNING: closing connections failed. Server at " fullurl " almost certainly dead")
;; (close-all-connections!))
-;; (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
+;; (debug:print 0 *default-log-port* "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
;; (http-transport:client-api-send-receive run-id serverdat cmd sparams numretries: (- numretries 1)))
;; (begin
;; (mutex-unlock! *http-mutex*)
;; (tasks:kill-server-run-id run-id)
;; #f))
;; (begin
- (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
+ (debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
;; set up the http-client here
(max-retry-attempts 1)
;; consider all requests indempotent
(retry-request? (lambda (request)
#f))
@@ -259,12 +259,12 @@
(db:string->obj
(handle-exceptions
exn
(begin
(set! success #f)
- (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(hash-table-delete! *runremote* run-id)
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
@@ -289,19 +289,19 @@
(th2 (make-thread time-out "time out")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
- (debug:print-info 11 "got res=" res)
+ (debug:print-info 11 *default-log-port* "got res=" res)
(if (vector? res)
(if (vector-ref res 0)
res
(begin ;; note: this code also called in nmsg-transport - consider consolidating it
- (debug:print 0 "ERROR: error occured at server, info=" (vector-ref res 2))
- (debug:print 0 " client call chain:")
+ (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref res 2))
+ (debug:print 0 *default-log-port* " client call chain:")
(print-call-chain (current-error-port))
- (debug:print 0 " server call chain:")
+ (debug:print 0 *default-log-port* " server call chain:")
(pp (vector-ref res 1) (current-error-port))
(signal (vector-ref result 0))))
(signal (make-composite-condition
(make-property-condition
'timeout
@@ -339,11 +339,11 @@
(define (http-transport:server-dat-update-last-access vec)
(if (vector? vec)
(vector-set! vec 5 (current-seconds))
(begin
(print-call-chain (current-error-port))
- (debug:print 0 "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!"))))
+ (debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!"))))
;;
;; connect
;;
(define (http-transport:client-connect iface port)
@@ -358,32 +358,32 @@
;;
(define (http-transport:keep-running server-id run-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
- (debug:print-info 0 "Starting the sync-back, keep alive thread in server for run-id=" run-id)
+ (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server for run-id=" run-id)
(let* ((tdbdat (tasks:open-db))
(server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
(let ((sdat #f))
(thread-sleep! 0.01)
- (debug:print-info 0 "Waiting for server alive signature")
+ (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
(mutex-lock! *heartbeat-mutex*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if (and sdat
(not changed)
(> (- (current-seconds) start-time) 2))
sdat
(begin
- (debug:print-info 0 "Still waiting, last-sdat=" last-sdat)
+ (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
(sleep 4)
(if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
(begin
- (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id)
+ (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server " server-id " for run " run-id)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
(exit))
(loop start-time
(equal? sdat last-sdat)
sdat)))))))
@@ -408,16 +408,16 @@
(http-transport:server-shutdown server-id port))
(else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop
(thread-sleep! 5)
(loop count server-state (+ bad-sync-count 1)))))
((exn)
- (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
+ (debug:print-error 0 *default-log-port* "error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed")
(exit)))
(set! sync-time (- (current-milliseconds) start-time))
(set! rem-time (quotient (- 4000 sync-time) 1000))
- (debug:print 4 "SYNC: time= " sync-time ", rem-time=" rem-time)
+ (debug:print 4 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time)
(if (and (<= rem-time 4)
(> rem-time 0))
(thread-sleep! rem-time)
(thread-sleep! 4))) ;; fallback for if the math is changed ...
@@ -449,20 +449,20 @@
(mutex-unlock! *heartbeat-mutex*)
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
- (debug:print-info 0 "interface changed, refreshing iface and port info")
+ (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))))
;; Transfer *last-db-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
- ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
+ ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout)
;;
;; no_traffic, no running tests, if server 0, no running servers
;;
;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out)
;;
@@ -469,17 +469,17 @@
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))
(adjusted-timeout (if (> hrs-since-start 1)
(- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour
server-timeout)))
(if (common:low-noise-print 120 "server timeout")
- (debug:print-info 0 "Adjusted server timeout: " adjusted-timeout))
+ (debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
(if (and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(begin
(if (common:low-noise-print 120 "server continuing")
- (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
+ (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
;;
;; Consider implementing some smarts here to re-insert the record or kill self is
;; the db indicates so
;;
;; (if (tasks:server-am-i-the-server? tdb run-id)
@@ -488,36 +488,36 @@
(loop 0 server-state bad-sync-count))
(http-transport:server-shutdown server-id port))))))
(define (http-transport:server-shutdown server-id port)
(let ((tdbdat (tasks:open-db)))
- (debug:print-info 0 "Starting to shutdown the server.")
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t))
;;
;; start_shutdown
;;
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
(portlogger:open-run-close portlogger:set-port port "released")
(thread-sleep! 5)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Number of cached writes " *number-of-writes*)
- (debug:print-info 0 "Average cached write time "
+ (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+ (debug:print-info 0 *default-log-port* "Average cached write time "
(if (eq? *number-of-writes* 0)
"n/a (no writes)"
(/ *writes-total-delay*
*number-of-writes*))
" ms")
- (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*)
- (debug:print-info 0 "Average non-cached time "
+ (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+ (debug:print-info 0 *default-log-port* "Average non-cached time "
(if (eq? *number-non-write-queries* 0)
"n/a (no queries)"
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms")
- (debug:print-info 0 "Server shutdown complete. Exiting")
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
(exit)))
;; all routes though here end in exit ...
;;
@@ -533,11 +533,11 @@
(begin
(current-error-port *alt-log-file*)
(current-output-port *alt-log-file*)))))
(if (server:check-if-running run-id)
(begin
- (debug:print 0 "INFO: Server for run-id " run-id " already running")
+ (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
@@ -545,23 +545,23 @@
(thread-sleep! 2)
(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+ (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
))
(let* ((th2 (make-thread (lambda ()
- (debug:print-info 0 "Server run thread started")
+ (debug:print-info 0 *default-log-port* "Server run thread started")
(http-transport:run
(if (args:get-arg "-server")
(args:get-arg "-server")
"-")
run-id
server-id)) "Server run"))
(th3 (make-thread (lambda ()
- (debug:print-info 0 "Server monitor thread started")
+ (debug:print-info 0 *default-log-port* "Server monitor thread started")
(http-transport:keep-running server-id run-id))
"Keep running")))
(thread-start! th2)
(thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
(thread-start! th3)
@@ -583,18 +583,18 @@
(define (http-transport:server-signal-handler signum)
(signal-mask! signum)
(handle-exceptions
exn
- (debug:print " ... exiting ...")
+ (debug:print 0 *default-log-port* " ... exiting ...")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1))
"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! 3) ;; give the flush three seconds 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))))
ADDED inteldate.scm
Index: inteldate.scm
==================================================================
--- /dev/null
+++ inteldate.scm
@@ -0,0 +1,180 @@
+(use srfi-19)
+(use test)
+(use format)
+(use regex)
+(declare (unit inteldate))
+;; utility procedures to convert among
+;; different ways to express date (inteldate, seconds since epoch, isodate)
+;;
+;; samples:
+;; isodate -> "2016-01-01"
+;; inteldate -> "16ww01.5"
+;; seconds -> 1451631600
+
+;; procedures provided:
+;; ====================
+;; seconds->isodate
+;; seconds->inteldate
+;;
+;; isodate->seconds
+;; isodate->inteldate
+;;
+;; inteldate->seconds
+;; inteldate->isodate
+
+;; srfi-19 used extensively; this doc is better tha the eggref:
+;; http://srfi.schemers.org/srfi-19/srfi-19.html
+
+;; Author: brandon.j.barclay@intel.com 16ww18.6
+
+(define (date->seconds date)
+ (inexact->exact
+ (string->number
+ (date->string date "~s"))))
+
+(define (seconds->isodate seconds)
+ (let* ((date (seconds->date seconds))
+ (result (date->string date "~Y-~m-~d")))
+ result))
+
+(define (isodate->seconds isodate)
+ "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
+ (let* ((numlist (map string->number (string-split isodate "-")))
+ (raw-year (car numlist))
+ (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
+ (month (list-ref numlist 1))
+ (day (list-ref numlist 2))
+ (date (make-date 0 0 0 0 day month year))
+ (seconds (date->seconds date)))
+
+ seconds))
+
+;; adapted from perl Intel::WorkWeek perl module
+;; intel year consists of numbered weeks starting from week 1
+;; week 1 is the week containing jan 1 of the year
+;; days of week are numbered starting from 0 on sunday
+;; intel year does not match calendar year in workweek 1
+;; before jan1.
+(define (seconds->inteldate-values seconds)
+ (define (date-difference->seconds d1 d2)
+ (- (date->seconds d1) (date->seconds d2)))
+
+ (let* ((thisdate (seconds->date seconds))
+ (thisdow (string->number (date->string thisdate "~w")))
+
+ (year (date-year thisdate))
+ ;; intel workweek 1 begins on sunday of week containing jan1
+ (jan1 (make-date 0 0 0 0 1 1 year))
+ (jan1dow (date-week-day jan1))
+ (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
+
+ (ww01_delta_seconds (date-difference->seconds thisdate ww01))
+ (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
+
+ ;; we could be in ww1 of next year
+ (this-saturday (seconds->date
+ (+ seconds
+ (* 60 60 24 (- 6 thisdow)))))
+ (this-week-ends-next-year?
+ (> (date-year this-saturday) year))
+ (intelyear
+ (if this-week-ends-next-year?
+ (add1 year)
+ year))
+ (intelweek
+ (if this-week-ends-next-year?
+ 1
+ wwnum_initial)))
+ (values intelyear intelweek thisdow)))
+
+(define (seconds->inteldate seconds)
+ (define (string-leftpad in width pad-char)
+ (let* ((unpadded-str (->string in))
+ (padlen_temp (- width (string-length unpadded-str)))
+ (padlen (if (< padlen_temp 0) 0 padlen_temp))
+ (padding
+ (fold conc ""
+ (map (lambda (x) (->string pad-char)) (iota padlen)))))
+ (conc padding unpadded-str)))
+ (define (zeropad num width)
+ (string-leftpad num width #:0))
+
+ (let-values (((intelyear intelweek day-of-week-num)
+ (seconds->inteldate-values seconds)))
+ (let ((intelyear-str
+ (zeropad
+ (->string
+ (if (> intelyear 1999)
+ (- intelyear 2000) intelyear))
+ 2))
+ (intelweek-str
+ (zeropad (->string intelweek) 2))
+ (dow-str (->string day-of-week-num)))
+ (conc intelyear-str "ww" intelweek-str "." dow-str))))
+
+(define (isodate->inteldate isodate)
+ (seconds->inteldate
+ (isodate->seconds isodate)))
+
+(define (inteldate->seconds inteldate)
+ (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate)))
+ (if
+ (not match)
+ #f
+ (let* (
+ (intelyear-raw (string->number (list-ref match 1)))
+ (intelyear (if (< intelyear-raw 100)
+ (+ intelyear-raw 2000)
+ intelyear-raw))
+ (intelww (string->number (list-ref match 2)))
+ (dayofweek (string->number (list-ref match 3)))
+
+ (day-of-seconds (* 60 60 24 ))
+ (week-of-seconds (* day-of-seconds 7))
+
+
+ ;; get seconds at ww1.0
+ (new-years-date (make-date 0 0 0 0 1 1 intelyear))
+ (new-years-seconds
+ (date->seconds new-years-date))
+ (new-years-dayofweek (date-week-day new-years-date))
+ (ww1.0_seconds (- new-years-seconds
+ (* day-of-seconds
+ new-years-dayofweek)))
+ (workweek-adjustment (* week-of-seconds (sub1 intelww)))
+ (weekday-adjustment (* dayofweek day-of-seconds))
+
+ (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
+ result))))
+
+(define (inteldate->isodate inteldate)
+ (seconds->isodate (inteldate->seconds inteldate)))
+
+(define (inteldate-tests)
+ (test-group
+ "date conversion tests"
+ (let ((test-table
+ '(("16ww01.5" . "2016-01-01")
+ ("16ww18.5" . "2016-04-29")
+ ("1999ww33.5" . "1999-08-13")
+ ("16ww18.4" . "2016-04-28")
+ ("16ww18.3" . "2016-04-27")
+ ("13ww01.0" . "2012-12-30")
+ ("13ww52.6" . "2013-12-28")
+ ("16ww53.3" . "2016-12-28"))))
+ (for-each
+ (lambda (test-pair)
+ (let ((inteldate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->inteldate "isodate ") => "inteldate)
+ inteldate
+ (isodate->inteldate isodate))
+
+ (test
+ (conc "(inteldate->isodate "inteldate ") => "isodate)
+ isodate
+ (inteldate->isodate inteldate))))
+ test-table))))
+
+;(inteldate-tests)
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -45,26 +45,26 @@
(define (item-assoc->item-list itemsdat)
(if (and itemsdat (not (null? itemsdat)))
(let ((itemlst (filter (lambda (x)
(list? x))
(map (lambda (x)
- (debug:print 6 "item-assoc->item-list x: " x)
+ (debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
(if (< (length x) 2)
(begin
- (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " "))
+ (debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
(list (car x)'()))
(let* ((name (car x))
(items (cadr x))
(ilist (list name (if (string? items)
(string-split items)
'()))))
(if (null? ilist)
- (debug:print 0 "ERROR: No items specified for " name))
+ (debug:print-error 0 *default-log-port* "No items specified for " name))
ilist)))
itemsdat))))
(let ((debuglevel 5))
- (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ")
+ (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
(if (debug:debug-mode 5)
(begin
(pp itemsdat)
(print " => ")
(pp itemlst))))
@@ -93,11 +93,11 @@
(rowdat (cadr row)))
(set! item (append item
(list
(if (< indx (length rowdat))
(let ((new (list rowname (list-ref rowdat indx))))
- ;; (debug:print 0 "New: " new)
+ ;; (debug:print 0 *default-log-port* "New: " new)
(set! elflag #t)
new
) ;; i.e. had at least on legit value to use
(list rowname "-")))))))
newlst)
@@ -121,11 +121,11 @@
(define (items:get-items-from-config tconfig)
(let* ((have-items (hash-table-ref/default tconfig "items" #f))
(have-itable (hash-table-ref/default tconfig "itemstable" #f))
(items (hash-table-ref/default tconfig "items" '()))
(itemstable (hash-table-ref/default tconfig "itemstable" '())))
- (debug:print 5 "items: " items " itemstable: " itemstable)
+ (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
(set! items (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
items))
@@ -132,16 +132,16 @@
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
- (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined"))
- (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined"))
+ (if (and have-items (null? items)) (debug:print-error 0 *default-log-port* "[items] section in testconfig but no entries defined"))
+ (if (and have-itable (null? itemstable))(debug:print-error 0 *default-log-port* "[itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))(not (null? itemstable)))
(append (item-assoc->item-list items)
(item-table->item-list itemstable))
'(()))))
;; (pp (item-assoc->item-list itemdat))
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -43,13 +43,13 @@
(for-each (lambda (key val)
(setenv key val)
(if ht (hash-table-set! ht (conc ":" key) val)))
keys
vals)
- (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys))
+ (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys))
vals)
- (debug:print 4 "ERROR: keys:target-set-args called with no target.")))
+ (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target.")))
;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list
;; keyval list ( (key1 val1) (key2 val2) ...)
(define (keys:target->keyval keys target)
(let* ((targlist (string-split target "/"))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -11,12 +11,12 @@
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
-(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables)
-(use defstruct)
+(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
+(use defstruct pathname-expand)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
@@ -55,10 +55,29 @@
(common:read-encoded-string enccmd)
'())))
;; 0 1 2 3
(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))
+
+;; return (conc status ": " comment) from the final section so that
+;; the comment can be set in the step record in launch.scm
+;;
+(define (launch:load-logpro-dat run-id test-id stepname)
+ (let ((cname (conc stepname ".dat")))
+ (if (file-exists? cname)
+ (let* ((dat (read-config cname #f #f))
+ (csvr (db:logpro-dat->csv dat stepname))
+ (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ",")))
+ (fmt-csv (map list->csv-record csvr))))
+ (status (configf:lookup dat "final" "exit-status"))
+ (msg (configf:lookup dat "final" "message")))
+ (rmt:csv->test-data run-id test-id csvt)
+ (cond
+ ((equal? status "PASS") "PASS") ;; skip the message part if status is pass
+ (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
+ (else #f)))
+ #f)))
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(stepinfo (cadr ezstep))
(stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
@@ -65,10 +84,11 @@
(stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
(stepcmd (list-ref stepparts 3))
(script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
(logpro-file (conc stepname ".logpro"))
(html-file (conc stepname ".html"))
+ (dat-file (conc stepname ".dat"))
(tconfig-logpro (configf:lookup testconfig "logpro" stepname))
(logpro-used (file-exists? logpro-file)))
(if (and tconfig-logpro
(not logpro-used)) ;; no logpro file found but have a defn in the testconfig
@@ -79,11 +99,11 @@
";;")
(print tconfig-logpro)))
(set! logpro-used #t)))
;; NB// can safely assume we are in test-area directory
- (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
+ (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
" stepparms: " stepparms " stepcmd: " stepcmd)
;; ;; first source the previous environment
;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
@@ -91,11 +111,11 @@
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
- (debug:print 4 "script: " script)
+ (debug:print 4 *default-log-port* "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch the actual process
(call-with-environment-variables
(list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
(lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
@@ -112,11 +132,11 @@
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
)))))
- (debug:print-info 0 "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
+ (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
;; now run logpro if needed
(if logpro-used
(let ((pid (process-run (conc "logpro " logpro-file " " (conc stepname ".html") " < " stepname ".log"))))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
@@ -128,17 +148,22 @@
(mutex-unlock! m)
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1)))))
- (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
+ (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
(let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
- (logfna (if logpro-used (conc stepname ".html") "")))
- (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
- (if logpro-used
- (rmt:test-set-log! run-id test-id (conc stepname ".html")))
+ (logfna (if logpro-used (conc stepname ".html") ""))
+ (comment #f))
+ (if logpro-used
+ (let ((datfile (conc stepname ".dat")))
+ ;; load the .dat file into the test_data table if it exists
+ (if (file-exists? datfile)
+ (set! comment (launch:load-logpro-dat run-id test-id stepname)))
+ (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
;; set the test final status
(let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
(this-step-status (cond
((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings
((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check
@@ -160,11 +185,11 @@
(next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
(cond
((null? tal) ;; more to run?
"COMPLETED")
(else "RUNNING"))))
- (debug:print 4 "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
+ (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
(case next-status
((warn)
(launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
@@ -202,13 +227,169 @@
(launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
(tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
)))
logpro-used))
+(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)
+ ;; (let-values
+ ;; (((pid exit-status exit-code)
+ ;; (run-n-wait fullrunscript)))
+ ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
+ ;; Since we should have a clean slate at this time there is no need to do
+ ;; any of the other stuff that tests:test-set-status! does. Let's just
+ ;; force RUNNING/n/a
+
+ ;; (thread-sleep! 0.3)
+ (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING")
+ ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
+
+ ;; if there is a runscript do it first
+ (if fullrunscript
+ (let ((pid (process-run fullrunscript)))
+ (rmt:test-set-top-process-pid run-id test-id pid)
+ (let loop ((i 0))
+ (let-values
+ (((pid-val exit-status exit-code) (process-wait pid #t)))
+ (mutex-lock! m)
+ (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
+ (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
+ (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
+ (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status
+ (mutex-unlock! m)
+ (if (eq? pid-val 0)
+ (begin
+ (thread-sleep! 2)
+ (loop (+ i 1)))
+ )))))
+ ;; then, if runscript ran ok (or did not get called)
+ ;; do all the ezsteps (if any)
+ (if ezsteps
+ (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
+ ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
+ ;; ezstep names need a full re-eval here.
+ (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
+ (ezstepslst (if (hash-table? testconfig)
+ (hash-table-ref/default testconfig "ezsteps" '())
+ #f)))
+ (if testconfig
+ (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
+ (begin
+ (launch:setup)
+ (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n "
+ (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))
+ ;; after all that, still no testconfig? Time to abort
+ (if (not testconfig)
+ (begin
+ (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
+ (exit 1)))
+ (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
+ ;; if ezsteps was defined then we are sure to have at least one step but check anyway
+ (if (not (> (length ezstepslst) 0))
+ (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
+ (let loop ((ezstep (car ezstepslst))
+ (tal (cdr ezstepslst))
+ (prevstep #f))
+ ;; check exit-info (vector-ref exit-info 1)
+ (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
+ (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
+ (stepname (car ezstep)))
+ ;; if logpro-used read in the stepname.dat file
+ (if (and logpro-used (file-exists? (conc stepname ".dat")))
+ (launch:load-logpro-dat run-id test-id stepname))
+ (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
+ (if (not (null? tal))
+ (loop (car tal) (cdr tal) stepname))
+ (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
+ (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))
+
+(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
+ (let* ((start-seconds (current-seconds))
+ (calc-minutes (lambda ()
+ (inexact->exact
+ (round
+ (-
+ (current-seconds)
+ start-seconds)))))
+ (kill-tries 0))
+ ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
+ ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
+ (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
+ (let loop ((minutes (calc-minutes))
+ (cpu-load (get-cpu-load))
+ (disk-free (get-df (current-directory))))
+ (let ((new-cpu-load (let* ((load (get-cpu-load))
+ (delta (abs (- load cpu-load))))
+ (if (> delta 0.6) ;; don't bother updating with small changes
+ load
+ #f)))
+ (new-disk-free (let* ((df (get-df (current-directory)))
+ (delta (abs (- df disk-free))))
+ (if (> delta 200) ;; ignore changes under 200 Meg
+ df
+ #f))))
+ (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
+ (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds))
+ (time-exceeded (> run-seconds runtlim)))
+ (if time-exceeded
+ (begin
+ (debug:print-info 0 *default-log-port* "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
+ #t)
+ #f)))))
+ (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
+ (if kill-job?
+ (begin
+ (mutex-lock! m)
+ ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
+ ;; section and the runit section? Or add a loop that tries three times with a 1/4 second
+ ;; between tries?
+ (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0))
+ (pid2 (rmt:test-get-top-process-pid run-id test-id))
+ (pids (delete-duplicates (filter number? (list pid1 pid2)))))
+ (if (not (null? pids))
+ (begin
+ (for-each
+ (lambda (pid)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 0 *default-log-port* "Unable to kill process with pid " pid ", possibly already killed.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (debug:print 0 *default-log-port* "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")")
+ (debug:print-info 0 *default-log-port* "Signal mask=" (signal-mask))
+ ;; (if (process:alive? pid)
+ ;; (begin
+ (map (lambda (pid-num)
+ (process-signal pid-num signal/term))
+ (process:get-sub-pids pid))
+ (thread-sleep! 5)
+ ;; (if (process:process-alive? pid)
+ (map (lambda (pid-num)
+ (handle-exceptions
+ exn
+ #f
+ (process-signal pid-num signal/kill)))
+ (process:get-sub-pids pid))))
+ ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive"))))
+ pids)
+ (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f))
+ (begin
+ (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2)
+ (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f)
+ )))
+ (mutex-unlock! m)
+ ;; no point in sticking around. Exit now.
+ (exit)))
+ (if (hash-table-ref/default misc-flags 'keep-going #f)
+ (begin
+ (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
+ (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
+ (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free)))))))
+ (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
+
(define (launch:execute encoded-cmd)
-
- (let* ((cmdinfo (common:read-encoded-string encoded-cmd))
+ (let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg (tests:get-all)))
(setenv "MT_CMDINFO" encoded-cmd)
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
(let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area
@@ -241,74 +422,71 @@
(let ((fulln (conc testpath "/" runscript)))
(if (and (file-exists? fulln)
(file-execute-access? fulln))
fulln
runscript))))) ;; assume it is on the path
- ;; (rollup-status 0)
- )
+ ) ;; (rollup-status 0)
;; NFS might not have propagated the directory meta data to the run host - give it time if needed
(let loop ((count 0))
(if (or (file-exists? top-path)
(> count 10))
(change-directory top-path)
(begin
- (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found")
+ (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found")
(thread-sleep! 10)
(loop (+ count 1)))))
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
- (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
+ (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 1)
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 2)
- (debug:print 0 "Done")
+ (debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2)))))
(set-signal-handler! signal/int sighand)
(set-signal-handler! signal/term sighand)
- (set-signal-handler! signal/stop sighand))
+ ) ;; (set-signal-handler! signal/stop sighand)
- ;; (set-signal-handler! signal/int (lambda ()
-
;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART,
;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY*
;;
(let* ((test-info (rmt:get-test-info-by-id run-id test-id))
(test-host (db:test-get-host test-info))
(test-pid (db:test-get-process_id test-info)))
(cond
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
- (debug:print 0 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
+ (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
- (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
+ (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
(tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
- (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed")
+ (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
- (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
+ (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
(set! keys (rmt:get-keys))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
(if (not (launch:setup force: #t))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
@@ -325,47 +503,47 @@
(let ((var (car varval))
(val (cadr varval)))
(if (and (string? var)(string? val))
(begin
(setenv var (config:eval-string-in-environment val))) ;; val)
- (debug:print 0 "ERROR: bad variable spec, " var "=" val))))
+ (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val))))
(configf:get-section rconfig section)))
(list "default" target)))
;; NFS might not have propagated the directory meta data to the run host - give it time if needed
(let loop ((count 0))
(if (or (file-exists? work-area)
(> count 10))
(change-directory work-area)
(begin
- (debug:print 0 "INFO: Not starting job yet - directory " work-area " not found")
+ (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
(thread-sleep! 10)
(loop (+ count 1)))))
;; (change-directory work-area)
(set! keyvals (keys:target->keyval keys target))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
(if (string? set-vars)
(let ((varpairs (string-split set-vars ",")))
- (debug:print 4 "varpairs: " varpairs)
+ (debug:print 4 *default-log-port* "varpairs: " varpairs)
(map (lambda (varpair)
(let ((varval (string-split varpair "=")))
(if (eq? (length varval) 2)
(let ((var (car varval))
(val (cadr varval)))
- (debug:print 1 "Adding pre-var/val " var " = " val " to the environment")
+ (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment")
(setenv var val)))))
varpairs)))
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cadr varval)))
(if val
(setenv var val)
(begin
- (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting")
+ (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting")
(exit)))))
(list
(list "MT_TEST_RUN_DIR" work-area)
(list "MT_TEST_NAME" test-name)
(list "MT_ITEM_INFO" (conc itemdat))
@@ -390,11 +568,11 @@
;; open-run-close not needed for test-set-meta-info
;; (tests:set-full-meta-info #f test-id run-id 0 work-area)
;; (tests:set-full-meta-info test-id run-id 0 work-area)
(tests:set-full-meta-info #f test-id run-id 0 work-area 10)
- (thread-sleep! 0.3) ;; NFS slowness has caused grief here
+ ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript
(file-exists? fullrunscript)
@@ -403,176 +581,31 @@
;; We are about to actually kick off the test
;; so this is a good place to remove the records for
;; any previous runs
;; (db:test-remove-steps db run-id testname itemdat)
-
+ ;;
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
(job-thread #f)
- (keep-going #t)
+ ;; (keep-going #t)
+ (misc-flags (let ((ht (make-hash-table)))
+ (hash-table-set! ht 'keep-going #t)
+ ht))
(runit (lambda ()
- ;; (let-values
- ;; (((pid exit-status exit-code)
- ;; (run-n-wait fullrunscript)))
- ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
- ;; Since we should have a clean slate at this time there is no need to do
- ;; any of the other stuff that tests:test-set-status! does. Let's just
- ;; force RUNNING/n/a
-
-
- ;; (thread-sleep! 0.3)
- (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING")
- ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here
-
- ;; if there is a runscript do it first
- (if fullrunscript
- (let ((pid (process-run fullrunscript)))
- (rmt:test-set-top-process-pid run-id test-id pid)
- (let loop ((i 0))
- (let-values
- (((pid-val exit-status exit-code) (process-wait pid #t)))
- (mutex-lock! m)
- (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
- (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
- (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code)
- (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status
- (mutex-unlock! m)
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (loop (+ i 1)))
- )))))
- ;; then, if runscript ran ok (or did not get called)
- ;; do all the ezsteps (if any)
- (if ezsteps
- (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
- ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
- ;; ezstep names need a full re-eval here.
- (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
- (ezstepslst (if (hash-table? testconfig)
- (hash-table-ref/default testconfig "ezsteps" '())
- #f)))
- (if testconfig
- (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
- (begin
- (launch:setup)
- (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n "
- (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))
- ;; after all that, still no testconfig? Time to abort
- (if (not testconfig)
- (begin
- (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
- (exit 1)))
- (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
- ;; if ezsteps was defined then we are sure to have at least one step but check anyway
- (if (not (> (length ezstepslst) 0))
- (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
- (let loop ((ezstep (car ezstepslst))
- (tal (cdr ezstepslst))
- (prevstep #f))
- ;; check exit-info (vector-ref exit-info 1)
- (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
- (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)))
- (if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
- (if (not (null? tal))
- (loop (car tal) (cdr tal) stepname))
- (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping")))
- (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
+ (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m)))
(monitorjob (lambda ()
- (let* ((start-seconds (current-seconds))
- (calc-minutes (lambda ()
- (inexact->exact
- (round
- (-
- (current-seconds)
- start-seconds)))))
- (kill-tries 0))
- ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
- ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
- (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
- (let loop ((minutes (calc-minutes))
- (cpu-load (get-cpu-load))
- (disk-free (get-df (current-directory))))
- (let ((new-cpu-load (let* ((load (get-cpu-load))
- (delta (abs (- load cpu-load))))
- (if (> delta 0.6) ;; don't bother updating with small changes
- load
- #f)))
- (new-disk-free (let* ((df (get-df (current-directory)))
- (delta (abs (- df disk-free))))
- (if (> delta 200) ;; ignore changes under 200 Meg
- df
- #f))))
- (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
- (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds))
- (time-exceeded (> run-seconds runtlim)))
- (if time-exceeded
- (begin
- (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
- #t)
- #f)))))
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
- (if kill-job?
- (begin
- (mutex-lock! m)
- ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
- ;; section and the runit section? Or add a loop that tries three times with a 1/4 second
- ;; between tries?
- (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0))
- (pid2 (rmt:test-get-top-process-pid run-id test-id))
- (pids (delete-duplicates (filter number? (list pid1 pid2)))))
- (if (not (null? pids))
- (begin
- (for-each
- (lambda (pid)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
- (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")")
- (debug:print-info 0 "Signal mask=" (signal-mask))
- ;; (if (process:alive? pid)
- ;; (begin
- (map (lambda (pid-num)
- (process-signal pid-num signal/term))
- (process:get-sub-pids pid))
- (thread-sleep! 5)
- ;; (if (process:process-alive? pid)
- (map (lambda (pid-num)
- (handle-exceptions
- exn
- #f
- (process-signal pid-num signal/kill)))
- (process:get-sub-pids pid))))
- ;; (debug:print-info 0 "not killing process " pid " as it is not alive"))))
- pids)
- (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f))
- (begin
- (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2)
- (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f)
- )))
- (mutex-unlock! m)
- ;; no point in sticking around. Exit now.
- (exit)))
- (if keep-going
- (begin
- (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
- (if keep-going ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
- (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free)))))))
- (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
+ (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job")))
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
- (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
- (set! keep-going #f)
+ (debug:print-info 0 *default-log-port* "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...")
+ (hash-table-set! misc-flags 'keep-going #f)
(thread-join! th1)
(thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
(mutex-lock! m)
(let* ((item-path (item-list->path itemdat))
;; only state and status needed - use lazy routine
@@ -595,11 +628,11 @@
((eq? (launch:einf-rollup-status exit-info) 3) "CHECK")
((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED")
((eq? (launch:einf-rollup-status exit-info) 5) "ABORT")
((eq? (launch:einf-rollup-status exit-info) 6) "SKIP")
(else "FAIL")))) ;; (db:test-get-status testinfo)))
- (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info))
+ (debug:print-info 1 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info))
(tests:test-set-status! run-id
test-id
new-state
new-status
(args:get-arg "-m") #f)
@@ -610,11 +643,11 @@
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f))
(tests:summarize-test run-id test-id) ;; don't force - just update if no
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
(mutex-unlock! m)
- (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
+ (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4)))))))
(define (launch:cache-config)
@@ -630,13 +663,13 @@
(args:get-arg ":runname")
(getenv "MT_RUNNAME")))
(fulldir (conc linktree "/"
target "/"
runname)))
- (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
(if (and linktree (file-exists? linktree)) ;; can't proceed without linktree
(begin
+ (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
(if (not (file-exists? fulldir))
(create-directory fulldir #t)) ;; need to protect with exception handler
(if (and target
runname
(file-exists? fulldir))
@@ -643,84 +676,16 @@
(let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
(targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
(rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
(if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
(begin
- (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
+ (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile)
(configf:write-alist *configdat* tmpfile)
(system (conc "ln -sf " tmpfile " " targfile))))
- )))))))
-
-;; set up the very basics needed for doing anything here.
-;;
-(define (launch:setup-old #!key (force #f))
- ;; would set values for KEYS in the environment here for better support of env-override but
- ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to
- ;; pass on that idea for now
- ;; special case
- (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call
- (begin
- (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
- (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
- (get-environment-variable "MT_TARGET") "/"
- (get-environment-variable "MT_RUNNAME") "/"
- ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (if (file-exists? alistconfig)
- (list (configf:read-alist alistconfig)
- (get-environment-variable "MT_RUN_AREA_HOME"))
- #f))
- #f) ;; no config cached - give up
- (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))
- (if runname (setenv "MT_RUNNAME" runname))
- (find-and-read-config
- (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
- environ-patt: "env-override"
- given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
- pathenvvar: "MT_RUN_AREA_HOME"))))
- (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f))
- (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f))
- (let* ((tmptransport (configf:lookup *configdat* "server" "transport"))
- (transport (if tmptransport (string->symbol tmptransport) 'http)))
- (if (member transport '(http rpc nmsg))
- (set! *transport-type* transport)
- (begin
- (debug:print 0 "ERROR: Unrecognised transport " transport)
- (exit))))
- (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
- (if linktree
- (if (not (file-exists? linktree))
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- (create-directory linktree #t))))
- (begin
- (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
- (exit 1)))
- (if linktree
- (let ((dbdir (conc linktree "/.db")))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))
- (if (not (directory-exists? dbdir))(create-directory dbdir)))
- (setenv "MT_LINKTREE" linktree))
- (begin
- (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
- (exit 1)))
- (if (and *toppath*
- (directory-exists? *toppath*))
- (setenv "MT_RUN_AREA_HOME" *toppath*)
- (begin
- (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
- (exit 1)))
- )))
- *toppath*)
+ )))
+ (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs.")))))
+
;; gather available information, if legit read configs in this order:
;;
;; if have cache;
;; read it a return it
@@ -768,19 +733,28 @@
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
toppath
(car first-pass))))
- (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
- sections: sections))))
+ (read-config ;; (conc toppath "/runconfigs.config")
+ (conc (if (string? toppath)
+ toppath
+ (get-environment-variable "MT_RUN_AREA_HOME"))
+ "/runconfigs.config")
+ *runconfigdat* #t
+ sections: sections))))
(set! *runconfigdat* first-rundat)
(if first-pass ;;
(begin
(set! *configdat* (car first-pass))
(set! *configinfo* first-pass)
(set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
(set! toppath *toppath*)
+ (if (not *toppath*)
+ (begin
+ (debug:print-error 0 *default-log-port* "you are not in a megatest area!")
+ (exit 1)))
(setenv "MT_RUN_AREA_HOME" *toppath*)
;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
(let* ((keys (rmt:get-keys))
(key-vals (keys:target->keyval keys target))
(linktree (or (getenv "MT_LINKTREE")
@@ -818,34 +792,42 @@
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
(set! *configstatus* 'partial))
(begin
- (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.")
+ (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
(exit 2))))))
;; additional house keeping
(let* ((linktree (or (getenv "MT_LINKTREE")
(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
(if linktree
- (if (not (file-exists? linktree))
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (exit 1))
- (create-directory linktree #t))))
- (begin
- (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
- ;; (exit 1)
+ (begin
+ (if (not (file-exists? linktree))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ (create-directory linktree #t))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (let ((tlink (conc *toppath* "/lt")))
+ (if (not (file-exists? tlink))
+ (create-symbolic-link linktree tlink)))))
+ (begin
+ (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
)))
(if (and *toppath*
(directory-exists? *toppath*))
(setenv "MT_RUN_AREA_HOME" *toppath*)
(begin
- (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
+ (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
*toppath*))
(define launch:setup launch:setup-new)
(define (get-best-disk confdat testconfig)
@@ -857,11 +839,11 @@
(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb
(if res
(cdr res)
(begin
(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
- (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
+ (debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
(exit 1)))))))
;; Desired directory structure:
;;
;; <linkdir> - <target> - <testname> -.
@@ -908,22 +890,22 @@
;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
;; rundir shortdir
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)
- (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
+ (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
- (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
+ (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree)
(create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
;; create the directory for the tests dir links, this is needed no matter what...
(if (and (not (directory-exists? lnkbase))
(not (file-exists? lnkbase)))
(handle-exceptions
exn
(begin
- (debug:print "ERROR: Problem creating linktree base at " lnkbase)
+ (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase)
(print-error-message exn (current-error-port)))
(create-directory lnkbase #t)))
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
@@ -934,32 +916,32 @@
;; if the test is iterated it is necessary to create the parent path
;; to the iteration. use pathname-directory to trim the path by one
;; level
(if (not not-iterated) ;; i.e. iterated
(let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path))))
- (debug:print-info 2 "Creating iterated parent " iterated-parent)
+ (debug:print-info 2 *default-log-port* "Creating iterated parent " iterated-parent)
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print-error 0 *default-log-port* " Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-directory iterated-parent #t))))
(if (symbolic-link? lnkpath)
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(delete-file lnkpath)))
(if (not (or (file-exists? lnkpath)
(symbolic-link? lnkpath)))
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-symbolic-link toptest-path lnkpath)))
;; NB - This was not working right - some top tests are not getting the path set!!!
;;
@@ -976,18 +958,19 @@
#f)))
(hash-table-set! *toptest-paths* testname curr-test-path)
;; NB// Was this for the test or for the parent in an iterated test?
(rmt:general-call 'test-set-rundir-shortdir run-id lnkpath
(if (file-exists? lnkpath)
- (resolve-pathname lnkpath)
+ ;; (resolve-pathname lnkpath)
+ (common:nice-path lnkpath)
lnkpath)
testname "")
;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
(if (or (not curr-test-path)
(not (directory-exists? toptest-path)))
(begin
- (debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
+ (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath)
(handle-exceptions
exn
#f ;; don't care to catch and deal with errors here for now.
(create-directory toptest-path #t))
(hash-table-set! *toptest-paths* testname toptest-path)))))
@@ -994,27 +977,27 @@
;; The toptest path has been created, the link to the test in the linktree has
;; been created. Now, if this is an iterated test the real test dir must be created
(if (not not-iterated) ;; this is an iterated test
(begin ;; (let ((lnktarget (conc lnkpath "/" item-path)))
- (debug:print 2 "Setting up sub test run area")
- (debug:print 2 " - creating run area in " test-path)
+ (debug:print 2 *default-log-port* "Setting up sub test run area")
+ (debug:print 2 *default-log-port* " - creating run area in " test-path)
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-directory test-path #t))
- (debug:print 2
+ (debug:print 2 *default-log-port*
" - creating link from: " test-path "\n"
" to: " lnktarget)
;; If there is already a symlink delete it and recreate it.
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit))
(if (symbolic-link? lnktarget) (delete-file lnktarget))
(if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
(if (not (directory? test-path))
@@ -1032,15 +1015,15 @@
ovrcmd
(conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/"
" >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log")))
(status (system cmd)))
(if (not (eq? status 0))
- (debug:print 2 "ERROR: problem with running \"" cmd "\"")))
+ (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\"")))
(list lnkpathf lnkpath ))
(if (and test-src-path (> remtries 0))
(begin
- (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
+ (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries)
;;
(create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1)))
(list #f #f)))))
;; 1. look though disks list for disk with most space
@@ -1114,11 +1097,11 @@
(if launcher (set! launcher (string-split launcher)))
;; set up the run work area for this test
(if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run
(not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir
(begin
- (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
+ (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path)
(runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
@@ -1126,15 +1109,15 @@
(set! diskpath (get-best-disk *configdat* tconfig))
(if diskpath
(let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
(set! toptest-work-area (cadr dat))
- (debug:print-info 2 "Using work area " work-area))
+ (debug:print-info 2 *default-log-port* "Using work area " work-area))
(begin
(set! work-area (conc test-path "/tmp_run"))
(create-directory work-area #t)
- (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
+ (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run")))
(set! cmdparms (base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
@@ -1168,17 +1151,17 @@
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
(set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
(else
- (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
+ (if (not useshell)(debug:print 0 *default-log-port* "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section"))
(set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" ""))))))
;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" "")))))
(if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
- (debug:print 1 "Launching " work-area)
+ (debug:print 1 *default-log-port* "Launching " work-area)
;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
- (debug:print 4 "fullcmd: " fullcmd)
+ (debug:print 4 *default-log-port* "fullcmd: " fullcmd)
(let* ((commonprevvals (alist->env-vars
(hash-table-ref/default *configdat* "env-override" '())))
(testprevvals (alist->env-vars
(hash-table-ref/default tconfig "pre-launch-env-overrides" '())))
(miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
@@ -1211,12 +1194,12 @@
(print "LAUNCHCMD: " (string-intersperse fullcmd " "))
(if (list? launch-results)
(apply print launch-results)
(print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this"))
#:append))
- (debug:print 2 "Launching completed, updating db")
- (debug:print 2 "Launch results: " launch-results)
+ (debug:print 2 *default-log-port* "Launching completed, updating db")
+ (debug:print 2 *default-log-port* "Launch results: " launch-results)
(if (not launch-results)
(begin
(print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now")
;; (sqlite3:finalize! db)
;; good ole "exit" seems not to work
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -73,16 +73,16 @@
(tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
(handle-exceptions
exn
(if (> remtries 0)
(begin
- (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 30)
(lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1)))
(begin
- (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
#f))
(sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;"
newstate
test-id)))
@@ -91,17 +91,17 @@
;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200)
(handle-exceptions
exn
(if (> remtries 0)
(begin
- (debug:print 0 "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 5)
(lock-queue:delete-lock-db dbdat)
(lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1)))
(begin
- (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
#f))
(let ((res #f))
(sqlite3:for-each-row
(lambda (tid)
;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
@@ -119,12 +119,12 @@
(mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
(let ((result
(handle-exceptions
exn
(begin
- (debug:print 0 "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 10)
;; (if (> count 0)
;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries
;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained
(lock-queue:delete-lock-db dbdat)
@@ -151,12 +151,12 @@
(let* ((dbdat (lock-queue:open-db fname)))
(tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal")
(handle-exceptions
exn
(begin
- (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! (/ count 10))
(if (> count 0)
(begin
(sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))
(lock-queue:release-lock fname test-id count: (- count 1)))
@@ -171,17 +171,17 @@
#f))))
(sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id)
(sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)))))
(define (lock-queue:steal-lock dbdat test-id #!key (count 10))
- (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
+ (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat))
(tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal")
(handle-exceptions
exn
(begin
- (tadebug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 10)
(if (> count 0)
(lock-queue:steal-lock dbdat test-id count: (- count 1))
#f))
(sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';"))
@@ -197,20 +197,20 @@
(db (lock-queue:db-dat-get-db dbdat)))
;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file")
(handle-exceptions
exn
(begin
- (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))
(thread-sleep! 10)
(if (> count 0)
(begin
(sqlite3:finalize! db)
(lock-queue:wait-turn fname test-id count: (- count 1)))
(begin
- (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
+ (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain")
(print-call-chain (current-error-port))
#f)))
;; wait 10 seconds and then check to see if someone is already updating the html
(thread-sleep! 10)
(if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two or four digit decimal
-;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00..
+;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6031)
+(define megatest-version 1.6102)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -36,10 +36,11 @@
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
+(declare (uses dcommon))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
@@ -76,16 +77,18 @@
Optionally use :state and :status
-set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
-rerun FAIL,WARN... : force re-run for tests with specificed status(s)
-rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
and then run the specified testpatt with -preclean
+ -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
-lock : lock run specified by target and runname
-unlock : unlock run specified by target and runname
-set-run-status status : sets status for run to status, requires -target and -runname
-get-run-status : gets status for run specified by target and runname
-run-wait : wait on run specified by target and runname
-preclean : remove the existing test directory before running the test
+ -clean-cache : remove the cached megatest.config and runconfig.config files
Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
-target key1/key2/... : run for key1, key2, etc.
-reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig
-testpatt patt1/patt2,patt3/... : % is wildcard
@@ -270,10 +273,12 @@
"-summarize-items"
"-gui"
"-daemonize"
"-preclean"
"-rerun-clean"
+ "-rerun-all"
+ "-clean-cache"
;; misc
"-repl"
"-lock"
"-unlock"
@@ -322,11 +327,11 @@
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
)
))
- (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
+ (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
@@ -354,25 +359,25 @@
(hash-table-ref/default *db-local-sync* run-id #f))
;; (if (> (- start-time last-write) 5) ;; every five seconds
(begin ;; let ((sync-time (- (current-seconds) start-time)))
(db:multi-db-sync (list run-id) 'new2old)
(let ((sync-time (- (current-seconds) start-time)))
- (debug:print-info 3 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
+ (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
(if (common:low-noise-print 30 "sync new to old")
- (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
+ (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
;; (begin
- ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
+ ;; (debug:print-info 0 *default-log-port* "Sync is taking a long time, start up a server to assist for run " run-id)
;; (server:kind-run run-id)))))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
(hash-table-keys *db-local-sync*))
(if (and debug-mode
(> (- start-time last-time) 60))
(begin
(set! last-time start-time)
- (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
+ (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
@@ -381,20 +386,20 @@
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(loop)))
(if (common:low-noise-print 30)
- (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))
"Watchdog thread")))
(thread-start! *watchdog*)
+
(if (args:get-arg "-log")
(let ((oup (open-output-file (args:get-arg "-log"))))
- (debug:print-info 0 "Sending log output to " (args:get-arg "-log"))
- (current-error-port oup)
- (current-output-port oup)))
+ (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
+ (set! *default-log-port* oup)))
(if (or (args:get-arg "-h")
(args:get-arg "-help")
(args:get-arg "--help"))
(begin
@@ -403,16 +408,16 @@
(if (args:get-arg "-start-dir")
(if (file-exists? (args:get-arg "-start-dir"))
(change-directory (args:get-arg "-start-dir"))
(begin
- (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
+ (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
(if (args:get-arg "-version")
(begin
- (print megatest-version)
+ (print (common:version-signature)) ;; (print megatest-version)
(exit)))
(define *didsomething* #f)
;; Overall exit handling setup immediately
@@ -450,22 +455,52 @@
(if (debug:debug-mode 3) ;; we are obviously debugging
(set! open-run-close open-run-close-no-exception-handling))
(if (args:get-arg "-itempatt")
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
- (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
+ (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
-
+(if (args:get-arg "-runtests")
+ (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
(on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
;;======================================================================
+;; handle a clean-cache request as early as possible
+;;
+(if (args:get-arg "-clean-cache")
+ (begin
+ (set! *didsomething* #t) ;; suppress the help output.
+ (if (getenv "MT_TARGET") ;; no point in trying if no target
+ (if (args:get-arg "-runname")
+ (let* ((toppath (launch:setup))
+ (linktree (if toppath (configf:lookup *configdat* "setup" "linktree")))
+ (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname")))
+ (files (if (file-exists? runtop)
+ (append (glob (conc runtop "/.megatest*"))
+ (glob (conc runtop "/.runconfig*")))
+ '())))
+ (if (null? files)
+ (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.")
+ (begin
+ (debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n "))
+ (for-each
+ (lambda (f)
+ (handle-exceptions
+ exn
+ (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f)
+ (delete-file f)))
+ files))))
+ (debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
+ (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))))
+
+
(if (args:get-arg "-env2file")
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
@@ -479,33 +514,10 @@
" => "))
(common:get-disks *configdat*))
"\n"))
(set! *didsomething* #t)))
-(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)))))
-
;; csv processing record
(define (make-refdb:csv)
(vector
(make-sparse-array)
(make-hash-table)
@@ -539,11 +551,11 @@
(current-output-port)))
(res-data (configf:read-refdb input-db))
(data (car res-data))
(msg (cadr res-data)))
(if (not data)
- (debug:print 0 "Bad input? data=" data) ;; some error occurred
+ (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
(with-output-to-port out-port
(lambda ()
(case (string->symbol out-fmt)
((scheme)(pp data))
((perl)
@@ -660,18 +672,10 @@
(if (args:get-arg "-ping")
(let* ((run-id (string->number (args:get-arg "-run-id")))
(host:port (args:get-arg "-ping")))
(server:ping run-id host:port)))
-;; (set! *did-something* #t)
-;; (begin
-;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
-;; (case (server:get-transport)
-;; ((http)(http:ping run-id host-port))
-;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
-;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
-
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
@@ -707,13 +711,11 @@
(lambda ()
(env:print added removed changed)))
(env:print added removed changed))
(env:close-database db)
(set! *didsomething* #t))
- (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))
-
-
+ (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=star-end")))))
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
@@ -727,11 +729,11 @@
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
(set! *didsomething* #t))
- (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
+ (debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
@@ -747,11 +749,11 @@
(string->number (args:get-arg "-run-id")))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
- (debug:print-info 1 "Server connection not needed")
+ (debug:print-info 1 *default-log-port* "Server connection not needed")
(begin
;; (if run-id
;; (client:launch run-id)
;; (client:launch 0) ;; without run-id we'll start a server for "0"
#t
@@ -800,14 +802,14 @@
(format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
(if status "alive" "dead") transport)
(if (or (equal? id sid)
(equal? sid 0)) ;; kill all/any
(begin
- (debug:print-info 0 "Attempting to stop server with pid " pid)
+ (debug:print-info 0 *default-log-port* "Attempting to stop server with pid " pid)
(tasks:kill-server status hostname pullport pid transport)))))
servers)
- (debug:print-info 1 "Done with listservers")
+ (debug:print-info 1 *default-log-port* "Done with listservers")
(set! *didsomething* #t)
(exit)) ;; must do, would have to add checks to many/all calls below
(exit))))
;;======================================================================
@@ -814,21 +816,21 @@
;; Weird special calls that need to run *after* the server has started?
;;======================================================================
(if (args:get-arg "-list-targets")
(let ((targets (common:get-runconfig-targets)))
- (debug:print 1 "Found "(length targets) " targets")
+ (debug:print 1 *default-log-port* "Found "(length targets) " targets")
(case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
((alist)
(for-each (lambda (x)
;; (print "[" x "]"))
(print x))
targets))
((json)
(json-write targets))
(else
- (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
+ (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t)))
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
@@ -884,11 +886,11 @@
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
((string=? (args:get-arg "-dumpmode") "ini")
(configf:config->ini data))
(else
- (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+ (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t))
(pop-directory)))
(if (args:get-arg "-show-config")
(let ((tl (launch:setup))
@@ -908,11 +910,11 @@
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
((string=? (args:get-arg "-dumpmode") "ini")
(configf:config->ini data))
(else
- (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+ (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t)
(pop-directory)))
(if (args:get-arg "-show-cmdinfo")
(if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
@@ -919,11 +921,11 @@
(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
(if (equal? (args:get-arg "-dumpmode") "json")
(json-write data)
(pp data))
(set! *didsomething* #t))
- (debug:print-info 0 "environment variable MT_CMDINFO is not set")))
+ (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
;;======================================================================
;; Remove old run(s)
;;======================================================================
@@ -932,34 +934,37 @@
(define (operate-on action)
(let* ((runrec (runs:runrec-make-record))
(target (common:args-get-target)))
(cond
((not target)
- (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg")
+ (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg")
(exit 1))
((not (or (args:get-arg ":runname")
(args:get-arg "-runname")))
- (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
+ (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
(exit 2))
((not (args:get-arg "-testpatt"))
- (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt")
+ (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt")
(exit 3))
(else
(if (not (car *configinfo*))
(begin
- (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
+ (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
(exit 1))
;; put test parameters into convenient variables
- (runs:operate-on action
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- state: (common:args-get-state)
- status: (common:args-get-status)
- new-state-status: (args:get-arg "-set-state-status")))
+ (begin
+ ;; check for correct version, exit with message if not correct
+ (common:exit-on-version-changed)
+ (runs:operate-on action
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ state: (common:args-get-state)
+ status: (common:args-get-status)
+ new-state-status: (args:get-arg "-set-state-status"))))
(set! *didsomething* #t)))))
-
+
(if (args:get-arg "-remove-runs")
(general-run-call
"-remove-runs"
"remove runs"
(lambda (target runname keys keyvals)
@@ -983,11 +988,11 @@
#f #f #f))
(header (vector-ref runsdat 0))
(rows (vector-ref runsdat 1)))
(if (null? rows)
(begin
- (debug:print-info 0 "No matching run found.")
+ (debug:print-info 0 *default-log-port* "No matching run found.")
(exit 1))
(let* ((row (car (vector-ref runsdat 1)))
(run-id (db:get-value-by-header row header "id")))
(if (args:get-arg "-set-run-status")
(rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
@@ -1083,11 +1088,11 @@
(tal (cdr adj-tests-spec))
(idx 0))
(hash-table-set! test-field-index hed idx)
(if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
(begin
- (debug:print 0 "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+ (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
(exit)))))
;; Each run
(for-each
(lambda (run)
@@ -1112,11 +1117,12 @@
;; use qryvals if test-spec provided
(if tests-spec
(string-intersperse adj-tests-spec ",")
;; db:test-record-fields
#f)
- #f)
+ #f
+ 'normal)
'())))
(case dmode
((json ods)
(if runs-spec
(for-each
@@ -1151,13 +1157,13 @@
(for-each
(lambda (test)
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Bad data in test record? " test)
+ (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
(testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
(itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
(comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
@@ -1297,11 +1303,11 @@
(map (lambda (field)
(let ((tmp (assoc field metadat)))
(if tmp (cdr tmp) "")))
metadat-fields)
(begin
- (debug:print 0 "WARNING: meta data for run " runname " not found")
+ (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
'()))))
allrundat)))
;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
(run-pages (map (lambda (targdat)
(let* ((target (car targdat))
@@ -1326,11 +1332,11 @@
(cons (conc target "/" runname)
(cons (list (conc target "/" runname))
(cons '()
(cons run-fields tests)))))
(begin
- (debug:print 0 "WARNING: run " target "/" runname " appears to have no data")
+ (debug:print 0 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
;; (pp rundat)
'()))))
runsdat)
'())))
newdat)) ;; we use newdat to get target
@@ -1347,11 +1353,11 @@
(let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
(outputfile (or (args:get-arg "-o") "out.ods"))
(ouf (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)))))
(create-directory tempdir #t)
(ods:list->ods tempdir ouf sheets))))
;; (system (conc "rm -rf " tempdir))
(set! *didsomething* #t))))
@@ -1387,10 +1393,11 @@
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall")
(args:get-arg "-run")
(args:get-arg "-rerun-clean")
+ (args:get-arg "-rerun-all")
(args:get-arg "-runtests"))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
@@ -1411,10 +1418,28 @@
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
+ new-state-status: "NOT_STARTED,n/a")))
+ ;; RERUN ALL
+ (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+ (begin
+ (hash-table-set! args:arg-hash "-preclean" #t)
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ state: #f
+ ;; status: statuses
+ new-state-status: "NOT_STARTED,n/a")
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ ;; state: states
+ status: #f
new-state-status: "NOT_STARTED,n/a")))
(runs:run-tests target
runname
#f ;; (common:args-get-testpatt #f)
;; (or (args:get-arg "-testpatt")
@@ -1513,15 +1538,15 @@
(target (args:get-arg "-target"))
(toppath (assoc/default 'toppath cmdinfo)))
(change-directory toppath)
(if (not target)
(begin
- (debug:print 0 "ERROR: -target is required.")
+ (debug:print-error 0 *default-log-port* "-target is required.")
(exit 1)))
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(let* ((keys (rmt:get-keys))
;; db:test-get-paths must not be run remote
(paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
(set! *didsomething* #t)
@@ -1564,11 +1589,11 @@
(let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(outputfile (args:get-arg "-extract-ods"))
(runspatt (or (args:get-arg "-runname")(args:get-arg ":runname")))
(pathmod (args:get-arg "-pathmod")))
;; (keyvalalist (keys->alist keys "%")))
- (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
+ (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
(db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
(db:close-all dbstruct)
(set! *didsomething* #t)))))
;;======================================================================
@@ -1597,21 +1622,21 @@
(if (and run-id test-id)
(begin
(launch:recover-test run-id test-id)
(set! *didsomething* #t))
(begin
- (debug:print 0 "ERROR: bad run-id or test-id, must be integers")
+ (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
(exit 1)))))))
;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================
(define (megatest:step step state status logfile msg)
(if (not (getenv "MT_CMDINFO"))
(begin
- (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
+ (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
(let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
@@ -1623,16 +1648,18 @@
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
- (rmt:teststep-set-status! run-id test-id step state status msg logfile)
+ (let ((comment (launch:load-logpro-dat run-id test-id step)))
+ ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
+ (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
(begin
- (debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
+ (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
(exit 6))))))
(if (args:get-arg "-step")
(begin
(megatest:step
@@ -1653,11 +1680,11 @@
(args:get-arg "-load-test-data")
(args:get-arg "-runstep")
(args:get-arg "-summarize-items"))
(if (not (getenv "MT_CMDINFO"))
(begin
- (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
+ (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
@@ -1668,17 +1695,18 @@
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
- (status (args:get-arg ":status")))
+ (status (args:get-arg ":status"))
+ (stepname (args:get-arg "-step")))
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
+ (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
@@ -1695,11 +1723,11 @@
;; DO NOT run remote
(tests:summarize-items run-id test-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
- (debug:print 0 "ERROR: nothing specified to run!")
+ (debug:print-error 0 *default-log-port* "nothing specified to run!")
(if db (sqlite3:finalize! db))
(exit 6))
(let* ((stepname (args:get-arg "-runstep"))
(logprofile (args:get-arg "-logpro"))
(logfile (conc stepname ".log"))
@@ -1718,21 +1746,21 @@
(cons cmd params) " ")
") " redir " " logfile)))
;; mark the start of the test
(rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;; run the test step
- (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
+ (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
(change-directory startingdir)
(set! exitstat (system fullcmd))
(set! *globalexitstatus* exitstat)
;; (change-directory testpath)
;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
(if logprofile
(let* ((htmllogfile (conc stepname ".html"))
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
- (debug:print-info 2 "running \"" cmd "\"")
+ (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
(rmt:test-set-log! run-id test-id htmllogfile)))
@@ -1756,11 +1784,11 @@
res)))
(if (and (args:get-arg "-test-status")
(or (not state)
(not status)))
(begin
- (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
+ (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
(if (sqlite3:database? db)(sqlite3:finalize! db))
(exit 6)))
(let* ((msg (args:get-arg "-m"))
(numoth (length (hash-table-keys otherdata))))
;; Convert to rpc inside the tests:test-set-status! call, not here
@@ -1776,20 +1804,20 @@
(args:get-arg "-show-keys"))
(let ((db #f)
(keys #f))
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(set! keys (rmt:get-keys)) ;; db))
- (debug:print 1 "Keys: " (string-intersperse keys ", "))
+ (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
(if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
- (debug:print 0 "Look at the dashboard for now")
+ (debug:print 0 *default-log-port* "Look at the dashboard for now")
;; (megatest-gui)
(set! *didsomething* #t)))
(if (args:get-arg "-gen-megatest-area")
(begin
@@ -1807,40 +1835,30 @@
(if (args:get-arg "-rebuild-db")
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; keep this one local
(open-run-close patch-db #f)
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- ;; keep this one local
- ;; (open-run-close db:clean-up #f)
- (db:multi-db-sync
- #f ;; do all run-ids
- ;; 'new2old
- 'killservers
- 'dejunk
- ;; 'adj-testids
- ;; 'old2new
- 'new2old
- )
+ (common:cleanup-db)
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting") b
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(open-run-close db:find-and-mark-incomplete #f)
(set! *didsomething* #t)))
;;======================================================================
@@ -1849,11 +1867,11 @@
(if (args:get-arg "-update-meta")
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; now can find our db
;; keep this one local
(open-run-close runs:update-all-test_meta #f)
(set! *didsomething* #t)))
@@ -1891,14 +1909,19 @@
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(include "readline-fix.scm")
- (gnu-history-install-file-manager
- (string-append
- (or (get-environment-variable "HOME") ".") "/.megatest_history"))
- (current-input-port (make-gnu-readline-port "megatest> "))
+ (if *use-new-readline*
+ (begin
+ (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
+ (current-input-port (make-readline-port "megatest> ")))
+ (begin
+ (gnu-history-install-file-manager
+ (string-append
+ (or (get-environment-variable "HOME") ".") "/.megatest_history"))
+ (current-input-port (make-gnu-readline-port "megatest> "))))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))
(db:close-all dbstruct))
(exit)))
@@ -1912,11 +1935,11 @@
(not (or (args:get-arg "-run")
(args:get-arg "-runtests")))) ;; run-wait is built into runtests now
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(operate-on 'run-wait)
(set! *didsomething* #t)))
;; ;; ;; redo me ;; Not converted to use dbstruct yet
@@ -1925,24 +1948,24 @@
;; ;; ;; redo me (let* ((toppath (setup-for-run))
;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;; ;; ;; redo me (for-each
;; ;; ;; redo me (lambda (field)
;; ;; ;; redo me (let ((dat '()))
-;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field)
+;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field)
;; ;; ;; redo me (sqlite3:for-each-row
;; ;; ;; redo me (lambda (id val)
;; ;; ;; redo me (set! dat (cons (list id val) dat)))
;; ;; ;; redo me (db:get-db db run-id)
;; ;; ;; redo me (conc "SELECT id," field " FROM tests;"))
-;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field)
+;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;; ;; ;; redo me (for-each
;; ;; ;; redo me (lambda (item)
;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid
;; ;; ;; redo me (cadr item))) ;; )
;; ;; ;; redo me (if (not (equal? newval (cadr item)))
-;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
+;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
;; ;; ;; redo me (sqlite3:execute qry newval (car item))))
;; ;; ;; redo me dat)
;; ;; ;; redo me (sqlite3:finalize! qry))))
;; ;; ;; redo me (db:close-all dbstruct)
;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
@@ -1973,20 +1996,20 @@
;;======================================================================
(if *runremote* (close-all-connections!))
(if (not *didsomething*)
- (debug:print 0 help))
+ (debug:print 0 *default-log-port* help))
(set! *time-to-exit* #t)
(thread-join! *watchdog*)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
- (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
+ (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -50,16 +50,16 @@
;; (print "runsdat: " runsdat)
(let* ((header (vector-ref runsdat 0))
(runslst (vector-ref runsdat 1))
(full-list (append res runslst))
(have-more (eq? (length runslst) limit)))
- ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
+ ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more)
(if have-more
(let ((new-offset (+ offset limit))
(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f)))
- (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
- (debug:print-info 0 "next-batch: " next-batch)
+ (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.")
+ (debug:print-info 0 *default-log-port* "next-batch: " next-batch)
(loop next-batch
full-list
new-offset
limit))
(vector header full-list)))))
@@ -67,20 +67,20 @@
;;======================================================================
;; T E S T S
;;======================================================================
(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f))
- (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update))
+ (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal))
(res '())
(offset 0)
(limit 500))
(let* ((full-list (append res testsdat))
(have-more (eq? (length testsdat) limit)))
(if have-more
(let ((new-offset (+ offset limit)))
- (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
- (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update)
+ (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.")
+ (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal)
full-list
new-offset
limit))
full-list))))
@@ -91,11 +91,11 @@
(if last-time
(< (current-seconds)(+ last-time 5))
#f))))
(if useres
(let ((result (vector-ref res 1)))
- (debug:print 4 "Using lazy value res: " result)
+ (debug:print 4 *default-log-port* "Using lazy value res: " result)
result)
(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
@@ -105,11 +105,11 @@
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
- (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
+ (debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
(remt (cdr tests))
(res '()))
(let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
(waitons (vector-ref test-dat 2)))
@@ -120,11 +120,11 @@
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
- (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test)
+ (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
@@ -137,11 +137,12 @@
(db:test-get-rundir test-dat)) ;; ) ;; )
(test-name (db:test-get-testname test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
- (if (and test-rundir ;; #f means no dir set yet
+ (if (and test-name
+ test-rundir ;; #f means no dir set yet
(file-exists? test-rundir)
(directory? test-rundir))
(call-with-environment-variables
(list (cons "MT_TEST_NAME" test-name)
(cons "MT_TEST_RUN_DIR" test-rundir)
@@ -155,11 +156,11 @@
(if cmd
;; Putting the commandline into ( )'s means no control over the shell.
;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
;; or equivalent. No need to do this. Just run it?
(let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&")))
- (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd)
+ (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd)
(process-run fullcmd)))))
(list
(conc state "/" status)
(conc state "/")
(conc "/" status)))
@@ -172,11 +173,11 @@
;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(if (not (and run-id test-id))
(begin
- (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
+ (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
(print-call-chain (current-error-port))
#f)
(begin
(cond
((and newstate newstatus newcomment)
@@ -214,9 +215,9 @@
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
- (debug:print 0 "ERROR: No readable testconfig found for " test-name)
+ (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
Index: multi-dboard.scm
==================================================================
--- multi-dboard.scm
+++ multi-dboard.scm
@@ -212,11 +212,11 @@
(else (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)))
@@ -240,11 +240,11 @@
db ;; merely return the already opened db
(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
(db (if (file-exists? dbfile)
(open-database dbfile)
(begin
- (debug:print 0 "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.")
+ (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
#f))))
(case run-id
((-1)(areadat-monitordb-set! areadat db))
((0) (areadat-maindb-set! areadat db))
(else (rundat-db-set! rundat db)))
@@ -263,11 +263,11 @@
(print row)
(hash-table-set! runs id dat))))
(sql maindb (conc "SELECT id,"
(string-intersperse keys "||'/'||")
",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
- (debug:print 0 "ERROR: no main.db found at " (areadb:dbfile-path areadat 0)))
+ (debug:print-error 0 *default-log-port* "no main.db found at " (areadb:dbfile-path areadat 0)))
areadat))
;; given an areadat and target/runname patt fill up runs data
;;
;; ?????/
@@ -323,15 +323,15 @@
(current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
(seen-nodes (make-hash-table))
(path-changed (if current-tab
(equal? current-path (tab-view-path current-tab))
#t)))
- ;; (debug:print-info 0 "Current path: " current-path)
+ ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
;; now for each area in the window gather the data
(if path-changed
(begin
- (debug:print-info 0 "clearing matrix - path changed")
+ (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
(dboard:clear-matrix current-tab)))
(for-each
(lambda (area-name)
;; (print "Processing for area-name " area-name)
(let* ((area-dat (hash-table-ref areas area-name))
@@ -389,18 +389,18 @@
(area (car tree-path))
(areadat-path (cdr tree-path)))
#f
;; (test-id (tree-path->test-id (cdr run-path))))
;; (if test-id
- ;; (hash-table-set! (dboard:data-get-curr-test-ids *data*)
+ ;; (hash-table-set! (dboard:data-curr-test-ids *data*)
;; window-id test-id))
;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
)))))
;; (iup:attribute-set! tb "VALUE" "0")
;; (iup:attribute-set! tb "NAME" "Runs")
;; (iup:attribute-set! tb "ADDEXPANDED" "NO")
- ;; (dboard:data-set-tests-tree! *data* tb)
+ ;; (dboard:data-tests-tree-set! *data* tb)
tb))
;;======================================================================
;; M A I N M A T R I X
;;======================================================================
@@ -422,11 +422,11 @@
#:click-cb (lambda (obj lin col status)
(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
(iup:attribute-set! view-matrix "WIDTH0" "100")
- ;; (dboard:data-set-runs-matrix! *data* runs-matrix)
+ ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
;; (iup:hbox
;; (iup:frame
;; #:title "Runs browser"
;; (iup:vbox
view-matrix))
@@ -485,11 +485,11 @@
(used-rows (hash-table-values rows))
(touched (make-hash-table)) ;; (vector row col) ==> true, touched cell
(view-type (dboard:get-view-type keys current-path))
(changed #f)
(state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
- ;; (debug:print 0 "current-matrix=" current-matrix)
+ ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
(case view-type
((areas) ;; find row for this area, if not found, create new entry
(let* ((curr-rownum (hash-table-ref/default rows area-name #f))
(next-rownum (+ (apply max (cons 0 used-rows)) 1))
(rownum (or curr-rownum next-rownum))
@@ -503,11 +503,11 @@
(if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
(iup:attribute-set! current-matrix (conc "0:" count) hed))
(iup:attribute-set! current-matrix (conc rownum ":" count) "0")
(if (not (null? tal))
(loop (car tal)(cdr tal)(+ count 1))))
- (debug:print-info 0 "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
+ (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
(iup:attribute-set! current-matrix coord area-name)
(set! changed #t))))))
(if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
@@ -573,11 +573,11 @@
(if (not (null? area-names))
(let loop ((index 0)
(hed (car area-names))
(tal (cdr area-names)))
;; (hash-table-set! tabs index hed)
- (debug:print 0 "Adding area " hed " with index " index " to dashboard")
+ (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
(iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
(if (not (null? tal))
(loop (+ index 1)(car tal)(cdr tal)))))
tabtop))))
@@ -730,21 +730,21 @@
toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
(curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
(curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f)))
(if curr-mtpath
(begin
- (debug:print-info 0 "Creating config file " fname)
+ (debug:print-info 0 *default-log-port* "Creating config file " fname)
(if (not (file-exists? dirname))
(create-directory dirname #t))
(with-output-to-file fname
(lambda ()
(let ((aname (pathname-strip-directory curr-mtpath)))
(print "[" aname "]")
(print "path " curr-mtpath))))
#t)
(begin
- (debug:print-info 0 "Need to create a config but no megatest.config found: " curr-mtcfgdat)
+ (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
#f))))
;; )
(define (dboard:read-mtconf apath)
(let* ((mtconffile (conc apath "/megatest.config")))
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -261,11 +261,11 @@
;; T E S T S
;;======================================================================
(define (tree-path->test-id path)
(if (not (null? path))
- (hash-table-ref/default (dboard:data-get-path-test-ids *data*) path #f)
+ (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f)
#f))
(define (test-panel window-id)
(let* ((curr-row-num 0)
(viewlog (lambda (x)
@@ -345,11 +345,11 @@
#:numlin-visible 8))
(updater (lambda (testdat)
(test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix))))
;; Set the updater in updaters
- (hash-table-set! (dboard:data-get-updaters *data*) window-id updater)
+ (hash-table-set! (dboard:data-updaters *data*) window-id updater)
;;
(for-each
(lambda (mat)
;; (iup:attribute-set! mat "0:1" "Value")
;; (iup:attribute-set! mat "0:0" "Var")
@@ -447,29 +447,29 @@
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(test-id (tree-path->test-id (cdr run-path))))
(if test-id
- (hash-table-set! (dboard:data-get-curr-test-ids *data*)
+ (hash-table-set! (dboard:data-curr-test-ids *data*)
window-id test-id))
(print "path: " (tree:node->path obj id) " test-id: " test-id))))))
(iup:attribute-set! tb "VALUE" "0")
(iup:attribute-set! tb "NAME" "Runs")
;;(iup:attribute-set! tb "ADDEXPANDED" "NO")
- (dboard:data-set-tests-tree! *data* tb)
+ (dboard:data-tests-tree-set! *data* tb)
tb)
(test-panel window-id)))
;; The function to update the fields in the test view panel
(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)
;; get test-id
;; then get test record
(if testdat
- (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f))
+ (let* ((test-id (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f))
(test-data (hash-table-ref/default testdat test-id #f))
(run-id (db:test-get-run_id test-data))
- (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*)
+ (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*)
run-id
'()))
(target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/")))
(runname (if (null? targ/runname) "" (car (cdr targ/runname))))
(steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id)))
@@ -562,11 +562,11 @@
(print "obj: " obj " lin: " lin " col: " col " status: " status)))))
(iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES")
(iup:attribute-set! runs-matrix "WIDTH0" "100")
- (dboard:data-set-runs-matrix! *data* runs-matrix)
+ (dboard:data-runs-matrix-set! *data* runs-matrix)
(iup:hbox
(iup:frame
#:title "Runs browser"
(iup:vbox
runs-matrix)))))
@@ -611,11 +611,11 @@
(states '())
(statuses '())
(nextmintime (current-milliseconds))
(my-window-id *current-window-id*))
(set! *current-window-id* (+ 1 *current-window-id*))
- (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application
+ (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
(iup:show (main-panel my-window-id))
;; Yes, running iup:show will pop up a new panel
;; (iup:show (main-panel my-window-id))
(iup:callback-set! *tim*
"ACTION_CB"
@@ -625,11 +625,11 @@
(if (< nextmintime (current-milliseconds))
(let* ((starttime (current-milliseconds))
(changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
(endtime (current-milliseconds)))
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
- (debug:print 11 "CHANGE(S): " (car changes) "..."))
- (debug:print-info 11 "Server overloaded"))))))
+ (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
+ (debug:print-info 11 *default-log-port* "Server overloaded"))))))
-(dboard:data-set-updaters! *data* (make-hash-table))
+(dboard:data-updaters-set! *data* (make-hash-table))
(newdashboard *dbstruct-local*)
(iup:main-loop)
Index: nmsg-transport.scm
==================================================================
--- nmsg-transport.scm
+++ nmsg-transport.scm
@@ -62,11 +62,11 @@
;;======================================================================
;; S E R V E R
;;======================================================================
(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
- (debug:print 2 "Attempting to start the server ...")
+ (debug:print 2 *default-log-port* "Attempting to start the server ...")
(let* ((start-port (portlogger:open-run-close portlogger:find-port))
(server-thread (make-thread (lambda ()
(nmsg-transport:try-start-server dbstruct run-id start-port server-id))
"server thread"))
(tdbdat (tasks:open-db)))
@@ -84,26 +84,26 @@
(lambda ()(nmsg-transport:keep-running server-id run-id))
"keep running"))
(thread-join! server-thread))
(if (> retrynum 0)
(begin
- (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
+ (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
(portlogger:open-run-close portlogger:set-failed start-port)
(nmsg-transport:run dbstruct hostn run-id server-id))
(begin
- (debug:print 0 "ERROR: could not find an open port to start server on. Giving up")
+ (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
(exit 1))))))
(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
(let ((repsoc (nn-socket 'rep)))
(nn-bind repsoc (conc "tcp://*:" portnum))
(let loop ((msg-in (nn-recv repsoc)))
(let* ((dat (db:string->obj msg-in transport: 'nmsg)))
- (debug:print 0 "server, received: " dat)
+ (debug:print 0 *default-log-port* "server, received: " dat)
(let ((result (api:execute-requests dbstruct dat)))
- (debug:print 0 "server, sending: " result)
+ (debug:print 0 *default-log-port* "server, sending: " result)
(nn-send repsoc (db:obj->string result transport: 'nmsg)))
(loop (nn-recv repsoc))))))
;; all routes though here end in exit ...
;;
@@ -122,11 +122,11 @@
;; (begin
;; (current-error-port *alt-log-file*)
;; (current-output-port *alt-log-file*)))))
(if (server:check-if-running run-id)
(begin
- (debug:print-info 0 "Server for run-id " run-id " already running")
+ (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
@@ -134,15 +134,15 @@
(thread-sleep! 2)
(if (not (server:check-if-running run-id))
(loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
(- remtries 1))
(begin
- (debug:print-info 0 "Another server took the slot, exiting")
+ (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
(exit 0))))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+ (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
))
;; locked in a server id, try to start up
(nmsg-transport:run dbstruct hostn run-id server-id))
(set! *didsomething* #t)
@@ -184,11 +184,11 @@
(nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
((timeout)(set! success #f) #f)))
(key (if success
(vector-ref result 1)
#f)))
- (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
+ (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
(if (and success
(or (not expected-key) ;; just getting a reply is good enough then
(equal? key expected-key)))
(if return-socket
req
@@ -218,11 +218,11 @@
"send-recv"))
(timeout (make-thread
(lambda ()
(let loop ((count 0))
(thread-sleep! 1)
- (debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...")
+ (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
(if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
(loop (+ count 1))))
(if keepwaiting
(begin
(print "timeout waiting for ping")
@@ -240,14 +240,14 @@
(if success
(if (and (vector? result)
(vector-ref result 0)) ;; did it fail at the server?
result ;; nope, all good
(begin
- (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2))
- (debug:print 0 " client call chain:")
+ (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
+ (debug:print 0 *default-log-port* " client call chain:")
(print-call-chain (current-error-port))
- (debug:print 0 " server call chain:")
+ (debug:print 0 *default-log-port* " server call chain:")
(pp (vector-ref result 1) (current-error-port))
(signal (vector-ref result 0))))
(signal (make-composite-condition
(make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
@@ -263,11 +263,11 @@
(mutex-lock! *heartbeat-mutex*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if sdat
(begin
- (debug:print-info 0 "keep-running got sdat=" sdat)
+ (debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
sdat)
(begin
(thread-sleep! 0.5)
(loop))))))
(iface (car server-info))
@@ -297,18 +297,18 @@
(db:sync-touched *inmemdb* run-id force-sync: #t)
(if (and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(begin
- (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+ (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
- (debug:print-info 0 "Starting to shutdown the server.")
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
(set! *time-to-exit* #t)
(db:sync-touched *inmemdb* run-id force-sync: #t)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
- (debug:print-info 0 "Server shutdown complete. Exiting")
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(exit)
))))))
;;======================================================================
;; C L I E N T S
@@ -339,20 +339,20 @@
;; DO NOT USE
;;
(define (nmsg-transport:client-signal-handler signum)
(handle-exceptions
exn
- (debug:print " ... exiting ...")
+ (debug:print 0 *default-log-port* " ... exiting ...")
(let ((th1 (make-thread (lambda ()
(if (not *received-response*)
(receive-message* *runremote*))) ;; 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! 3) ;; give the flush three seconds 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))))
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -54,13 +54,13 @@
(avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
(handle-exceptions
exn
(begin
;; (release-dot-lock fname)
- (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params)
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "exn=" (condition->list exn))
+ (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "exn=" (condition->list exn))
(if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
(print-call-chain (current-error-port)))
(let* (;; (lock (obtain-dot-lock fname 2 9 10))
(db (portlogger:open-db fname))
(res (apply proc db params)))
@@ -101,15 +101,15 @@
(define (portlogger:get-prev-used-port db)
(handle-exceptions
exn
(begin
- (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "exn=" (condition->list exn))
(print-call-chain (current-error-port))
- (debug:print 0 "Continuing anyway.")
+ (debug:print 0 *default-log-port* "Continuing anyway.")
#f)
(sqlite3:fold-row
(lambda (var curr)
(or curr var curr))
#f
@@ -126,15 +126,15 @@
(+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
(random (- 64000 lowport))))))
(handle-exceptions
exn
(begin
- (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "exn=" (condition->list exn))
(print-call-chain (current-error-port))
- (debug:print 0 "Continuing anyway."))
+ (debug:print 0 *default-log-port* "Continuing anyway."))
(portlogger:take-port db portnum))
portnum))
;; set port to "released", "failed" etc.
;;
@@ -156,14 +156,14 @@
(numargs (length args))
(result
(handle-exceptions
exn
(begin
- (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.")
+ (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))
#f)
(case (string->symbol (car args)) ;; commands with two or more params
((take)(portlogger:take-port db (string->number (cadr args))))
((find)(portlogger:find-port db))
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -52,11 +52,11 @@
;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
(handle-exceptions
exn
(begin
(print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
- (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))
#f)
(let-values (((fh fho pid) (if (null? params)
(process cmd)
(process cmd params))))
@@ -104,11 +104,11 @@
;; here is an example line where the shell is sh or bash
;; "find / -print 2&>1 > findall.log"
(define (run-n-wait cmdline #!key (params #f)(print-cmd #f))
(if print-cmd
- (debug:print 0
+ (debug:print 0 *default-log-port*
(if (string? print-cmd)
print-cmd
"")
cmdline
(if params
ADDED records-vs-vectors-vs-coops.scm
Index: records-vs-vectors-vs-coops.scm
==================================================================
--- /dev/null
+++ records-vs-vectors-vs-coops.scm
@@ -0,0 +1,93 @@
+;; (include "vg.scm")
+
+;; (declare (uses vg))
+
+(use foof-loop defstruct coops)
+
+(defstruct obj type fill-color angle)
+
+(define (make-vg:obj)(make-vector 3))
+(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
+(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
+(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
+(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
+(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
+(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
+
+(use simple-exceptions)
+(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
+(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
+(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
+(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
+(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
+(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
+(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
+(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
+
+(define-class <vgc> ()
+ ((type)
+ (fill-color)
+ (angle)))
+
+
+;; first use raw vectors
+(print "Using vectors")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vg:obj)))
+ (vg:obj-set-type! obj 'abc)
+ (vg:obj-set-fill-color! obj "green")
+ (vg:obj-set-angle! obj 135)
+ (let ((a (vg:obj-get-type obj))
+ (b (vg:obj-get-fill-color obj))
+ (c (vg:obj-get-angle obj)))
+ obj))))))
+
+;; first use raw vectors with safe mode
+(print "Using vectors (safe mode)")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vgs:obj)))
+ ;; (badobj (make-vector 20)))
+ (vgs:obj-type-set! obj 'abc)
+ (vgs:obj-fill-color-set! obj "green")
+ (vgs:obj-angle-set! obj 135)
+ (let ((a (vgs:obj-type obj))
+ (b (vgs:obj-fill-color obj))
+ (c (vgs:obj-angle obj)))
+ obj))))))
+
+;; first use defstruct
+(print "Using defstruct")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-obj)))
+ (obj-type-set! obj 'abc)
+ (obj-fill-color-set! obj "green")
+ (obj-angle-set! obj 135)
+ (let ((a (obj-type obj))
+ (b (obj-fill-color obj))
+ (c (obj-angle obj)))
+ obj))))))
+
+
+;; first use defstruct
+(print "Using coops")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make <vgc>)))
+ (set! (slot-value obj 'type) 'abc)
+ (set! (slot-value obj 'fill-color) "green")
+ (set! (slot-value obj 'angle) 135)
+ (let ((a (slot-value obj 'type))
+ (b (slot-value obj 'fill-color))
+ (c (slot-value obj 'angle)))
+ obj))))))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -53,11 +53,11 @@
(max (- (current-seconds) start) 1))))
(vector-set! record 1 count)
(if (and (> count 10)
(> queries-per-second 10))
(begin
- (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
+ (debug:print-info 1 *default-log-port* "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
#t)
#f))))
;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
@@ -73,26 +73,26 @@
#f))))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
;; clean out old connections
- (mutex-lock! *db-multi-sync-mutex*)
+ ;; (mutex-lock! *db-multi-sync-mutex*)
(let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
(for-each
(lambda (run-id)
(let ((connection (hash-table-ref/default *runremote* run-id #f)))
(if (and (vector? connection)
(< (http-transport:server-dat-get-last-access connection) expire-time))
(begin
- (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
+ (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses")
;; SHOULD CLOSE THE CONNECTION HERE
(case *transport-type*
((nmsg)(nn-close (http-transport:server-dat-get-socket
(hash-table-ref *runremote* run-id)))))
(hash-table-delete! *runremote* run-id)))))
(hash-table-keys *runremote*)))
- (mutex-unlock! *db-multi-sync-mutex*)
+ ;; (mutex-unlock! *db-multi-sync-mutex*)
;; (mutex-lock! *send-receive-mutex*)
(let* ((run-id (if rid rid 0))
(connection-info (rmt:get-connection-info run-id)))
;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
(if connection-info
@@ -114,11 +114,11 @@
;; (mutex-unlock! *send-receive-mutex*)
(case *transport-type*
((http) res) ;; (db:string->obj res))
((nmsg) res))) ;; (vector-ref res 1)))
(begin ;; let ((new-connection-info (client:setup run-id)))
- (debug:print 0 "WARNING: Communication failed, trying call to rmt:send-receive again.")
+ (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.")
;; (case *transport-type*
;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info))))
(hash-table-delete! *runremote* run-id) ;; don't keep using the same connection
;; NOTE: killing server causes this process to block forever. No idea why. Dec 2.
;; (if (eq? (modulo attemptnum 5) 0)
@@ -153,17 +153,17 @@
"300")))
(newres (rmt:open-qry-close-locally cmd run-id params)))
(let ((delta (- (current-milliseconds) start-time)))
(if (> delta max-query)
(begin
- (debug:print-info 0 "Starting server as query time " delta " is over the limit of " max-query)
+ (debug:print-info 0 *default-log-port* "Starting server as query time " delta " is over the limit of " max-query)
(server:kind-run run-id)))
;; return the result!
newres)
)))
(begin
- ;; (debug:print 0 "ERROR: Communication failed!")
+ ;; (debug:print-error 0 *default-log-port* "Communication failed!")
;; (mutex-unlock! *send-receive-mutex*)
;; (exit)
(rmt:open-qry-close-locally cmd run-id params)
)))))
@@ -170,12 +170,12 @@
(define (rmt:update-db-stats run-id rawcmd params duration)
(mutex-lock! *db-stats-mutex*)
(handle-exceptions
exn
(begin
- (debug:print 0 "WARNING: stats collection failed in update-db-stats")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
#f) ;; if this fails we don't care, it is just stats
(let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd)))
(stat-vec (hash-table-ref/default *db-stats* cmd #f)))
(if (not (vector? stat-vec))
@@ -187,15 +187,15 @@
(mutex-unlock! *db-stats-mutex*))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
- (debug:print 18 "DB Stats\n========")
- (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
+ (debug:print 18 *default-log-port* "DB Stats\n========")
+ (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
- (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
+ (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
(lambda (a b)
(> (vector-ref (hash-table-ref *db-stats* a) 0)
(vector-ref (hash-table-ref *db-stats* b) 0)))))))
@@ -239,15 +239,15 @@
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (not success)
(if (> remretries 0)
(begin
- (debug:print 0 "ERROR: local query failed. Trying again.")
+ (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
(thread-sleep! (/ (random 5000) 1000)) ;; some random delay
(rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
(begin
- (debug:print 0 "ERROR: too many retries in rmt:open-qry-close-locally, giving up")
+ (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
#f))
(begin
;; (rmt:update-db-stats run-id cmd params duration)
;; mark this run as dirty if this was a write
(if (not (member cmd api:read-only-queries))
@@ -270,11 +270,11 @@
(if (and res (vector-ref res 0))
(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
#f)))
;; (db:string->obj (vector-ref dat 1))
;; (begin
-;; (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat)
+;; (debug:print-error 0 *default-log-port* "rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat)
;; dat))))
;; Wrap json library for strings (why the ports crap in the first place?)
(define (rmt:dat->json-str dat)
(with-output-to-string
@@ -350,10 +350,13 @@
(rmt:send-receive 'get-key-vals #f (list run-id)))
(define (rmt:get-targets)
(rmt:send-receive 'get-targets #f '()))
+(define (rmt:get-target run-id)
+ (rmt:send-receive 'get-target run-id (list run-id)))
+
;;======================================================================
;; T E S T S
;;======================================================================
;; Just some syntatic sugar
@@ -365,11 +368,11 @@
(define (rmt:get-test-info-by-id run-id test-id)
(if (and (number? run-id)(number? test-id))
(rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
(begin
- (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
+ (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain (current-error-port))
#f)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
@@ -376,25 +379,25 @@
(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(let* ((test-path (if (string? work-area)
work-area
(rmt:test-get-rundir-from-test-id run-id test-id))))
- (debug:print 3 "TEST PATH: " test-path)
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
(rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
-(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update)
+(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
(if (number? run-id)
- (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update))
+ (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))
(begin
- (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
+ (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
(print-call-chain (current-error-port))
'())))
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
@@ -421,11 +424,11 @@
(if (list? res)
(begin
(mutex-lock! multi-run-mutex)
(set! result (append result res))
(mutex-unlock! multi-run-mutex))
- (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
+ (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
(conc "multi-run-thread for run-id " hed)))
(newthreads (cons newthread threads)))
(thread-start! newthread)
(thread-sleep! 0.05) ;; give that thread some time to start
(if (null? tal)
@@ -615,22 +618,27 @@
(if (not keyvals)
#f
(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
+ (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
- (let ((results (rmt:get-tests-for-run 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 ", item-path " item-path ": " results)
+ (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
+ #f #f #f ;; offset limit not-in hide/not-hide
+ #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
+ (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
+(define (rmt:get-run-stats)
+ (rmt:send-receive 'get-run-stats #f '()))
+
;;======================================================================
;; S T E P S
;;======================================================================
;; Getting steps is more complicated.
@@ -647,11 +655,11 @@
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
(let* ((state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
- (debug:print 3 "WARNING: Invalid " (if status "status" "state")
+ (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
(define (rmt:get-steps-for-test run-id test-id)
(rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
@@ -659,14 +667,15 @@
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
- (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
- (if tdb
- (tdb:read-test-data tdb test-id categorypatt)
- '())))
+ (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
+;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
+;; (if tdb
+;; (tdb:read-test-data tdb test-id categorypatt)
+;; '())))
(define (rmt:testmeta-add-record testname)
(rmt:send-receive 'testmeta-add-record #f (list testname)))
(define (rmt:testmeta-get-record testname)
@@ -692,10 +701,13 @@
(rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
(define (rmt:tasks-set-state-given-param-key param-key new-state)
(rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
+(define (rmt:tasks-get-last target runname)
+ (rmt:send-receive 'tasks-get-last #f (list target runname)))
+
;;======================================================================
;; A R C H I V E S
;;======================================================================
(define (rmt:archive-get-allocations testname itempath dneeded)
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ rpc-transport.scm
@@ -27,11 +27,11 @@
;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
(handle-exceptions
exn
(begin
- (debug:print 1 "Remote failed for " proc " " params)
+ (debug:print 1 *default-log-port* "Remote failed for " proc " " params)
(apply (eval (string->symbol procstr)) params))
;; (if *runremote*
;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
(apply (eval (string->symbol procstr)) params)))
@@ -43,11 +43,11 @@
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
(if (server:check-if-running run-id)
(begin
- (debug:print 0 "INFO: Server for run-id " run-id " already running")
+ (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0)))
(let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
@@ -55,18 +55,18 @@
(thread-sleep! 2)
(loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+ (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch")))
(begin
(rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
(exit)))))
(define (rpc-transport:run hostn run-id server-id)
- (debug:print 2 "Attempting to start the rpc server ...")
+ (debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
;; (trace rpc:publish-procedure!)
(rpc:publish-procedure! 'server:login server:login)
(rpc:publish-procedure! 'testing (lambda () "Just testing"))
@@ -99,11 +99,11 @@
(set! db *inmemdb*)
(open-run-close tasks:server-set-interface-port
tasks:open-db
server-id
ipaddrstr portnum)
- (debug:print 0 "Server started on " host:port)
+ (debug:print 0 *default-log-port* "Server started on " host:port)
;; (trace rpc:publish-procedure!)
;; (rpc:publish-procedure! 'server:login server:login)
;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
@@ -123,18 +123,18 @@
(thread-sleep! 5) ;; no need to do this very often
(let ((numrunning -1)) ;; (db:get-count-tests-running db)))
(if (or (> numrunning 0)
(> (+ *last-db-access* 60)(current-seconds)))
(begin
- (debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
+ (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop (+ 1 count)))
(begin
- (debug:print-info 0 "Starting to shutdown the server side")
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server side")
(open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
(thread-sleep! 10)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Server shutdown complete. Exiting")
+ (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
))))))
(define (rpc-transport:find-free-port-and-open port)
(handle-exceptions
exn
@@ -162,11 +162,11 @@
(exit 1))))))
(define (rpc-transport:client-setup run-id #!key (remtries 10))
(if *runremote*
(begin
- (debug:print 0 "ERROR: Attempt to connect to server but already connected")
+ (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected")
#f)
(let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
(if host-info
(let ((iface (car host-info))
(port (cadr host-info))
@@ -178,11 +178,11 @@
(begin
(server:try-running run-id)
(thread-sleep! 2)
(rpc-transport:client-setup run-id (- remtries 1)))))
(let* ((server-db-info (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-db-info
(let* ((iface (tasks:hostinfo-get-interface server-db-info))
(port (tasks:hostinfo-get-port server-db-info))
(server-dat (list iface port #f #f #f))
(ping-res ((rpc:procedure 'server:login host port) *toppath*)))
@@ -201,26 +201,26 @@
;;
;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
;; (if (and port
;; (string->number port))
;; (let ((portn (string->number port)))
-;; (debug:print-info 2 "Setting up to connect to host " host ":" port)
+;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port)
;; (handle-exceptions
;; exn
;; (begin
-;; (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port)
-;; (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port)
+;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
;; ;; (open-run-close
;; ;; (lambda (db . param)
;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
;; ;; #f)
;; (set! *runremote* #f))
;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
;; ((rpc:procedure 'server:login host portn) *toppath*))
;; (begin
-;; (debug:print-info 2 "Logged in and connected to " host ":" port)
+;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port)
;; (set! *runremote* (vector host portn)))
;; (begin
-;; (debug:print-info 2 "Failed to login or connect to " host ":" port)
+;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port)
;; (set! *runremote* #f)))))
-;; (debug:print-info 2 "no server available")))))
+;; (debug:print-info 2 *default-log-port* "no server available")))))
ADDED run-eff.sql
Index: run-eff.sql
==================================================================
--- /dev/null
+++ run-eff.sql
@@ -0,0 +1,14 @@
+.mode col
+.head on
+select runs.runname,num_items,printf("%.2f",wall_runtime) AS runtime,printf("%.2f",max_duration) AS duration,ratio,testname from
+ (select run_id,
+ count(id) AS num_items,
+ (max(event_time+run_duration)-min(event_time))/3600.0 AS wall_runtime,
+ max(run_duration)/3600.0 AS max_duration,
+ (max(event_time+run_duration)-min(event_time))/max(run_duration) AS ratio,
+ testname from tests where item_path != '' AND state != 'DELETED'
+ group by run_id
+ order by ratio DESC) AS dat
+ join runs on dat.run_id=runs.id
+WHERE ratio > 1
+AND runs.state != 'deleted';
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -17,20 +17,20 @@
(thekey (if keyvals
(string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/")
(or (common:args-get-target)
(get-environment-variable "MT_TARGET")
(begin
- (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg")
+ (debug:print-error 0 *default-log-port* "setup-env-defaults called with no run-id or -target or -reqtarg")
"nothing matches this I hope"))))
;; Why was system disallowed in the reading of the runconfigs file?
;; NOTE: Should be setting env vars based on (target|default)
(confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey)))
(whatfound (make-hash-table))
(finaldat (make-hash-table))
(sections (list "default" thekey)))
(if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
- (debug:print 4 "Using key=\"" thekey "\"")
+ (debug:print 4 *default-log-port* "Using key=\"" thekey "\"")
(if change-env
(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
(lambda (keyval)
(safe-setenv (car keyval)(cadr keyval)))
@@ -51,15 +51,15 @@
(hash-table-set! finaldat envvar val)))
(map car section-dat)))))
sections)
(if already-seen
(begin
- (debug:print 2 "Key settings found in runconfig.config:")
+ (debug:print 2 *default-log-port* "Key settings found in runconfig.config:")
(for-each (lambda (fullkey)
- (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
+ (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
sections)
- (debug:print 2 "---")
+ (debug:print 2 *default-log-port* "---")
(set! *already-seen-runconfig-info* #t)))
;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses
confdat
))
@@ -74,7 +74,7 @@
(setup-env-defaults runconfigf run-id #t keyvals
environ-patt: (conc "(default"
(if targ
(conc "|" targ ")")
")")))
- (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))
+ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf))))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -1,7 +1,7 @@
-;; Copyright 2006-2013, Matthew Welland.
+;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
@@ -8,11 +8,12 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)
+ posix-extras directory-utils pathname-expand defstruct format)
(import (prefix sqlite3 sqlite3:))
(declare (unit runs))
(declare (uses db))
(declare (uses common))
@@ -27,10 +28,12 @@
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
+
+;; (include "debugger.scm")
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
@@ -48,11 +51,11 @@
(if itempath (setenv "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
(setenv "MT_LINKTREE" link-tree)
- (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section."))
+ (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
@@ -61,19 +64,19 @@
keyvals)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
- (debug:print 2 "setenv " key " " val)
+ (debug:print 2 *default-log-port* "setenv " key " " val)
(safe-setenv key val)))
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
(setenv "MT_RUNNAME" runname)
- (debug:print 0 "ERROR: no value for runname for id " run-id)))
+ (debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)
;; if a testname and itempath are available set the remaining appropriate variables
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
(if (and testname link-tree)
@@ -87,11 +90,11 @@
""))))
))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
- (debug:print 2 "setenv " (car item) " " (cadr item))
+ (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
itemdat))
;; Every time can-run-more-tests is called increment the delay
;;
@@ -125,11 +128,11 @@
(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
(thread-sleep! (cond
((> *runs:can-run-more-tests-count* 20)
(if (runs:lownoise "waiting on tasks" 60)
- (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ..."))
+ (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
2);; obviously haven't had any work to do for a while
(else 0)))
(let* ((num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
@@ -138,28 +141,28 @@
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
(if (not (eq? *last-num-running-tests* num-running))
(begin
- (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
+ (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(set! *last-num-running-tests* num-running)))
(if (not (eq? 0 *globalexitstatus*))
(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
(let ((can-not-run-more (cond
;; if max-concurrent-jobs is set and the number running is greater
;; than it than cannot run more jobs
((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
(if (runs:lownoise "mcj msg" 60)
- (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
+ (debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs))
#t)
;; if job-group-limit is set and number of jobs in the group is greater
;; than the limit then cannot run more jobs of this kind
((and job-group-limit
(>= num-running-in-jobgroup job-group-limit))
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
- (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
+ (debug:print 1 *default-log-port* "WARNING: number of jobs " num-running-in-jobgroup
" in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
#t)
(else #f))))
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
@@ -195,11 +198,11 @@
(set! run-count config-reruns))
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(let ((sighand (lambda (signum)
- y ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
+ ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
(let ((tdbdat (tasks:open-db)))
(rmt:tasks-set-state-given-param-key task-key "killed"))
@@ -206,11 +209,11 @@
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 3)
(exit))))
(th2 (make-thread (lambda ()
(thread-sleep! 5)
- (debug:print 0 "Done")
+ (debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2)))))
(set-signal-handler! signal/int sighand)
@@ -218,20 +221,20 @@
(runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(set! runconf (if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
- (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)
+ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
#f)))
+
+ (if (not test-patts) ;; first time in - adjust testpatt
+ (set! test-patts (common:args-get-testpatt runconf)))
;; register this run in monitor.db
(rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running")
- (if (not test-patts) ;; first time in - adjust testpatt
- (set! test-patts (common:args-get-testpatt runconf)))
-
;; Now generate all the tests lists
(set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test
(set! all-test-names (hash-table-keys all-tests-registry))
(set! test-names (tests:filter-test-names all-test-names test-patts))
@@ -249,14 +252,14 @@
;; look up all tests matching the comma separated list of globs in
;; test-patts (using % as wildcard)
;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
- (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " "))
- (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " "))
- (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " "))
- (debug:print-info 0 "required tests: " (string-intersperse (sort required-tests string<) " "))
+ (debug:print-info 0 *default-log-port* "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " "))
+ (debug:print-info 0 *default-log-port* "all tests: " (string-intersperse (sort all-test-names string<) " "))
+ (debug:print-info 0 *default-log-port* "test names: " (string-intersperse (sort test-names string<) " "))
+ (debug:print-info 0 *default-log-port* "required tests: " (string-intersperse (sort required-tests string<) " "))
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
(if (eq? *passnum* 0)
(begin
@@ -291,17 +294,17 @@
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
- (debug:print-info 8 "waitons: " waitons)
+ (debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (or (member hed waitons)
(member hed waitors))
(begin
- (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!")
+ (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton or waitor, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
(set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
@@ -323,11 +326,11 @@
(waiton-itemized (and waiton-tconfig
(or (hash-table-ref/default waiton-tconfig "items" #f)
(hash-table-ref/default waiton-tconfig "itemstable" #f))))
(itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap"))
(new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps)))
- (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
+ (debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
;; is this satisfied by merely appending "/" to the waiton name added to the list?
;;
;; This approach causes all of the items in an upstream test to be run
@@ -340,19 +343,19 @@
(if waiton-tconfig
(begin
(set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
(if waiton-itemized
(begin
- (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts)
+ (debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
(set! required-tests (cons (conc waiton "/") required-tests))
(set! test-patts new-test-patts))
(begin
- (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests")
+ (debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
(set! required-tests (cons waiton required-tests))
(set! test-patts new-test-patts))))
(begin
- (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it")
+ (debug:print-info 0 *default-log-port* "No testconfig info yet for " waiton ", setting up to re-process it")
(set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
;; - doesn't work
;; (set! test-patts (conc test-patts "," waiton "/"))
@@ -361,41 +364,42 @@
)))
(delete-duplicates (append waitons waitors)))
(let ((remtests (delete-duplicates (append waitons tal))))
(if (not (null? remtests))
(begin
- ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
+ ;; (debug:print-info 0 *default-log-port* "Preprocessing continues for " (string-intersperse remtests ", "))
(loop (car remtests)(cdr remtests))))))))
(if (not (null? required-tests))
- (debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
+ (debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
;; NOTE: these are all parent tests, items are not expanded yet.
- (debug:print-info 4 "test-records=" (hash-table->alist test-records))
+ (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
(let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
(if (> (length (hash-table-keys test-records)) 0)
(let* ((keep-going #t)
(run-queue-retries 5)
(th1 (make-thread (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain (current-error-port))
- (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
- (if (> run-queue-retries 0)
- (begin
- (set! run-queue-retries (- run-queue-retries 1))
- (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
- (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
+ (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))
+ ;; (handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (print-call-chain (current-error-port))
+ ;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (if (> run-queue-retries 0)
+ ;; (begin
+ ;; (set! run-queue-retries (- run-queue-retries 1))
+ ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))))
+ ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))
"runs:run-tests-queue"))
(th2 (make-thread (lambda ()
;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
(let ((run-ids (rmt:get-all-run-ids)))
(for-each (lambda (run-id)
(if keep-going
(handle-exceptions
exn
- (debug:print 0 "error in calling find-and-mark-incomplete for run-id " run-id)
+ (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id)
(rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
run-ids)))
"runs: mark-incompletes")))
(thread-start! th1)
(thread-start! th2)
@@ -409,12 +413,12 @@
(hash-table-set! flags "-preclean" #t))
(if (not (hash-table-ref/default flags "-rerun" #f))
(hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
;; recursive call to self
(runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
- (debug:print-info 0 "No tests to run")))
- (debug:print-info 4 "All done by here")
+ (debug:print-info 0 *default-log-port* "No tests to run")))
+ (debug:print-info 4 *default-log-port* "All done by here")
(rmt:tasks-set-state-given-param-key task-key "done")
;; (sqlite3:finalize! tasks-db)
))
@@ -438,11 +442,11 @@
;; ((and regfull (null? reg)(not (null? tal))) (car tal))
;; ((and regfull (not (null? reg))) (car reg))
;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg))
;; ((and (not regfull)(not (null? tal))) (car tal))
;; (else
-;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull)
+;; (debug:print-error 0 *default-log-port* "runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull)
;; #f)))
(define (runs:queue-next-tal tal reg n regfull)
(if regfull
tal
@@ -459,17 +463,24 @@
(define runs:nothing-left-in-queue-count 0)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps)
(let* ((loop-list (list hed tal reg reruns))
- (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
+ (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)))
+ (if (list? res)
+ res
+ (begin
+ (debug:print 0 *default-log-port*
+ "ERROR: rmt:get-prereqs-not-met returned non-list!\n"
+ " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps)
+ '()))))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(runnables (runs:calc-runnable prereqs-not-met)))
- (debug:print-info 4 "START OF INNER COND #2 "
+ (debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
"\n prereq-fails: " (runs:pretty-string prereq-fails)
@@ -479,41 +490,41 @@
"\n (null? non-completed): " (null? non-completed)
"\n reruns: " reruns
"\n items: " items
"\n can-run-more: " can-run-more)
- (cond
+ (cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
((and (not (member 'toplevel testmode))
(member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
'(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here
- (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
+ (debug:print-info 1 *default-log-port* "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue")
(if (or (not (null? tal))
(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
(begin
- (debug:print-info 0 "Nothing left in the queue!")
+ (debug:print-info 0 *default-log-port* "Nothing left in the queue!")
;; If get here twice then we know we've tried to expand all items
;; since there must be a logic issue with the handling of loops in the
;; items expand phase we will brute force an exit here.
(if (> runs:nothing-left-in-queue-count 2)
(begin
- (debug:print 0 "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness")
+ (debug:print 0 *default-log-port* "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness")
(exit 0))
(set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1)))
#f)))
;;
((or (null? prereqs-not-met)
(and (member 'toplevel testmode)
(null? non-completed)))
- (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
+ (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))")
(let ((test-name (tests:testqueue-get-testname test-record)))
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
@@ -526,11 +537,11 @@
(not (> num-items 0)))
(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
(tests:testqueue-set-items! test-record items-list)
(list hed tal reg reruns))
(begin
- (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this")
+ (debug:print-error 0 *default-log-port* "The proc from reading the items table did not yield a list - please report this")
(exit 1))))))
((and (null? fails)
(null? prereq-fails)
(not (null? non-completed)))
@@ -557,11 +568,11 @@
(if (and give-up
(not (and (null? tal)(null? reg))))
(let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
(trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
- (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
+ (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
(if (and (null? trimmed-tal)
@@ -577,18 +588,18 @@
(null? prereq-fails)
(null? non-completed))
(if (runs:can-keep-running? hed 20)
(begin
(runs:inc-cant-run-tests hed)
- (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
+ (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0))
;; getting here likely means the system is way overloaded, kill a full minute before continuing
(thread-sleep! 60)
;; num-retries code was here
;; we use this opportunity to move contents of reg to tal
(list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
(begin
- (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
+ (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
@@ -596,11 +607,11 @@
((and
(or (not (null? fails))
(not (null? prereq-fails)))
(member 'normal testmode))
- (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); "
+ (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); "
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id
(if (not (null? prereq-fails))
@@ -619,11 +630,11 @@
(if (or (not (null? reg))(not (null? tal)))
(list (car newtal)(append (cdr newtal) reg) '() reruns)
#f))
((null? runnables) #f) ;; if we get here and non-completed is null the it's all over.
(else
- (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
+ (debug:print 0 *default-log-port* "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now")
;; (list (runs:queue-next-hed tal reg reglen regfull)
;; (runs:queue-next-tal tal reg reglen regfull)
;; (runs:queue-next-reg tal reg reglen regfull)
;; reruns)
(list (car newtal)(cdr newtal) reg reruns)))))
@@ -652,20 +663,24 @@
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
- (fails (runs:calc-fails prereqs-not-met))
+ (fails (if (list? prereqs-not-met)
+ (runs:calc-fails prereqs-not-met)
+ (begin
+ (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
+ '())))
(non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed!
(not (equal? x hed)))
(runs:calc-not-completed prereqs-not-met)))
(loop-list (list hed tal reg reruns))
;; configure the load runner
(numcpus (common:get-num-cpus))
(maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
(waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
- (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: ("
+ (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: ("
(string-intersperse
(map (lambda (t)
(if (vector? t)
(conc (db:test-get-state t) "/" (db:test-get-status t))
(conc " WARNING: t is not a vector=" t )))
@@ -675,24 +690,24 @@
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
- (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))
+ (debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))
;; Don't know at this time if the test have been launched at some time in the past
;; i.e. is this a re-launch?
- (debug:print-info 4 "run-limits-info = " run-limits-info)
+ (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info)
(cond
;; Check item path against item-patts,
;;
((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
;; else the run is stuck, temporarily or permanently
;; but should check if it is due to lack of resources vs. prerequisites
- (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
+ (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
(if (or (not (null? tal))(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
@@ -699,21 +714,21 @@
#f))
;; Register tests
;;
((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
- (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
+ (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(let register-loop ((numtries 15))
(rmt:register-test run-id test-name item-path)
(if (rmt:get-test-id run-id test-name item-path)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
(if (> numtries 0)
(begin
(thread-sleep! 0.5)
(register-loop (- numtries 1)))
- (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path)))))
+ (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path)))))
(if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
(begin
(rmt:register-test run-id test-name "")
(if (rmt:get-test-id run-id test-name "")
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
@@ -731,11 +746,11 @@
;; At this point hed test registration must be completed.
;;
((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
'start)
- (debug:print-info 0 "Waiting on test registration(s): "
+ (debug:print-info 0 *default-log-port* "Waiting on test registration(s): "
(string-intersperse
(filter (lambda (x)
(eq? (hash-table-ref/default test-registry x #f) 'start))
(hash-table-keys test-registry))
", "))
@@ -744,11 +759,11 @@
;; If no resources are available just kill time and loop again
;;
((not have-resources) ;; simply try again after waiting a second
(if (runs:lownoise "no resources" 60)
- (debug:print-info 1 "no resources to run new tests, waiting ..."))
+ (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
;; Have gone back and forth on this but db starvation is an issue.
;; wait one second before looking again to run jobs.
(thread-sleep! 1)
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(list (car newtal)(cdr newtal) reg reruns))
@@ -766,10 +781,11 @@
;; well, first lets see if cpu load throttling is enabled. If so wait around until the
;; average cpu load is under the threshold before continuing
(if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
(common:wait-for-cpuload maxload numcpus waitdelay))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
+ (runs:incremental-print-results run-id)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(if (or (not (null? tal))(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
@@ -779,32 +795,32 @@
#f))
;; must be we have unmet prerequisites
;;
(else
- (debug:print 4 "FAILS: " fails)
+ (debug:print 4 *default-log-port* "FAILS: " fails)
;; If one or more of the prereqs-not-met are FAIL then we can issue
;; a message and drop hed from the items to be processed.
;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met)
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
- (debug:print-info 1 "waiting on tests; " (string-intersperse
+ (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse
(runs:mixed-list-testname-and-testrec->list-of-strings
prereqs-not-met) ", ")))
(if (or (null? fails)
(member 'toplevel testmode))
(begin
;; couldn't run, take a breather
(if (runs:lownoise "Waiting for more work to do..." 60)
- (debug:print-info 0 "Waiting for more work to do..."))
+ (debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
(thread-sleep! 1)
(list (car newtal)(cdr newtal) reg reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
(if (or (not (null? reg))(not (null? tal)))
(if (vector? hed)
(begin
- (debug:print 1 "WARNING: Dropping test " test-name "/" item-path
+ (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
" from the launch list as it has prerequistes that are FAIL")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
@@ -818,11 +834,11 @@
))
(let ((nth-try (hash-table-ref/default test-registry hed 0)))
(cond
((member "RUNNING" (map db:test-get-state prereqs-not-met))
(if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
- (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
+ (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
(thread-sleep! 4)
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns))
@@ -831,11 +847,11 @@
(< nth-try 10)))
(hash-table-set! test-registry hed (if (number? nth-try)
(+ nth-try 1)
0))
(if (runs:lownoise (conc "not removing test " hed) 60)
- (debug:print 1 "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
+ (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (list hed tal reg reruns)
;; (list (car newtal)(cdr newtal) reg reruns)
;; (hash-table-set! test-registry hed 'removed)
@@ -848,21 +864,21 @@
(if (null? tal)
#f ;; yes, really
(list (car tal)(cdr tal) reg reruns))
(begin
(if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
- (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
+ (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
(hash-table-set! test-registry hed 0)
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns))))
(else
(if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
- (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
- ;; (debug:print 0 " prereqs: " prereqs-not-met)
+ (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
+ ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met)
(hash-table-set! test-registry hed 'removed)
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
(rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL
(list (if (null? tal)(car newtal)(car tal))
@@ -893,20 +909,88 @@
t))
((DELETED) #f)
(else t)))))
tests))
+;; move all the miscellanea into this struct
+;;
+(defstruct runs:gendat inc-results inc-results-last-update inc-results-fmt run-info runname target)
+
+(define *runs:general-data*
+ (make-runs:gendat
+ inc-results: (make-hash-table)
+ inc-results-last-update: 0
+ inc-results-fmt: "~12a~12a~20a~12a~40a\n" ;; state status time duration test-name item-path
+ run-info: #f
+ runname: #f
+ target: #f
+ )
+)
+
+(define (runs:incremental-print-results run-id)
+ (let ((curr-sec (current-seconds)))
+ (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update
+ (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id)))
+ (runname (or (runs:gendat-runname *runs:general-data*)
+ (db:get-value-by-header (db:get-rows run-dat)
+ (db:get-header run-dat) "runname")))
+ (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id)))
+ (testsdat (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
+ #f #f ;; offset limit
+ #f ;; not-in
+ #f ;; sort-by
+ #f ;; sort-order
+ #f ;; get full data (not 'shortlist)
+ (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
+ 'dashboard)))
+ (if (not (runs:gendat-run-info *runs:general-data*))
+ (runs:gendat-run-info-set! *runs:general-data* run-dat))
+ (if (not (runs:gendat-runname *runs:general-data*))
+ (runs:gendat-runname-set! *runs:general-data* runname))
+ (if (not (runs:gendat-target *runs:general-data*))
+ (runs:gendat-target-set! *runs:general-data* target))
+ (for-each
+ (lambda (testdat)
+ (let* ((test-id (db:test-get-id testdat))
+ (prevdat (hash-table-ref/default (runs:gendat-inc-results *runs:general-data*)
+ (conc run-id "," test-id) #f))
+ (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))
+ (event-time (db:test-get-event_time testdat))
+ (duration (db:test-get-run_duration testdat)))
+ (if (and (not (member state '("DELETED" "REMOTEHOSTSTART" "RUNNING" "LAUNCHED""NOT_STARTED")))
+ (not (and prevdat
+ (equal? state (db:test-get-state prevdat))
+ (equal? status (db:test-get-status prevdat)))))
+ (let ((fmt (runs:gendat-inc-results-fmt *runs:general-data*))
+ (dtime (seconds->year-work-week/day-time event-time)))
+ (if (runs:lownoise "inc-print" 600)
+ (format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))
+ ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime)
+ ;; (debug:print 0 #f "event-time: " event-time " duration: " duration)
+ (format #t fmt
+ state
+ status
+ dtime
+ (seconds->hr-min-sec duration)
+ (conc "lt/" target "/" runname "/" test-name (if (string-null? item-path) "" (conc "/" item-path))))
+ (hash-table-set! (runs:gendat-inc-results *runs:general-data*) (conc run-id "," test-id) testdat)))))
+ testsdat)))
+ (runs:gendat-inc-results-last-update-set! *runs:general-data* (- curr-sec 10))))
+
;; every time though the loop increment the test/itempatt val.
;; when the min is > max-allowed and none running then force exit
;;
(define *max-tries-hash* (make-hash-table))
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
- (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))
+ (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))
;; Do mark-and-find clean up of db before starting runing of quue
;;
;; (rmt:find-and-mark-incomplete)
@@ -941,11 +1025,13 @@
(let loop ((hed (car sorted-test-names))
(tal (cdr sorted-test-names))
(reg '()) ;; registered, put these at the head of tal
(reruns '()))
- (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns))
+ (runs:incremental-print-results run-id)
+
+ (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns))
;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
;; moving this to a parallel thread and just run it once.
;;
(if (> (current-seconds)(+ last-time-incomplete 900))
@@ -980,11 +1066,11 @@
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
- ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))
+ ;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))
;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
;; and it is clear they *should* have run but did not.
(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
(begin
@@ -995,19 +1081,20 @@
;;
(if (member (hash-table-ref/default test-registry tfullname #f)
'(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
(begin
(if (runs:lownoise (conc "been marked do not run " tfullname) 60)
- (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable"))
+ (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable"))
(if (or (not (null? tal))(not (null? reg)))
(loop (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns))))
;; (loop (car tal)(cdr tal) reg reruns))))
- (debug:print 4 "TOP OF LOOP => "
+ (runs:incremental-print-results run-id)
+ (debug:print 4 *default-log-port* "TOP OF LOOP => "
"test-name: " test-name
"\n test-record " test-record
"\n hed: " hed
"\n itemdat: " itemdat
"\n items: " items
@@ -1018,16 +1105,27 @@
"\n reruns: " reruns
"\n regfull: " regfull
"\n reglen: " reglen
"\n length reg: " (length reg)
"\n reg: " reg)
+
+ ;; lets use the debugger eh?
+;; (debugger-start start: 7)
+;; (debugger-trace-var "runs:run-tests-queue" "")
+;; (debugger-trace-var "hed" hed)
+;; (debugger-trace-var "tal" tal)
+;; (debugger-trace-var "items" items)
+;; (debugger-trace-var "item-path" item-path)
+;; (debugger-trace-var "waitons" waitons)
+;; (debugger-pauser)
+
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member test-name waitons)
(begin
- (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
+ (debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
(cond
;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF
@@ -1041,17 +1139,17 @@
(if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run
(not (member waiton reruns)))
1
#f))
waitons))))) ;; could do this more elegantly with a marker....
- (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.")
+ (debug:print 0 *default-log-port* "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.")
(hash-table-set! test-registry tfullname 'removed))
;; items is #f then the test is ok to be handed off to launch (but not before)
;;
((not items)
- (debug:print-info 4 "OUTER COND: (not items)")
+ (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
(let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)))
(if loop-list (apply loop loop-list))))
@@ -1058,18 +1156,18 @@
;; items processed into a list but not came in as a list been processed
;;
((and (list? items) ;; thus we know our items are already calculated
(not itemdat)) ;; and not yet expanded into the list of things to be done
- (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))")
+ (debug:print-info 4 *default-log-port* "OUTER COND: (and (list? items)(not itemdat))")
;; Must determine if the items list is valid. Discard the test if it is not.
(if (and (list? items)
(> (length items) 0)
(and (list? (car items))
(> (length (car items)) 0))
(debug:debug-mode 1))
- (debug:print 2 (map (lambda (row)
+ (debug:print 2 *default-log-port* (map (lambda (row)
(conc (string-intersperse
(map (lambda (varval)
(string-intersperse varval "="))
row)
" ")
@@ -1088,11 +1186,11 @@
(tests:testqueue-set-item_path! new-test-record my-item-path)
(hash-table-set! test-records newtestname new-test-record)
(set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath
items)
- ;; (debug:print-info 0 "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items")
+ ;; (debug:print-info 0 *default-log-port* "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items")
;; At this point we have possibly added items to tal but all must be handed off to
;; INNER COND logic. I think loop without rotating the queue
;; (loop hed tal reg reruns))
;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test
@@ -1114,56 +1212,56 @@
;; if can't run more just loop with next possible test
(loop (car newtal)(cdr newtal) reg reruns))))
;; this case should not happen, added to help catch any bugs
((and (list? items) itemdat)
- (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
+ (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this")
(exit 1))
((not (null? reruns))
(let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
(junked (lset-difference equal? tal newlst)))
- (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal)
+ (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal)
(if (< num-retries max-retries)
(set! newlst (append reruns newlst)))
(set! num-retries (+ num-retries 1))
;; (thread-sleep! (+ 1 *global-delta*))
(if (not (null? newlst))
;; since reruns have been tacked on to newlst create new reruns from junked
(loop (car newlst)(cdr newlst) reg (delete-duplicates junked)))))
((not (null? tal))
- (debug:print-info 4 "I'm pretty sure I shouldn't get here."))
+ (debug:print-info 4 *default-log-port* "I'm pretty sure I shouldn't get here."))
((not (null? reg)) ;; could we get here with leftovers?
- (debug:print-info 0 "Have leftovers!")
+ (debug:print-info 0 *default-log-port* "Have leftovers!")
(loop (car reg)(cdr reg) '() reruns))
(else
- (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
+ (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
)))
;; now *if* -run-wait we wait for all tests to be done
;; Now wait for any RUNNING tests to complete (if in run-wait mode)
(thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle
(let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
(prev-num-running 0))
- ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running)
+ ;; (debug:print 0 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
(if (and (or (args:get-arg "-run-wait")
(equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
(> num-running 0))
(begin
;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
- ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
+ ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
(if (> (current-seconds)(+ last-time-incomplete 900))
(begin
- (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
+ (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
(set! last-time-incomplete (current-seconds))
(rmt:find-and-mark-incomplete run-id #f)))
(if (not (eq? num-running prev-num-running))
- (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
+ (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
(thread-sleep! 5)
;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
(wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
;; LET* ((test-record
;; we get here on "drop through". All done!
- (debug:print-info 1 "All tests launched")))
+ (debug:print-info 1 *default-log-port* "All tests launched")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
(and (vector? test) ;; not (string? test))
(member (db:test-get-state test) '("INCOMPLETE" "COMPLETED"))
@@ -1227,16 +1325,16 @@
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(set! item-path (item-list->path itemdat))
(set! full-test-name (db:test-make-full-name test-name item-path))
- (debug:print-info 4
+ (debug:print-info 4 *default-log-port*
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
- (debug:print 2 "Attempting to launch test " full-test-name)
+ (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
;; (setenv "MT_TEST_NAME" test-name) ;;
;; (setenv "MT_ITEMPATH" item-path)
;; (setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process
(change-directory *toppath*)
@@ -1268,35 +1366,35 @@
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
(if (not test-id)
(begin
- (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
+ (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(rmt:register-test run-id test-name item-path)
(set! test-id (rmt:get-test-id run-id test-name item-path))))
- (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
+ (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (rmt:get-test-info-by-id run-id test-id))
(if (not testdat)
(begin
- (debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
+ (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second")
(thread-sleep! 1)
(loop)))))
(if (not testdat) ;; should NOT happen
- (debug:print 0 "ERROR: failed to get test record for test-id " test-id))
+ (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(if (file-exists? test-path)
(change-directory test-path)
(begin
- (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
+ (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
(change-directory *toppath*)))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
- (debug:print 0 "ERROR: Failed to insert the record into the db"))
+ (debug:print-error 0 *default-log-port* "Failed to insert the record into the db"))
((NOT_STARTED COMPLETED DELETED INCOMPLETE)
(let ((runflag #f))
(cond
;; -force, run no matter what
(force (set! runflag #t))
@@ -1306,34 +1404,34 @@
((and (or (not rerun)
keepgoing)
;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED"))
(member (test:get-state testdat) '("COMPLETED"))))
- (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
+ (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
(hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED)
(set! runflag #f))
;; -rerun and status is one of the specifed, run it
((and rerun
(let* ((rerunlst (string-split rerun ","))
(must-rerun (member (test:get-status testdat) rerunlst)))
- (debug:print-info 3 "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
+ (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
must-rerun))
- (debug:print-info 2 "Rerun forced for test " test-name "/" item-path)
+ (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path)
(set! runflag #t))
;; -keepgoing, do not rerun FAIL
((and keepgoing
(member (test:get-status testdat) '("FAIL")))
(set! runflag #f))
((and (not rerun)
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
- (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
+ (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(if (runs:lownoise (conc "not starting test" full-test-name) 60)
- (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat)
+ (debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override")))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
@@ -1367,32 +1465,32 @@
(set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago"))))))
(if skip-test
(begin
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
- (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test))
+ (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))))
((KILLED)
- (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
+ (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
- (debug:print 2 "NOTE: " test-name " is already running"))
+ (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
- ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
+ ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
- ;; (debug:print 2 "NOTE: " test-name " is already running")))
+ ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")))
(else
- (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
+ (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))))))))
@@ -1412,11 +1510,11 @@
(if (> (system (conc "rm -rf " real-dir)) 0)
(begin
;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time
(system (conc "chmod -R a+rwx " real-dir))
(if (> (system (conc "rm -rf " real-dir)) 0)
- (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f")))))
+ (debug:print-error 0 *default-log-port* "There was a problem removing " real-dir " with rm -f")))))
(define (runs:safe-delete-test-dir real-dir)
;; first delete all sub-directories
(directory-fold
(lambda (f x)
@@ -1454,14 +1552,14 @@
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
(state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
(rp-mutex (make-mutex))
(bup-mutex (make-mutex)))
- (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
+ (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
- (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
+ (debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
(lambda (run)
(let ((runkey (string-intersperse (map (lambda (k)
(db:get-value-by-header run header k)) keys) "/"))
@@ -1479,42 +1577,42 @@
(tests (if (not (equal? run-state "locked"))
(proc-get-tests run-id)
'()))
(lasttpath "/does/not/exist/I/hope")
(worker-thread #f))
- (debug:print-info 4 "runs:operate-on run=" run ", header=" header)
+ (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
((remove-runs)
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
;; seek and kill in flight -runtests with % as testpatt here
;; (if (equal? testpatt "%")
(tasks:kill-runner target run-name testpatt)
- ;; (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt))
- (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
+ ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
+ (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
- (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
+ (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((print-run)
- (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
+ (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
action)
((run-wait)
- (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
+ (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete"))
((archive)
- (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
+ (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
(set! worker-thread (make-thread (lambda ()
(case (string->symbol (args:get-arg "-archive"))
((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
(else
- (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help")
+ (debug:print-error 0 *default-log-port* "unrecognised sub command to -archive. Run \"megatest\" to see help")
(exit))))
"archive-bup-thread"))
(thread-start! worker-thread))
(else
- (debug:print-info 0 "action not recognised " action)))
+ (debug:print-info 0 *default-log-port* "action not recognised " action)))
;; actions that operate on one test at a time can be handled below
;;
(let ((sorted-tests (filter
vector?
@@ -1532,11 +1630,11 @@
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
(new-test-dat (rmt:get-test-info-by-id run-id test-id)))
(if (not new-test-dat)
(begin
- (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
+ (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
(if (not (null? tal))
(loop (car tal)(cdr tal))))
(let* ((item-path (db:test-get-item-path new-test-dat))
(test-name (db:test-get-testname new-test-dat))
(run-dir ;;(filedb:get-path *fdb*
@@ -1550,19 +1648,19 @@
(case action
((remove-runs)
;; if the test is a toplevel-with-children issue an error and do not remove
(if toplevel-with-children
(begin
- (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
+ (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
(hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))
(if (> (hash-table-ref toplevel-retries test-fulln) 3)
(if (not (null? tal))
(loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries
(let ((newtal (append tal (list test))))
(loop (car newtal)(cdr newtal))))) ;; loop with test still in queue
(begin
- (debug:print-info 0 "test: " test-name " itest-state: " test-state)
+ (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
(if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
(begin
(if (not (hash-table-ref/default test-retry-time test-fulln #f))
(begin
;; want to set to REMOVING BUT CANNOT do it here?
@@ -1570,11 +1668,11 @@
(if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time)
;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
;; up and blow it away.
(begin
- (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
+ (debug:print 0 *default-log-port* "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
(thread-sleep! 1))
(begin
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
@@ -1586,28 +1684,28 @@
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
((set-state-status)
- (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
+ (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status))
(mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
(if (not (null? tal))
(loop (car tal)(cdr tal))))
((run-wait)
- (debug:print-info 2 "still waiting, " (length tests) " tests still running")
+ (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running")
(thread-sleep! 10)
(let ((new-tests (proc-get-tests run-id)))
(if (null? new-tests)
- (debug:print-info 1 "Run completed according to zero tests matching provided criteria.")
+ (debug:print-info 1 *default-log-port* "Run completed according to zero tests matching provided criteria.")
(loop (car new-tests)(cdr new-tests)))))
((archive)
(if (and run-dir (not toplevel-with-children))
(let ((ddir (conc run-dir "/")))
(case (string->symbol (args:get-arg "-archive"))
((save save-remove keep-html)
(if (file-exists? ddir)
- (debug:print-info 0 "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir)))))))
+ (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir)))))))
(if (not (null? tal))
(loop (car tal)(cdr tal))))
)))
)
(if worker-thread (thread-join! worker-thread))))))
@@ -1617,18 +1715,18 @@
(if (null? remtests) ;; no more tests remaining
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
- (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
+ (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
(rmt:delete-run run-id)
(rmt:delete-old-deleted-test-records)
;; (rmt:set-var "DELETED_TESTS" (current-seconds))
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
- ;; (debug:print 1 "Removing run dir " runpath)
+ ;; (debug:print 1 *default-log-port* "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
)))))
))
runs)
;; (sqlite3:finalize! (db:delay-if-busy tdbdat))
@@ -1636,46 +1734,47 @@
#t)
(define (runs:remove-test-directory test mode) ;; remove-data-only)
(let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree
(real-dir (if (file-exists? run-dir)
- (resolve-pathname run-dir)
+ ;; (resolve-pathname run-dir)
+ (common:nice-path run-dir)
#f)))
(case mode
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
- (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
+ (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
(begin ;; let* ((realpath (resolve-pathname run-dir)))
- (debug:print-info 1 "Recursively removing " real-dir)
+ (debug:print-info 1 *default-log-port* "Recursively removing " real-dir)
(if (file-exists? real-dir)
(runs:safe-delete-test-dir real-dir)
- (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable")))
+ (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable")))
(if real-dir
- (debug:print 0 "WARNING: directory " real-dir " does not exist")
- (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
+ (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist")
+ (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done")))
(if (symbolic-link? run-dir)
(begin
- (debug:print-info 1 "Removing symlink " run-dir)
+ (debug:print-info 1 *default-log-port* "Removing symlink " run-dir)
(handle-exceptions
exn
- (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
+ (debug:print-error 0 *default-log-port* " Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-file run-dir)))
(if (directory? run-dir)
(if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0)
- (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty")
+ (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty")
(handle-exceptions
exn
- (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
+ (debug:print-error 0 *default-log-port* " Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue")
(delete-directory run-dir)))
(if (and run-dir
(not (member run-dir (list "n/a" "/tmp/badname"))))
- (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
- (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
+ (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
+ (debug:print 0 *default-log-port* "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
))
;; Only delete the records *after* removing the directory. If things fail we have a record
(case mode
((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f))
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f))
@@ -1690,24 +1789,24 @@
(define (general-run-call switchname action-desc proc)
(let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))
(target (common:args-get-target)))
(cond
((not target)
- (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
+ (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target")
(exit 3))
((not runname)
- (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
+ (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the run name with -runname runname")
(exit 3))
(else
(let (;; (db #f)
(keys #f))
(if (launch:setup)
(begin
(full-runconfigs-read) ;; cache the run config
(launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
(begin
- (debug:print 0 "Failed to setup, exiting")
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
@@ -1714,19 +1813,19 @@
(runconfig (read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
- (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
+ (debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf)
;; (if db (sqlite3:finalize! db))
(exit 1)
)))
(if (args:get-arg "-target")
(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
(if (not (car *configinfo*))
(begin
- (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
+ (debug:print-error 0 *default-log-port* "Attempted to " action-desc " but run area config file not found")
(exit 1))
;; Extract out stuff needed in most or many calls
;; here then call proc
(let* ((keyvals (keys:target->keyval keys target)))
(proc target runname keys keyvals)))
@@ -1748,11 +1847,11 @@
(and unlock
(begin
(print "Do you really wish to unlock run " run-id "?\n y/n: ")
(equal? "y" (read-line)))))
(rmt:lock/unlock-run run-id lock unlock user)
- (debug:print-info 0 "Skipping lock/unlock on " run-id))))
+ (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id))))
runs)))
;;======================================================================
;; Rollup runs
;;======================================================================
@@ -1766,11 +1865,11 @@
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
- ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
+ ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
@@ -1786,11 +1885,11 @@
;; This could probably be refactored into one complex query ...
;; NOT PORTED - DO NOT USE YET
;;
(define (runs:rollup-run keys runname user keyvals)
- (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
+ (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
(let* ((db #f)
;; register run operates on the main db
(new-run-id (rmt:register-run keyvals runname "new" "n/a" user))
(prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
(curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '()))
@@ -1822,24 +1921,24 @@
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
new-run-id (cddr (vector->list testdat)))
(set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '())))
(hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
;; Now duplicate the test steps
- (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
+ (debug:print 4 *default-log-port* "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
(cdb:remote-run ;; to be replaced, note: this routine is not used currently
(lambda ()
(sqlite3:execute
db
(conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
"SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")
(db:test-get-id testdat))
;; Now duplicate the test data
- (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
+ (debug:print 4 *default-log-port* "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
(sqlite3:execute
db
(conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) "
"SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;")
(db:test-get-id testdat))))
))
prev-tests)))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -52,12 +52,12 @@
(define (server:launch run-id)
(case *transport-type*
((http)(http-transport:launch run-id))
((nmsg)(nmsg-transport:launch run-id))
((rpc) (rpc-transport:launch run-id))
- (else (debug:print 0 "ERROR: unknown server type " *transport-type*))))
-;; (else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc")
+ (else (debug:print-error 0 *default-log-port* "unknown server type " *transport-type*))))
+;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; (rpc-transport:launch run-id)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -83,11 +83,11 @@
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
+ (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; (send-message pubsock target send-more: #t)
;; (send-message pubsock
(case (server:get-transport)
((rpc) (db:obj->string (vector success/fail query-sig result)))
((http) (db:obj->string (vector success/fail query-sig result)))
@@ -95,11 +95,11 @@
(let ((pub-socket (vector-ref *runremote* 1)))
(send-message pub-socket return-addr send-more: #t)
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
((fs) result)
(else
- (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
+ (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
result)))
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
@@ -113,11 +113,11 @@
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
" -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &")))))
- (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
+ (debug:print 0 *default-log-port* "INFO: Starting server (" cmdln ") as none running ...")
(push-directory *toppath*)
(if (not (directory-exists? "logs"))(create-directory "logs"))
;; Rotate logs, logic:
;; if > 500k and older than 1 week, remove previous compressed log and compress this log
(directory-fold
@@ -125,13 +125,13 @@
(if (and (string-match "^.*.log" file)
(> (file-size (conc "logs/" file)) 200000))
(let ((gzfile (conc "logs/" file ".gz")))
(if (file-exists? gzfile)
(begin
- (debug:print-info 0 "removing " gzfile)
+ (debug:print-info 0 *default-log-port* "removing " gzfile)
(delete-file gzfile)))
- (debug:print-info 0 "compressing " file)
+ (debug:print-info 0 *default-log-port* "compressing " file)
(system (conc "gzip logs/" file)))))
'()
"logs")
;; host.domain.tld match host?
@@ -139,11 +139,11 @@
;; look at target host, is it host.domain.tld or ip address and does it
;; match current ip or hostname
(not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
(not (equal? curr-ip target-host)))
(begin
- (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile)
+ (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
(setenv "TARGETHOST" target-host)))
(setenv "TARGETHOST_LOGF" logfile)
(common:wait-for-normalized-load 4 " delaying server start due to load") ;; do not try starting servers on an already overloaded machine, just wait forever
(system (conc "nbfake " cmdln))
(unsetenv "TARGETHOST_LOGF")
@@ -193,11 +193,11 @@
timeout: 2)))))
;; if the server didn't respond we must remove the record
(if res
#t
(begin
- (debug:print-info 0 "server at " server " not responding, removing record")
+ (debug:print-info 0 *default-log-port* "server at " server " not responding, removing record")
(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id
" server:check-if-running")
res)))
#f))))
@@ -211,11 +211,11 @@
#f)))
(toppath (launch:setup))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
(begin
- (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
+ (debug:print-error 0 *default-log-port* "must specify run-id when doing ping, -run-id n")
(print "ERROR: No run-id")
(exit 1))
(if (and (not host-port)
(not server-db-dat))
(begin
@@ -252,14 +252,14 @@
(define (server:login toppath)
(lambda (toppath)
(set! *last-db-access* (current-seconds))
(if (equal? *toppath* toppath)
(begin
- ;; (debug:print-info 2 "login successful")
+ ;; (debug:print-info 2 *default-log-port* "login successful")
#t)
(begin
- ;; (debug:print-info 2 "login failed")
+ ;; (debug:print-info 2 *default-log-port* "login failed")
#f))))
(define (server:get-timeout)
(let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
Index: sharedat.scm
==================================================================
--- sharedat.scm
+++ sharedat.scm
@@ -115,11 +115,11 @@
(writeable (file-write-access? dbpath))
(dbexists (file-exists? dbpath)))
(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 1))
(call-with-database
dbpath
(lambda (db)
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -115,11 +115,11 @@
(writeable (file-write-access? dbpath))
(dbexists (file-exists? dbpath)))
(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 1))
(call-with-database
dbpath
(lambda (db)
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -54,12 +54,13 @@
(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
ls : list contents of target area
get <relversion> : retrieve data for release <version>
-m \"message\" : why retrieved?
-
+ cp <relative path> : copy file to current directory
log : get listing of recent downloads
+ shell : start a shell-like interface
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest
Version: " megatest-fossil-hash)) ;; "
@@ -108,14 +109,15 @@
;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
;; ...))
;; Create the sqlite db
(define (sretrieve:db-do configdat proc)
+
(let ((path (configf:lookup configdat "database" "location")))
(if (not path)
(begin
- (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
+ (debug:print 0 *default-log-port* "[database]\nlocation /some/path\n\n Is missing from the config file!")
(exit 1)))
(if (and path
(directory? path)
(file-read-access? path))
(let* ((dbpath (conc path "/" *exe-name* ".db"))
@@ -122,50 +124,132 @@
(writeable (file-write-access? dbpath))
(dbexists (file-exists? dbpath)))
(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 1))
+ ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath )
(call-with-database
dbpath
(lambda (db)
- ;; (debug:print 0 "calling proc " proc " on db " db)
+ ;;(debug:print 0 *default-log-port* "calling proc " proc " on db " db)
(set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
(if (not dbexists)(sretrieve:initialize-db db))
(proc db)))))
- (debug:print 0 "ERROR: invalid path for storing database: " path))))
+ (debug:print-error 0 *default-log-port* "invalid path for storing database: " path))))
-;; copy in file to dest, validation is done BEFORE calling this
+;; copy in directory to dest, validation is done BEFORE calling this
;;
(define (sretrieve:get configdat retriever version comment)
(let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
(datadir (conc base-dir "/" version)))
(if (or (not base-dir)
(not (file-exists? base-dir)))
(begin
- (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+ (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
(exit 1)))
(print datadir)
(if (not (file-exists? datadir))
(begin
- (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." )
+ (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." )
(exit 1)))
(sretrieve:db-do
configdat
(lambda (db)
(sretrieve:register-action db "get" retriever datadir comment)))
(sretrieve:do-as-calling-user
(lambda ()
- (change-directory datadir)
- (let ((files (filter (lambda (x)
+ (if (directory? datadir)
+ (begin
+ (change-directory datadir)
+ (let ((files (filter (lambda (x)
(not (member x '("." ".."))))
(glob "*" ".*"))))
- (print "files: " files)
- (process-execute "/bin/tar" (append (list "chfv" "-") files)))))))
+ (print "files: " files)
+ (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read")))))
+ (begin
+ (let* ((parent-dir (pathname-directory datadir) )
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (change-directory parent-dir)
+ (process-execute "/bin/tar" (list "chfv" "-" filename))
+ )))
+))
+))
+
+
+;; copy in file to dest, validation is done BEFORE calling this
+;;
+(define (sretrieve:cp configdat retriever file comment)
+ (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+ (datadir (conc base-dir "/" file))
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (if (or (not base-dir)
+ (not (file-exists? base-dir)))
+ (begin
+ (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
+ (exit 1)))
+ (print datadir)
+ (if (not (file-exists? datadir))
+ (begin
+ (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." )
+ (exit 1)))
+ (if (directory? datadir)
+ (begin
+ (debug:print-error 0 *default-log-port* "(" file ") is a dirctory!! cp cmd works only on files ." )
+ (exit 1)))
+ (if(not (string-match (regexp allowed-sub-paths) file))
+ (begin
+ (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " )
+ (exit 1)))
+
+ (sretrieve:db-do
+ configdat
+ (lambda (db)
+ (sretrieve:register-action db "cp" retriever datadir comment)))
+ (sretrieve:do-as-calling-user
+ ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " )
+ (change-directory (pathname-directory datadir))
+ ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) )
+ (process-execute "/bin/tar" (list "chfv" "-" filename)))
+ ))
+
+;; ls in file to dest, validation is done BEFORE calling this
+;;
+(define (sretrieve:ls configdat retriever file comment)
+ (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+ (datadir (conc base-dir "/" file))
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (if (or (not base-dir)
+ (not (file-exists? base-dir)))
+ (begin
+ (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found")
+ (exit 1)))
+ (print datadir)
+ (if (not (file-exists? datadir))
+ (begin
+ (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." )
+ (exit 1)))
+ (if(not (string-match (regexp allowed-sub-paths) file))
+ (begin
+ (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " )
+ (exit 1)))
+
+ (sretrieve:do-as-calling-user
+ (lambda ()
+ ;;(change-directory datadir)
+ ;; (debug:print 0 *default-log-port* "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'"))
+ ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line))))
+ ;; (debug:print 0 *default-log-port* status)
+ (process-execute "/bin/ls" (list "-ls" "-lrt" datadir ))
+ ))))
+
+
;;(filter (lambda (x)
;; (not (member x '("." ".."))))
;; (glob "*" ".*"))))))))
@@ -172,37 +256,37 @@
(define (sretrieve:validate target-dir targ-mk)
(let* ((normal-path (normalize-pathname targ-mk))
(targ-path (conc target-dir "/" normal-path)))
(if (string-contains normal-path "..")
(begin
- (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir )
+ (debug:print-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir )
(exit 1)))
(if (not (string-contains targ-path target-dir))
(begin
- (debug:print 0 "ERROR: You cannot update data outside " target-dir ".")
+ (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".")
(exit 1)))
- (debug:print 0 "Path " targ-mk " is valid.")
+ (debug:print 0 *default-log-port* "Path " targ-mk " is valid.")
))
;; make directory in dest
;;
(define (sretrieve:mkdir configdat submitter target-dir targ-mk comment)
(let ((targ-path (conc target-dir "/" targ-mk)))
(if (file-exists? targ-path)
(begin
- (debug:print 0 "ERROR: target Directory " targ-path " already exist!!")
+ (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!")
(exit 1)))
(sretrieve:db-do
configdat
(lambda (db)
(sretrieve:register-action db "mkdir" submitter targ-mk comment)))
(let* ((th1 (make-thread
(lambda ()
(create-directory targ-path #t)
- (debug:print 0 " ... dir " targ-path " created"))
+ (debug:print 0 *default-log-port* " ... dir " targ-path " created"))
"mkdir thread"))
(th2 (make-thread
(lambda ()
(let loop ()
(thread-sleep! 15)
@@ -219,25 +303,25 @@
;;
(define (sretrieve:ln configdat submitter target-dir targ-link link-name comment)
(let ((targ-path (conc target-dir "/" link-name)))
(if (file-exists? targ-path)
(begin
- (debug:print 0 "ERROR: target file " targ-path " already exist!!")
+ (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!")
(exit 1)))
(if (not (file-exists? targ-link ))
(begin
- (debug:print 0 "ERROR: target file " targ-link " does not exist!!")
+ (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!")
(exit 1)))
(sretrieve:db-do
configdat
(lambda (db)
(sretrieve:register-action db "ln" submitter link-name comment)))
(let* ((th1 (make-thread
(lambda ()
(create-symbolic-link targ-link targ-path )
- (debug:print 0 " ... link " targ-path " created"))
+ (debug:print 0 *default-log-port* " ... link " targ-path " created"))
"symlink thread"))
(th2 (make-thread
(lambda ()
(let loop ()
(thread-sleep! 15)
@@ -255,20 +339,20 @@
;;
(define (sretrieve:rm configdat submitter target-dir targ-file comment)
(let ((targ-path (conc target-dir "/" targ-file)))
(if (not (file-exists? targ-path))
(begin
- (debug:print 0 "ERROR: target file " targ-path " not found, nothing to remove.")
+ (debug:print-error 0 *default-log-port* "target file " targ-path " not found, nothing to remove.")
(exit 1)))
(sretrieve:db-do
configdat
(lambda (db)
(sretrieve:register-action db "rm" submitter targ-file comment)))
(let* ((th1 (make-thread
(lambda ()
(delete-file targ-path)
- (debug:print 0 " ... file " targ-path " removed"))
+ (debug:print 0 *default-log-port* " ... file " targ-path " removed"))
"rm thread"))
(th2 (make-thread
(lambda ()
(let loop ()
(thread-sleep! 15)
@@ -308,11 +392,11 @@
(define (sretrieve:do-as-calling-user proc)
(let ((eid (current-effective-user-id))
(cid (current-user-id)))
(if (not (eq? eid cid)) ;; running suid
(set! (current-effective-user-id) cid))
- ;; (debug:print 0 "running as " (current-effective-user-id))
+ ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id))
(proc)
(if (not (eq? eid cid))
(set! (current-effective-user-id) eid))))
(define (sretrieve:find name paths)
@@ -328,10 +412,55 @@
(define (sretrieve:stderr-print . args)
(with-output-to-port (current-error-port)
(lambda ()
(apply print args))))
+
+;;======================================================================
+;; SHELL
+;;======================================================================
+
+(define (toplevel-command . args) #f)
+(define (sretrieve:shell)
+ (use readline)
+ (let* ((path '())
+ (prompt "> ")
+ (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18"))
+ (iport (make-readline-port prompt)))
+ (install-history-file) ;; [homedir] [filename] [nlines])
+ (with-input-from-port iport
+ (lambda ()
+ (let loop ((inl (read-line)))
+ (if (not (or (eof-object? inl)
+ (equal? inl "exit")))
+ (let* ((parts (string-split inl))
+ (cmd (if (null? parts) #f (car parts))))
+ (if (not cmd)
+ (loop (read-line))
+ (case (string->symbol cmd)
+ ((cd)
+ (if (> (length parts) 1) ;; have a parameter
+ (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths
+ (set! path '())))
+ ((ls)
+ (let* ((thepath (if (> (length parts) 1) ;; have a parameter
+ (cdr parts)
+ path))
+ (plen (length thepath)))
+ (cond
+ ((null? thepath)
+ (print (string-intersperse top-areas " ")))
+ ((and (< plen 2)
+ (member (car thepath) top-areas))
+ (system (conc "ls /p/fdk/gwa/" (car thepath))))
+ (else ;; have a long path
+ ;; check for access rights here
+ (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/")))))))
+ (else
+ (print "Got command: " inl))))
+ (loop (read-line)))))))))
+
;;======================================================================
;; MAIN
;;======================================================================
@@ -358,62 +487,86 @@
(if (file-exists? upstream-file)
(if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer
(> (file-modification-time upstream-file)(file-modification-time package-config)))
(handle-exceptions
exn
- (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config)
+ (debug:print-error 0 *default-log-port* "failed to run script " conversion-script " with params " upstream-file " " package-config)
(let ((pid (process-run conversion-script (list upstream-file package-config))))
(process-wait pid)))
- (debug:print 0 "Skipping update of " package-config " from " upstream-file))
- (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found"))
+ (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file))
+ (debug:print 0 *default-log-port* "Skipping update of " package-config " as " upstream-file " not found"))
;; (ini:property-separator-patt " * *")
;; (ini:property-separator #\space)
(let ((res (if (file-exists? package-config)
(begin
- (debug:print 0 "Reading package config " package-config)
+ (debug:print 0 *default-log-port* "Reading package config " package-config)
(read-config package-config #f #t))
(make-hash-table))))
(pop-directory)
res)))
(define (sretrieve:process-action configdat action . args)
(let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
(user (current-user-name))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
(allowed-users (string-split
(or (configf:lookup configdat "settings" "allowed-users")
"")))
(default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package
(if (not base-dir)
(begin
- (debug:print 0 "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!")
+ (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!")
(exit)))
(if (null? allowed-users)
(begin
- (debug:print 0 "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
+ (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!")
(exit)))
(if (not (member user allowed-users))
(begin
- (debug:print 0 "User \"" (current-user-name) "\" does not have access. Exiting")
+ (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting")
(exit 1)))
(case (string->symbol action)
((get)
(if (< (length args) 1)
(begin
- (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
(exit 1)))
(let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
(version (car args))
(msg (or (args:get-arg "-m") ""))
(package-type (or (args:get-arg "-package")
default-area))
(exe-dir (configf:lookup configdat "exe-info" "exe-dir")))
;; (relconfig (sretrieve:load-packages configdat exe-dir package-type)))
- (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout")
+ (debug:print 0 *default-log-port* "retrieving " version " of " package-type " as tar data on stdout")
(sretrieve:get configdat user version msg)))
- (else (debug:print 0 "Unrecognised command " action)))))
+ ((cp)
+ (if (< (length args) 1)
+ (begin
+ (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
+ (file (car args))
+ (msg (or (args:get-arg "-m") "")) )
+
+ (debug:print 0 *default-log-port* "copinging " file " to current directory " )
+ (sretrieve:cp configdat user file msg)))
+ ((ls)
+ (if (< (length args) 1)
+ (begin
+ (debug:print-error 0 *default-log-port* "Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
+ (dir (car args))
+ (msg (or (args:get-arg "-m") "")) )
+
+ (debug:print 0 *default-log-port* "Listing files in " )
+ (sretrieve:ls configdat user dir msg)))
+
+ (else (debug:print 0 *default-log-port* "Unrecognised command " action)))))
;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc")))
;; (if (file-exists? debugcontrolf)
;; (load debugcontrolf)))
@@ -442,23 +595,25 @@
(if base-dir
(begin
(print "Files in " base-dir)
(sretrieve:do-as-calling-user
(lambda ()
- (process-execute "/bin/ls" (list base-dir)))))
+ (process-execute "/bin/ls" (list "-lrt" base-dir)))))
(print "ERROR: No base dir specified!"))))
((log)
(sretrieve:db-do configdat (lambda (db)
(print "Logs : ")
(query (for-each-row
(lambda (row)
(apply print (intersperse row " | "))))
(sql db "SELECT * FROM actions")))))
+ ((shell)
+ (sretrieve:shell))
(else
(print "ERROR: Unrecognised command. Try \"sretrieve help\""))))
;; multi-word commands
((null? rema)(print sretrieve:help))
((>= (length rema) 2)
(apply sretrieve:process-action configdat (car rema)(cdr rema)))
- (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\"")))))
+ (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\"")))))
(main)
Index: synchash.scm
==================================================================
--- synchash.scm
+++ synchash.scm
@@ -71,11 +71,11 @@
(hash-table-set! synchash synckey myhash)))
(for-each
(lambda (item)
(let ((id (car item))
(dat (cadr item)))
- ;; (debug:print-info 2 "Processing item: " item)
+ ;; (debug:print-info 2 *default-log-port* "Processing item: " item)
(hash-table-set! myhash id dat)))
newdat)
(for-each
(lambda (id)
(hash-table-delete! myhash id))
@@ -85,11 +85,11 @@
(list newdat removs))) ;; synchash))
(define *synchashes* (make-hash-table))
(define (synchash:server-get dbstruct run-id proc synckey keynum params)
- ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params)
+ ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params)
(let* ((dbdat (db:get-db dbstruct run-id))
(db (db:dbdat-get-db dbdat))
(synchash (hash-table-ref/default *synchashes* synckey #f))
(newdat (apply (case proc
((db:get-runs) db:get-runs)
@@ -103,22 +103,22 @@
(make-indexed (lambda (x)
(list (vector-ref x keynum) x))))
;; Now process newdat based on the query type
(set! postdat (case proc
((db:get-runs)
- ;; (debug:print-info 2 "Get runs call")
+ ;; (debug:print-info 2 *default-log-port* "Get runs call")
(let ((header (vector-ref newdat 0))
(data (vector-ref newdat 1)))
- ;; (debug:print-info 2 "header: " header ", data: " data)
+ ;; (debug:print-info 2 *default-log-port* "header: " header ", data: " data)
(cons (list "header" header) ;; add the header keyed by the word "header"
(map make-indexed data)))) ;; add each element keyed by the keynum'th val
(else
- ;; (debug:print-info 2 "Non-get runs call")
+ ;; (debug:print-info 2 *default-log-port* "Non-get runs call")
(map make-indexed newdat))))
- ;; (debug:print-info 2 "postdat: " postdat)
+ ;; (debug:print-info 2 *default-log-port* "postdat: " postdat)
;; (if (not indb)(sqlite3:finalize! db))
(if (not synchash)
(begin
(set! synchash (make-hash-table))
(hash-table-set! *synchashes* synckey synchash)))
(synchash:get-delta postdat synchash)))
Index: task_records.scm
==================================================================
--- task_records.scm
+++ task_records.scm
@@ -15,12 +15,12 @@
(define-inline (tasks:task-get-action vec) (vector-ref vec 1))
(define-inline (tasks:task-get-owner vec) (vector-ref vec 2))
(define-inline (tasks:task-get-state vec) (vector-ref vec 3))
(define-inline (tasks:task-get-target vec) (vector-ref vec 4))
(define-inline (tasks:task-get-name vec) (vector-ref vec 5))
-(define-inline (tasks:task-get-test vec) (vector-ref vec 6))
-(define-inline (tasks:task-get-item vec) (vector-ref vec 7))
+(define-inline (tasks:task-get-testpatt vec) (vector-ref vec 6))
+(define-inline (tasks:task-get-keylock vec) (vector-ref vec 7))
(define-inline (tasks:task-get-params vec) (vector-ref vec 8))
(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9))
(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10))
(define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -25,27 +25,27 @@
;; wait up to aprox n seconds for a journal to go away
;;
(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f))
(if (not (string? path))
- (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)")
+ (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)")
(let ((fullpath (conc path "-journal")))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 " exn=" (condition->list exn))
- (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain")
#t) ;; if stuff goes wrong just allow it to move on
(let loop ((journal-exists (file-exists? fullpath))
(count n)) ;; wait ten times ...
(if journal-exists
(begin
(if (and waiting-msg
(eq? (modulo n 30) 0))
- (debug:print 0 waiting-msg))
+ (debug:print 0 *default-log-port* waiting-msg))
(if (> count 0)
(begin
(thread-sleep! 1)
(loop (file-exists? fullpath)
(- count 1)))
@@ -59,11 +59,11 @@
(configf:lookup *configdat* "setup" "dbdir")
(conc (configf:lookup *configdat* "setup" "linktree") "/.db"))))
(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)))
dbdir))
;; If file exists AND
@@ -81,18 +81,18 @@
(handle-exceptions
exn
(if (> numretries 0)
(begin
(print-call-chain (current-error-port))
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 " exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " exn=" (condition->list exn))
(thread-sleep! 1)
(tasks:open-db numretries (- numretries 1)))
(begin
(print-call-chain (current-error-port))
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 " exn=" (condition->list exn))))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " exn=" (condition->list exn))))
(let* ((dbpath (tasks:get-task-db-path))
(dbfile (conc dbpath "/monitor.db"))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (file-exists? dbpath))
(write-access (file-write-access? dbpath))
@@ -286,21 +286,21 @@
port))))))
(define (tasks:server-am-i-the-server? mdb run-id)
(let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id))
(first (if (null? all)
- #f;; (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.")
+ #f;; (begin (debug:print-error 0 *default-log-port* "no servers listed, should be at least one by now.")
;; (sqlite3:finalize! mdb)
;; (exit 1))
(car (db:get-rows all)))))
(if first
(let* ((header (db:get-header all))
(id (db:get-value-by-header first header "id"))
(hostname (db:get-value-by-header first header "hostname"))
(pid (db:get-value-by-header first header "pid"))
(priority (db:get-value-by-header first header "priority")))
- ;; (debug:print 0 "INFO: am-i-the-server got record " first)
+ ;; (debug:print 0 *default-log-port* "INFO: am-i-the-server got record " first)
;; for now a basic check. add tiebreaking by priority later
(if (and (equal? hostname (get-host-name))
(equal? pid (current-process-id)))
id
#f))
@@ -326,20 +326,20 @@
(best #f))
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
- (debug:print 0 "WARNING: tasks:get-server db access error.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 " for run " run-id)
+ (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* " for run " run-id)
(print-call-chain (current-error-port))
(if (> retries 0)
(begin
- (debug:print 0 " trying call to tasks:get-server again in 10 seconds")
+ (debug:print 0 *default-log-port* " trying call to tasks:get-server again in 10 seconds")
(thread-sleep! 10)
(tasks:get-server mdb run-id retries: (- retries 0)))
- (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\"")))
+ (debug:print 0 *default-log-port* "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\"")))
(sqlite3:for-each-row
(lambda (id interface port pubport transport pid hostname)
(set! res (vector id interface port pubport transport pid hostname)))
mdb
;; removed:
@@ -373,15 +373,15 @@
;; (maxqry (cdr (rmt:get-max-query-average run-id)))
;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10"))))
;; (cond
;; (forced
;; (if (common:low-noise-print 60 run-id "server required is set")
-;; (debug:print-info 0 "Server required is set, starting server for run-id " run-id "."))
+;; (debug:print-info 0 *default-log-port* "Server required is set, starting server for run-id " run-id "."))
;; #t)
;; ((> maxqry threshold)
;; (if (common:low-noise-print 60 run-id "Max query time execeeded")
-;; (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id "."))
+;; (debug:print-info 0 *default-log-port* "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id "."))
;; #t)
;; (else
;; #f))))
;; try to start a server and wait for it to be available
@@ -392,11 +392,11 @@
(delay-time 0))
(if (and (not server-dat)
(< delay-time delay-max-tries))
(begin
(if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)
- (debug:print 0 "Try starting server for run-id " run-id))
+ (debug:print 0 *default-log-port* "Try starting server for run-id " run-id))
(thread-sleep! (/ (random 2000) 1000))
(server:kind-run run-id)
(thread-sleep! (min delay-time 1))
(loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1))))))
@@ -424,11 +424,11 @@
(reverse res)))
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid)
- (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname)
+ (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(setenv "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill " pid))
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))
@@ -441,14 +441,14 @@
(if sdat
(let ((hostname (vector-ref sdat 6))
(pid (vector-ref sdat 5))
(server-id (vector-ref sdat 0)))
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
- (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
+ (debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
(tasks:kill-server hostname pid)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) )
- (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill"))
+ (debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill"))
;; (sqlite3:finalize! tdb)
))
;;======================================================================
;; M O N I T O R S
@@ -519,21 +519,21 @@
res))
;;
(define (tasks:start-monitor db mdb)
(if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
- (debug:print-info 1 "Not starting monitor, already have more than two running")
+ (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
(let* ((megatestdb (conc *toppath* "/megatest.db"))
(monitordbf (conc (db:dbfile-path #f) "/monitor.db"))
(last-db-update 0)) ;; (file-modification-time megatestdb)))
(task:register-monitor mdb)
(let loop ((count 0)
(next-touch 0)) ;; next-touch is the time where we need to update last_update
;; if the db has been modified we'd best look at the task queue
(let ((modtime (file-modification-time megatestdbpath )))
(if (> modtime last-db-update)
- (tasks:process-queue db mdb last-db-update megatestdb next-touch))
+ (tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
;; WARNING: Possible race conditon here!!
;; should this update be immediately after the task-get-action call above?
(if (> (current-seconds) next-touch)
(begin
(tasks:monitors-update mdb)
@@ -548,10 +548,21 @@
;;======================================================================
;; NOTE: It might be good to add one more layer of checking to ensure
;; that no task gets run in parallel.
+;; id INTEGER PRIMARY KEY,
+;; action TEXT DEFAULT '',
+;; owner TEXT,
+;; state TEXT DEFAULT 'new',
+;; target TEXT DEFAULT '',
+;; name TEXT DEFAULT '',
+;; testpatt TEXT DEFAULT '',
+;; keylock TEXT,
+;; params TEXT,
+;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
+;; execution_time TIMESTAMP);
;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
(db:with-db
@@ -645,10 +656,27 @@
;; WHERE
;; state IN " statesstr " AND
;; action IN " actionsstr
" ORDER BY creation_time DESC;"))
res))))
+
+(define (tasks:get-last dbstruct target runname)
+ (let ((res #f))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id . rem)
+ (set! res (apply vector id rem)))
+ db
+ (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
+ FROM tasks_queue
+ WHERE
+ target = ? AND name =?
+ ORDER BY creation_time DESC LIMIT 1;")
+ target runname)
+ res))))
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
(db:with-db
dbstruct #f #t
@@ -747,28 +775,28 @@
;;
(define (tasks:kill-runner target run-name testpatt)
(let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
(hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
(if (null? records)
- (debug:print 0 "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
- (debug:print 0 "Found " (length records) " run(s) to kill."))
+ (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
+ (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
(for-each
(lambda (record)
(let* ((param-key (list-ref record 8))
(match-dat (string-search hostpid-rx param-key)))
(if match-dat
(let ((hostname (cadr match-dat))
(pid (string->number (caddr match-dat))))
- (debug:print 0 "Sending SIGINT to process " pid " on host " hostname)
+ (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
(if (equal? (get-host-name) hostname)
(if (process:alive? pid)
(begin
(handle-exceptions
exn
(begin
- (debug:print 0 "Kill of process " pid " on host " hostname " failed.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
#t)
(process-signal pid signal/int)
(thread-sleep! 5)
(if (process:alive? pid)
(process-signal pid signal/kill)))))
@@ -778,11 +806,11 @@
(setenv "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill " pid))
(if old-targethost (setenv "TARGETHOST" old-targethost))
(unsetenv "TARGETHOST")
(unsetenv "TARGETHOST_LOGF"))))
- (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
+ (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
records)))
;; (define (tasks:start-run dbstruct mdb task)
;; (let ((flags (make-hash-table)))
;; (hash-table-set! flags "-rerun" "NOT_STARTED")
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -45,11 +45,11 @@
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
(define (open-test-db work-area)
- (debug:print-info 11 "open-test-db " work-area)
+ (debug:print-info 11 *default-log-port* "open-test-db " work-area)
(if (and work-area
(directory? work-area)
(file-read-access? work-area))
(let* ((dbpath (conc work-area "/testdat.db"))
(dbexists (file-exists? dbpath))
@@ -56,11 +56,11 @@
(work-area-writeable (file-write-access? work-area))
(db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
exn
(begin
(print-call-chain (current-error-port))
- (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
+ (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
((condition-property-accessor 'exn 'message) exn))
(set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
(sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
(if (or work-area-writeable
dbexists)
@@ -76,48 +76,48 @@
*db-write-access*)
(sqlite3:set-busy-handler! db handler))
(if (not dbexists)
(begin
(db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
- (debug:print-info 11 "Initialized test database " dbpath)
+ (debug:print-info 11 *default-log-port* "Initialized test database " dbpath)
(tdb:testdb-initialize db)))
;; (sqlite3:execute db "PRAGMA synchronous = 0;")
- (debug:print-info 11 "open-test-db END (sucessful)" work-area)
+ (debug:print-info 11 *default-log-port* "open-test-db END (sucessful)" work-area)
;; now let's test that everything is correct
(handle-exceptions
exn
(begin
(print-call-chain (current-error-port))
- (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
+ (debug:print-error 0 *default-log-port* "problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file "
dbpath ".\n "
((condition-property-accessor 'exn 'message) exn))
#f)
;; Is there a cheaper single line operation that will check for existance of a table
;; and raise an exception ?
(sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
db)
;; no work-area or not readable - create a placeholder to fake rest of world out
(let ((baddb (sqlite3:open-database ":memory:")))
- (debug:print-info 11 "open-test-db END (unsucessful)" work-area)
+ (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area)
;; provide an in-mem db (this is dangerous!)
(tdb:testdb-initialize baddb)
baddb)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
(let* ((test-path (if work-area
work-area
(rmt:test-get-rundir-from-test-id test-id))))
- (debug:print 3 "TEST PATH: " test-path)
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
(let* ((test-path (if work-area
work-area
(db:test-get-rundir-from-test-id dbstruct run-id test-id))))
- (debug:print 3 "TEST PATH: " test-path)
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
;; find and open the testdat.db file for an existing test
(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
(let* ((test-path (if work-area
@@ -125,11 +125,11 @@
(db:test-get-rundir-from-test-id dbstruct run-id test-id)))
(tdb (open-test-db test-path)))
(apply proc tdb params)))
(define (tdb:testdb-initialize db)
- (debug:print 11 "db:testdb-initialize START")
+ (debug:print 11 *default-log-port* "db:testdb-initialize START")
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (sqlcmd)
@@ -171,11 +171,11 @@
id INTEGER PRIMARY KEY,
var TEXT,
val TEXT,
ackstate INTEGER DEFAULT 0,
CONSTRAINT metadat_constraint UNIQUE (var));"))))
- (debug:print 11 "db:testdb-initialize END"))
+ (debug:print 11 *default-log-port* "db:testdb-initialize END"))
;; This routine moved to db:read-test-data
;;
(define (tdb:read-test-data tdb test-id categorypatt)
(let ((res '()))
@@ -208,11 +208,23 @@
;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data run-id test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
- (debug:print 4 lin)
+ (debug:print 4 *default-log-port* lin)
+ (rmt:csv->test-data run-id test-id lin)
+ (loop (read-line)))))
+ ;; roll up the current results.
+ ;; FIXME: Add the status too
+ (rmt:test-data-rollup run-id test-id #f))
+
+;; NOTE: Run this local with #f for db !!!
+(define (tdb:load-logpro-data run-id test-id)
+ (let loop ((lin (read-line)))
+ (if (not (eof-object? lin))
+ (begin
+ (debug:print 4 *default-log-port* lin)
(rmt:csv->test-data run-id test-id lin)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup run-id test-id #f))
@@ -234,17 +246,17 @@
;;
(define (tdb:get-steps-table steps);; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
- (debug:print 6 "step=" step)
+ (debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status Duration Logfile
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
+ (debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
@@ -258,11 +270,11 @@
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
+ (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
@@ -271,11 +283,11 @@
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
+ (debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
@@ -295,17 +307,17 @@
(define (tdb:get-steps-table-list steps)
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
- (debug:print 6 "step=" step)
+ (debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; stepname start end status
(vector (tdb:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
+ (debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
@@ -319,11 +331,11 @@
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
+ (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
@@ -332,11 +344,11 @@
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
+ (debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
@@ -383,7 +395,7 @@
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(sqlite3:finalize! tdb))
- (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
+ (debug:print 2 *default-log-port* "Can't update testdat.db for test " test-id " read-only or non-existant"))))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -47,11 +47,11 @@
(filter (lambda (d)
(if (directory-exists? d)
d
(begin
(if (common:low-noise-print 60 "tests:get-tests-search-path" d)
- (debug:print 0 "WARNING: problem with directory " d ", dropping it from tests path"))
+ (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
#f)))
(append paths (list (conc *toppath* "/tests"))))))
(define (tests:get-valid-tests test-registry tests-paths)
(if (null? tests-paths)
@@ -101,11 +101,11 @@
(tests:match (car itemmap) testname #f))
itemmaps)))
(if (null? best-matches)
#f
(let ((res (car best-matches)))
- ;; (debug:print 0 "res=" res)
+ ;; (debug:print 0 *default-log-port* "res=" res)
(cond
((string? res) res) ;;; FIX THE ROOT CAUSE HERE ....
((null? res) #f)
((string? (cdr res)) (cdr res)) ;; it is a pair
((string? (cadr res))(cadr res)) ;; it is a list
@@ -120,23 +120,23 @@
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
((procedure? items)
- (debug:print-info 4 "items is a procedure, will calc later")
+ (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
items) ;; calc later
((procedure? itemstable)
- (debug:print-info 4 "itemstable is a procedure, will calc later")
+ (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
itemstable) ;; calc later
((filter (lambda (x)
(let ((val (car x)))
(if (procedure? val) val #f)))
(append (if (list? items) items '())
(if (list? itemstable) itemstable '())))
'have-procedure)
((or (list? items)(list? itemstable)) ;; calc now
- (debug:print-info 4 "items and itemstable are lists, calc now\n"
+ (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config tconfig))
(else #f)))) ;; not iterated
@@ -145,50 +145,50 @@
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs)))
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
- (debug:print 0 "ERROR: non-existent required test \"" test-name "\"")
+ (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
(instr2 (if config
(config-lookup config "requirements" "waitor")
"")))
- (debug:print-info 8 "waitons string is " instr ", waitors string is " instr2)
+ (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
((procedure? instr) ;; here
(let ((res (instr)))
- (debug:print-info 8 "waiton procedure results in string " res " for test " test-name)
+ (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " test-name)
res))
((string? instr) instr)
(else
- ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name)
""))))
(newwaitors
(string-split (cond
((procedure? instr2)
(let ((res (instr2)))
- (debug:print-info 8 "waitor procedure results in string " res " for test " test-name)
+ (debug:print-info 8 *default-log-port* "waitor procedure results in string " res " for test " test-name)
res))
((string? instr2) instr2)
(else
- ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name)
"")))))
(values
;; the waitons
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
- (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
+ (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
#f)))
newwaitons)
(filter (lambda (x)
(if (hash-table-ref/default all-tests-registry x #f)
#t
(begin
- (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
+ (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x)
#f)))
newwaitors)
config)))))
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
@@ -302,29 +302,29 @@
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
(logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
(if (not (file-exists? test-rundir))
(begin
- (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver")
+ (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver")
#f)
(begin
(push-directory test-rundir)
(let ((result (if (null? waivers)
#f
(let loop ((hed (car waivers))
(tal (cdr waivers)))
- (debug:print 0 "INFO: Applying waiver rule \"" hed "\"")
+ (debug:print 0 *default-log-port* "INFO: Applying waiver rule \"" hed "\"")
(let* ((waiver (configf:lookup testconfig "waivers" hed))
(wparts (if waiver (string-match waiver-rx waiver) #f))
(waiver-rule (if wparts (cadr wparts) #f))
(waiver-glob (if wparts (caddr wparts) #f))
(logpro-file (if waiver
(let ((fname (conc hed ".logpro")))
(if (file-exists? fname)
fname
(begin
- (debug:print 0 "INFO: No logpro file " fname " falling back to diff")
+ (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff")
#f)))
#f))
;; if rule by name of waiver-rule is found in testconfig - use it
;; else if waivername.logpro exists use logpro-rule
;; else default to diff-rule
@@ -332,21 +332,21 @@
(if rule
rule
(if logpro-file
logpro-rule
(begin
- (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule")
+ (debug:print 0 *default-log-port* "INFO: No logpro file " logpro-file " found, using diff rule")
diff-rule)))))
;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t)
(processed-cmd (string-substitute
"%file1%" (conc test-rundir "/" waiver-glob)
(string-substitute
"%file2%" (conc prev-rundir "/" waiver-glob)
(string-substitute
"%waivername%" hed rule-string #t) #t) #t))
(res #f))
- (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"")
+ (debug:print 0 *default-log-port* "INFO: waiver command is \"" processed-cmd "\"")
(if (eq? (system processed-cmd) 0)
(if (null? tal)
#t
(loop (car tal)(cdr tal)))
#f))))))
@@ -377,11 +377,11 @@
(waived (if prev-test
(if prev-test ;; true if we found a previous test in this run series
(let ((prev-status (db:test-get-status prev-test))
(prev-state (db:test-get-state prev-test))
(prev-comment (db:test-get-comment prev-test)))
- (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
+ (debug:print 4 *default-log-port* "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
(if (and (equal? prev-state "COMPLETED")
(equal? prev-status "WAIVED"))
(if comment
comment
prev-comment) ;; waived is either the comment or #f
@@ -390,11 +390,11 @@
#f)))
(if (and waived
(tests:check-waiver-eligibility testdat prev-test))
(set! real-status "WAIVED"))
- (debug:print 4 "real-status " real-status ", waived " waived ", status " status)
+ (debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
@@ -423,11 +423,11 @@
(expected (hash-table-ref/default otherdat ":expected" #f))
(tol (hash-table-ref/default otherdat ":tol" #f))
(units (hash-table-ref/default otherdat ":units" ""))
(type (hash-table-ref/default otherdat ":type" ""))
(dcomment (hash-table-ref/default otherdat ":comment" "")))
- (debug:print 4
+ (debug:print 4 *default-log-port*
"category: " category ", variable: " variable ", value: " value
", expected: " expected ", tol: " tol ", units: " units)
(if (and value expected tol) ;; all three required
(let ((dat (conc category ","
variable ","
@@ -465,15 +465,15 @@
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(if (and (string? path)
(directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
(begin
- (debug:print 4 "Found path: " path)
+ (debug:print 4 *default-log-port* "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
- (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
- (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
+ (debug:print-error 0 *default-log-port* "summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
+ (debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(let ((my-start-time (current-seconds))
(lockf (conc outputfilename ".lock")))
@@ -494,11 +494,11 @@
;; didn't get the lock, check to see if current update started later than this
;; update, if so we can exit without doing any work
(if (> my-start-time (file-modification-time lockf))
;; we started since current re-gen in flight, delay a little and try again
(begin
- (debug:print-info 1 "Waiting to update " outputfilename ", another test currently updating it")
+ (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
(thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
(loop (common:simple-file-lock lockf))))))))))
(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
(let ((counts (make-hash-table))
@@ -579,17 +579,17 @@
;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
- (debug:print 6 "step=" step)
+ (debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
- ;; stepname start end status Duration Logfile
- (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
+ ;; stepname start end status Duration Logfile Comment
+ (vector (tdb:step-get-stepname step) "" "" "" "" "" ""))))
+ (debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
@@ -603,24 +603,28 @@
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
+ (debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
- (vector-set! record 5 (tdb:step-get-logfile step))))
+ (vector-set! record 5 (tdb:step-get-logfile step)))
+ (if (> (string-length (tdb:step-get-comment step))
+ 0)
+ (vector-set! record 6 (tdb:step-get-comment step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
- (vector-set! record 4 (tdb:step-get-event_time step))))
+ (vector-set! record 4 (tdb:step-get-event_time step))
+ (vector-set! record 6 (tdb:step-get-comment step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
+ (debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
@@ -631,17 +635,14 @@
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
-
-;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers)
+;;
;;
-(define (tests:get-compressed-steps dbstruct run-id test-id)
- (let* ((steps-data (if dbstruct
- (db:get-steps-for-test dbstruct run-id test-id)
- (rmt:get-steps-for-test run-id test-id)))
+(define (tests:get-compressed-steps run-id test-id)
+ (let* ((steps-data (rmt:get-steps-for-test run-id test-id))
(comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
@@ -649,11 +650,12 @@
(if (number? s)(seconds->time-string s) s))
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s))
(vector-ref x 3) ;; status
(vector-ref x 4)
- (vector-ref x 5))) ;; time delta
+ (vector-ref x 5) ;; time delta
+ (vector-ref x 6)))
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1)))
(if (and (number? time-a)(number? time-b))
@@ -675,11 +677,11 @@
(full-name (db:test-make-full-name test-name item-path))
(oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html")))
(status (db:test-get-status test-dat))
(color (common:get-color-from-status status))
(logf (db:test-get-final_logf test-dat))
- (steps-dat (tests:get-compressed-steps #f run-id test-id)))
+ (steps-dat (tests:get-compressed-steps run-id test-id)))
;; (dcommon:get-compressed-steps #f 1 30045)
;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))
(s:output-new
oup
@@ -753,22 +755,23 @@
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
(define (tests:get-test-path-from-environment)
- (and (getenv "MT_LINKTREE")
- (getenv "MT_TARGET")
- (getenv "MT_RUNNAME")
- (getenv "MT_TEST_NAME")
- (getenv "MT_ITEMPATH")
- (conc (getenv "MT_LINKTREE") "/"
- (getenv "MT_TARGET") "/"
- (getenv "MT_RUNNAME") "/"
- (getenv "MT_TEST_NAME") "/"
- (if (or (getenv "MT_ITEMPATH")
- (not (string=? "" (getenv "MT_ITEMPATH"))))
- (conc "/" (getenv "MT_ITEMPATH"))))))
+ (if (and (getenv "MT_LINKTREE")
+ (getenv "MT_TARGET")
+ (getenv "MT_RUNNAME")
+ (getenv "MT_TEST_NAME")
+ (getenv "MT_ITEMPATH"))
+ (conc (getenv "MT_LINKTREE") "/"
+ (getenv "MT_TARGET") "/"
+ (getenv "MT_RUNNAME") "/"
+ (getenv "MT_TEST_NAME") "/"
+ (if (or (getenv "MT_ITEMPATH")
+ (not (string=? "" (getenv "MT_ITEMPATH"))))
+ (conc "/" (getenv "MT_ITEMPATH"))))
+ #f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
@@ -803,27 +806,27 @@
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
- (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
+ (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
- (debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
+ (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(configf:write-alist tcfg tpath)))
tcfg))))))
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
(let* ((mungepriority (lambda (priority)
(if priority
(let ((tmp (any->number priority)))
- (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0)))
+ (if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0)))
0)))
(all-tests (hash-table-keys test-records))
(all-waited-on (let loop ((hed (car all-tests))
(tal (cdr all-tests))
(res '()))
@@ -844,35 +847,35 @@
(b-raw-pri (config-lookup b-config "requirements" "priority"))
(a-priority (mungepriority a-raw-pri))
(b-priority (mungepriority b-raw-pri)))
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
- ;; (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
+ ;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
(cond
;; is
((member a b-waitons) ;; is b waiting on a?
- ;; (debug:print 0 "case1")
+ ;; (debug:print 0 *default-log-port* "case1")
#t)
((member b a-waitons) ;; is a waiting on b?
- ;; (debug:print 0 "case2")
+ ;; (debug:print 0 *default-log-port* "case2")
#f)
((and (not (null? a-waitons)) ;; both have waitons - do not disturb
(not (null? b-waitons)))
- ;; (debug:print 0 "case2.1")
+ ;; (debug:print 0 *default-log-port* "case2.1")
#t)
((and (null? a-waitons) ;; no waitons for a but b has waitons
(not (null? b-waitons)))
- ;; (debug:print 0 "case3")
+ ;; (debug:print 0 *default-log-port* "case3")
#f)
((and (not (null? a-waitons)) ;; a has waitons but b does not
(null? b-waitons))
- ;; (debug:print 0 "case4")
+ ;; (debug:print 0 *default-log-port* "case4")
#t)
((not (eq? a-priority b-priority)) ;; use
(> a-priority b-priority))
(else
- ;; (debug:print 0 "case5")
+ ;; (debug:print 0 *default-log-port* "case5")
(string>? a b))))))
(sort-fn2
(lambda (a b)
(> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
@@ -1029,38 +1032,38 @@
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
- (debug:print-info 4 "hed=" hed " at top of loop")
+ (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
(let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
- (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
+ (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
- (debug:print-info 8 "waitons string is " instr)
+ (debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
((procedure? instr)
(let ((res (instr)))
- (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
+ (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed)
res))
((string? instr) instr)
(else
- ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
+ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " hed)
""))))))
(if (not config) ;; this is a non-existant test called in a waiton.
(if (null? tal)
test-records
(loop (car tal)(cdr tal)))
(begin
- (debug:print-info 8 "waitons: " waitons)
+ (debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member hed waitons)
(begin
- (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
+ (debug:print-error 0 *default-log-port* "test " hed " has listed itself as a waiton, please correct this!")
(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
;; (items (items:get-items-from-config config)))
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
@@ -1074,23 +1077,23 @@
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
;; otherwise return #f - this is not an iterated test
(cond
((procedure? items)
- (debug:print-info 4 "items is a procedure, will calc later")
+ (debug:print-info 4 *default-log-port* "items is a procedure, will calc later")
items) ;; calc later
((procedure? itemstable)
- (debug:print-info 4 "itemstable is a procedure, will calc later")
+ (debug:print-info 4 *default-log-port* "itemstable is a procedure, will calc later")
itemstable) ;; calc later
((filter (lambda (x)
(let ((val (car x)))
(if (procedure? val) val #f)))
(append (if (list? items) items '())
(if (list? itemstable) itemstable '())))
'have-procedure)
((or (list? items)(list? itemstable)) ;; calc now
- (debug:print-info 4 "items and itemstable are lists, calc now\n"
+ (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n"
" items: " items " itemstable: " itemstable)
(items:get-items-from-config config))
(else #f))) ;; not iterated
#f ;; itemsdat 5
#f ;; spare - used for item-path
@@ -1155,20 +1158,20 @@
(handle-exceptions
exn
(if (> remtries 0)
(begin
(print-call-chain (current-error-port))
- (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times")
+ (debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times")
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
- (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
- (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
+ (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))))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
)))
;;======================================================================
Index: tests/Makefile
==================================================================
--- tests/Makefile
+++ tests/Makefile
@@ -8,11 +8,11 @@
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"
RUNID := 1
SERVER =
DEBUG = 1
-LOGGING =
+LOGGING = -log logs/$(RUNNAME)
ROWS = 20
OS = $(shell grep ID /etc/*-release|cut -d= -f2)
FS = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)
@@ -21,11 +21,11 @@
NEWTARGET = "$(OS)/$(FS)/$(VER)"
TARGET = "ubuntu/nfs/none"
all : build unit test1 test2 test3 test4 test5 test6 test7 test8 test9
-unit : basicserver.log runs.log misc.log
+unit : basicserver.log runs.log misc.log tests.log
rel :
cd release;dashboard -rows 25 &
## basicserver.log : unittests/basicserver.scm
@@ -180,11 +180,11 @@
fullprep : cleanprep
cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
cd fullrun;$(BINPATH)/dashboard -rows 15 &
dashboard : cleanprep
- cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) &
+ cd fullrun && $(BINPATH)/dashboard -skip-version-check -rows $(ROWS) &
newdashboard : cleanprep
cd fullrun && $(BINPATH)/newdashboard &
mdboard : cleanprep
Index: tests/rununittest.sh
==================================================================
--- tests/rununittest.sh
+++ tests/rununittest.sh
@@ -13,8 +13,9 @@
dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db
rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db
rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir
mkdir -p simplelinks simpleruns
(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm)
+(cd simplerun;cp ../../altdb.scm .)
# Run the test $1 is the unit test to run
cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1
Index: tests/unittests/basicserver.scm
==================================================================
--- tests/unittests/basicserver.scm
+++ tests/unittests/basicserver.scm
@@ -7,11 +7,11 @@
;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
(delete-file* "logs/1.log")
(define run-id 1)
-(test "setup for run" #t (begin (launch:setup-for-run)
+(test "setup for run" #t (begin (launch:setup)
(string? (getenv "MT_RUN_AREA_HOME"))))
;; NON Server tests go here
(test #f #f (db:dbdat-get-path *db*))
@@ -179,11 +179,11 @@
;; ;; (test "launch server" #t (let ((pid (process-fork (lambda ()
;; ;; ;; (daemon:ize)
;; ;; (server:launch 'http)))))
;; ;; (set! server-pid pid)
;; ;; (number? pid)))
-;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
+;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &")
;;
;; (let loop ((n 10))
;; (thread-sleep! 1) ;; need to wait for server to start.
;; (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
;; (print "tasks:get-best-server returned " res)
Index: tests/unittests/tests.scm
==================================================================
--- tests/unittests/tests.scm
+++ tests/unittests/tests.scm
@@ -1,13 +1,80 @@
-;;======================================================================
-;; itemwait, itemmatch
-
-(db:compare-itempaths ref-item-path item-path itemmap)
-
-;; prereqs-not-met
-
-(rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
-
- (fails (runs:calc-fails prereqs-not-met))
- (prereq-fails (runs:calc-prereq-fail prereqs-not-met))
- (non-completed (runs:calc-not-completed prereqs-not-met))
- (runnables (runs:calc-runnable prereqs-not-met)))
+;; ;;======================================================================
+;; ;; itemwait, itemmatch
+;;
+;; (db:compare-itempaths ref-item-path item-path itemmap)
+;;
+;; ;; prereqs-not-met
+;;
+;; (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
+;;
+;; (fails (runs:calc-fails prereqs-not-met))
+;; (prereq-fails (runs:calc-prereq-fail prereqs-not-met))
+;; (non-completed (runs:calc-not-completed prereqs-not-met))
+;; (runnables (runs:calc-runnable prereqs-not-met)))
+;;
+;;
+;;
+
+(define user (current-user-name))
+(define runname "mytestrun")
+(define keys (rmt:get-keys))
+(define runinfo #f)
+(define keyvals '(("SYSTEM" "abc")("RELEASE" "def")))
+(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time"))
+(define run-id 1)
+
+;; Create a run
+(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user))
+(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" ""))
+(test #f #t (rmt:general-call 'register-test run-id run-id "test-two" ""))
+(test #f #t (rmt:general-call 'register-test run-id run-id "test-three" ""))
+(test #f #t (rmt:general-call 'register-test run-id run-id "test-four" ""))
+
+(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "")
+(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "")
+(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "")
+(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "")
+
+(print "MODE=not in")
+(test #f '()
+ (filter
+ (lambda (y)
+ (equal? y "FAIL")) ;; any FAIL in the output list?
+ (map
+ (lambda (x)(vector-ref x 4))
+ (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))))
+
+(print "MODE=in")
+(test #f '("FAIL")
+ (map
+ (lambda (x)(vector-ref x 4))
+ (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard)))
+(set! *verbosity* 1)
+
+(print "MODE=in, state in RUNNING")
+;; (set! *verbosity* 8)
+(test #f '("RUNNING")
+ (map
+ (lambda (x)(vector-ref x 3))
+ (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard)))
+(set! *verbosity* 1)
+
+(print "MODE=in, state in RUNNING and status IN WARN")
+;; (set! *verbosity* 8)
+(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN"))
+ (map
+ (lambda (x)
+ (cons (vector-ref x 3)(vector-ref x 4)))
+ (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard)))
+(set! *verbosity* 1)
+
+(print "MODE=not in, state in RUNNING and status IN WARN")
+(set! *verbosity* 8)
+(test #f '(("DELETED" . "n/a") ("COMPLETED" . "PASS") ("COMPLETED" . "FAIL"))
+ (map
+ (lambda (x)
+ (cons (vector-ref x 3)(vector-ref x 4)))
+ (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))
+(set! *verbosity* 1)
+
+(exit)
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -135,10 +135,10 @@
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id (cdr run-path))))
(if run-id
(begin
- (dboard:data-set-curr-run-id! *data* run-id)
+ (dboard:data-curr-run-id-set! *data* run-id)
(dashboard:update-run-summary-tab)))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
))))
|#
ADDED utils/Makefile.git.installall
Index: utils/Makefile.git.installall
==================================================================
--- /dev/null
+++ utils/Makefile.git.installall
@@ -0,0 +1,334 @@
+
+# Copyright 2013-2015 Matthew Welland.
+#
+# This program is made available under the GNU GPL version 2.0 or
+# greater. See the accompanying file COPYING for details.
+#
+# This program is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.
+
+help :
+ @echo You may need to do the following setup first:
+ @echo
+ @echo sudo apt-get install libreadline-dev
+ @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \
+ libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \
+ libwebkitgtk-3.0-dev
+ @echo -- nb// adding monodevelop gets more packages of which some might be needed...
+ @echo sudo apt-get install libmotif3
+ @echo
+ @echo Set up your PATH, setting it in the Makefile does not work as expected
+ @echo export PATH=$(PREFIX)/bin:\$$PATH
+ @echo
+ @echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
+ @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files
+ @echo You are using PREFIX=$(PREFIX)
+ @echo You are using PRODCHICKEN=$(PRODCHICKEN)
+ @echo You are using PROXY="$(PROXY)"
+ @echo If needed set PROXY to host.dom:port
+ @echo http_proxy=$(http_proxy)
+ @echo
+ @echo To make all do: make all
+ @echo make minimal: make nogui
+ @echo
+ @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG=
+
+FPIC=-C "-fPIC"
+
+# Put the installation here
+ifeq ($(PREFIX),)
+PREFIX=$(PWD)/target
+endif
+ifeq ($(PRODCHICKEN),)
+PRODCHICKEN=$(PREFIX)/prod-chicken/
+endif
+# Set this on the command line of your make call if needed: make PROXY=host.com:1234
+PROXY=
+
+# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+# Select version of chicken, sqlite3 etc
+CHICKEN_VERSION=4.10.1
+SQLITE3_VERSION=3090200
+# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
+# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
+# Override IUPBRANCH to use other than trunk
+IUPBRANCH=trunk
+IUPCONFIG=ubuntu-15.04.inc
+# iup-3.15
+
+# 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 sql-de-lite \
+ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
+ crypt parley
+
+#
+# Derived variables
+#
+
+ifeq ($(PROXY),)
+PROX:=
+else
+http_proxy:=http://$(PROXY)
+PROX:=-proxy $(PROXY)
+endif
+
+BUILDHOME=$(PWD)
+PATH:=$(PREFIX)/bin:$(PATH)
+LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
+LD_LIBRARY_PATH=$(LIBPATH)
+CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+
+VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
+
+vpath %.so $(CHICKEN_EGG_DIR)
+vpath %.flag eggflags
+
+EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS)))
+EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS)))
+
+# Stuff needed for IUP
+ISARCHX86_64=$(shell uname -a | grep x86_64)
+ifeq ($(ISARCHX86_64),)
+ARCHSIZE=
+else
+ARCHSIZE=64_
+endif
+
+CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
+CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
+# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
+
+nogui : base mutils
+
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
+
+base : chkn eggs
+
+# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
+# NOTE TO SELF: eggifying these would be great...
+mutils : base logprobin $(PREFIX)/bin/hs \
+ $(PREFIX)/lib/chicken/7/mutils.so \
+ $(PREFIX)/lib/chicken/7/dbi.so \
+ $(PREFIX)/lib/chicken/7/stml.so \
+ $(PREFIX)/lib/chicken/7/margs.so
+
+chkn : $(CHICKEN_INSTALL)
+
+eggs : $(EGGSOFILES)
+
+# libiup : $(PREFIX)/lib/libavcall.a
+libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so
+
+logprobin : $(PREFIX)/bin/logpro
+
+$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
+ $(CHICKEN_INSTALL) logpro
+
+# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
+$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
+ $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)
+
+$(EGGFLAGS) : # $(CHICKEN_INSTALL)
+ mkdir -p eggflags
+ touch $(EGGFLAGS)
+
+# some setup stuff
+#
+$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh)
+ (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh)
+
+$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
+ (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+
+chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
+ #tar xf chicken-$(CHICKEN_VERSION).tar.gz
+ #ln -sf chicken-$(CHICKEN_VERSION) chicken-core
+ echo "Hello from chicken"
+
+chicken-4.9.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
+
+chicken-4.9.0.1.tar.gz :
+ wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz
+
+chicken-4.10.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+
+chicken-4.10.0.tar.gz :
+ wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+
+chicken-4.10.1.tar.gz :
+ fossil clone https://www.kiatoa.com/fossils/chicken-core chicken-scheme.fossil
+ mkdir -p chicken-core
+ cd chicken-core; pwd
+ cd chicken-core; fossil open ../chicken-scheme.fossil
+ cd chicken-core; fossil up 337f5be
+# wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+
+# git clone git://code.call-cc.org/chicken-core
+# git clone http://code.call-cc.org/git/chicken-core.git
+
+$(PRODCHICKEN)/bin/chicken :
+ wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+ tar -xzvf chicken-4.10.1.tar.gz
+ cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN)
+ cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) install
+ rm -rfv chicken-4.10.1/
+
+$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh $(PRODCHICKEN)/bin/chicken
+ cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX)
+ cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) install
+
+#======================================================================
+# S Q L I T E 3
+#======================================================================
+# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz
+sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
+ wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+ tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
+ cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install
+
+$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3
+
+#======================================================================
+# N A N O M S G
+#======================================================================
+
+# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
+# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz
+
+nanomsg-0.6-beta.tar.gz :
+ wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz
+
+nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
+ tar xf nanomsg-0.6-beta.tar.gz
+
+$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
+ cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install
+
+$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg
+
+# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg
+
+#======================================================================
+# M A T T S U T I L S
+#======================================================================
+
+# opensrc
+
+opensrc.fossil :
+ fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+
+opensrc/histstore/histstore.scm : opensrc.fossil
+ mkdir -p opensrc
+ cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
+
+$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+ cd opensrc/mutils;chicken-install
+
+$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+ cd opensrc/dbi; sed -i -e 's/.*postgres.*/;;commented out/g' dbi.scm; chicken-install
+
+$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+ cd opensrc/margs;chicken-install
+
+opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
+ cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
+
+$(PREFIX)/bin/hs : opensrc/histstore/hs
+ cp -f opensrc/histstore/hs $(PREFIX)/bin/hs
+
+# stml
+stml.fossil :
+ fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
+
+# open touches the .fossil :(
+stml/requirements.scm.template : stml.fossil
+ mkdir -p stml
+ cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi
+
+stml/requirements.scm : stml/requirements.scm.template
+ cp stml/install.cfg.template stml/install.cfg
+ cp stml/requirements.scm.template stml/requirements.scm
+
+$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+ cd stml; sed -i -e "s#.*TARGDIR.*#TARGDIR=$(PREFIX)/bin#g" install.cfg
+ cd stml;CSC_OPTIONS='-C "-fPIC"' make
+
+#======================================================================
+# F F C A L L (Used by IUP)
+#======================================================================
+
+ffcall.fossil :
+ fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil
+
+ffcall/README : ffcall.fossil
+ mkdir -p ffcall
+ cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi
+
+# NOTE: This worked fine *without* the enable-shared
+#
+$(PREFIX)/lib/libavcall.a : ffcall/README
+ cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install
+
+#======================================================================
+# I U P
+#======================================================================
+
+iuplib.fossil :
+ #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
+ touch iuplib.fossil
+iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so
+ mkdir -p iup
+ pwd
+ wget -c --no-check-certificate http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ wget -c --no-check-certificate http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ wget -c --no-check-certificate http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+
+#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+# $(PREFIX)/lib/libiup.so : iup/iup/alldone
+# touch -c $(PREFIX)/lib/libiup.so
+
+$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
+
+# -feature disable-iup-web
+
+$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
+
+
+clean :
+ rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
Index: utils/Makefile.installall
==================================================================
--- utils/Makefile.installall
+++ utils/Makefile.installall
@@ -44,11 +44,12 @@
PROXY=
# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
# Select version of chicken, sqlite3 etc
-CHICKEN_VERSION=4.10.0
+# CHICKEN_VERSION=4.10.0
+CHICKEN_VERSION=4.11.0rc2
SQLITE3_VERSION=3090200
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
# Override IUPBRANCH to use other than trunk
IUPBRANCH=trunk
@@ -56,14 +57,14 @@
# iup-3.15
# 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 \
+ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars pathname-expand \
spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
- crypt
+ crypt parley
#
# Derived variables
#
@@ -77,11 +78,11 @@
BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
-CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/8
VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
vpath %.so $(CHICKEN_EGG_DIR)
vpath %.flag eggflags
@@ -101,21 +102,22 @@
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
nogui : base mutils
-all : nogui libiup $(PREFIX)/lib/sqlite3.so
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
base : chkn eggs
# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
# NOTE TO SELF: eggifying these would be great...
mutils : base logprobin $(PREFIX)/bin/hs \
- $(PREFIX)/lib/chicken/7/mutils.so \
- $(PREFIX)/lib/chicken/7/dbi.so \
- $(PREFIX)/lib/chicken/7/stml.so \
- $(PREFIX)/lib/chicken/7/margs.so
+ $(PREFIX)/lib/chicken/8/mutils.so \
+ $(PREFIX)/lib/chicken/8/dbi.so \
+ $(PREFIX)/lib/chicken/8/stml.so \
+ $(PREFIX)/lib/chicken/8/margs.so
chkn : $(CHICKEN_INSTALL)
eggs : $(EGGSOFILES)
@@ -145,14 +147,15 @@
$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
mkdir -p $(PREFIX)
(echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
(echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+# NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file
chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
tar xf chicken-$(CHICKEN_VERSION).tar.gz
ln -sf chicken-$(CHICKEN_VERSION) chicken-core
-
+ if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi
chicken-4.9.0rc1.tar.gz :
wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
chicken-4.9.0.1.tar.gz :
@@ -162,10 +165,13 @@
wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
chicken-4.10.0.tar.gz :
wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+chicken-4.11.0rc2.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz
+
# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git
$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh
cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
@@ -219,17 +225,17 @@
opensrc/histstore/histstore.scm : opensrc.fossil
mkdir -p opensrc
cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
-$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+$(PREFIX)/lib/chicken/8/mutils.so : opensrc/histstore/histstore.scm
cd opensrc/mutils;chicken-install
-$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+$(PREFIX)/lib/chicken/8/dbi.so : opensrc/dbi/dbi.scm
cd opensrc/dbi;chicken-install
-$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+$(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm
cd opensrc/margs;chicken-install
opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
@@ -247,11 +253,11 @@
stml/requirements.scm : stml/requirements.scm.template
cp stml/install.cfg.template stml/install.cfg
cp stml/requirements.scm.template stml/requirements.scm
-$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+$(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm
cd stml;make
#======================================================================
# F F C A L L (Used by IUP)
#======================================================================
@@ -273,29 +279,58 @@
#======================================================================
iuplib.fossil :
fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
-iup/installall.sh : iuplib.fossil
+cd-5.9_Linux26g4_64_lib.tar.gz :
+ wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ mv download cd-5.9_Linux26g4_64_lib.tar.gz
+
+iup-3.17_Linux26g4_64_lib.tar.gz :
+ wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ mv download iup-3.17_Linux26g4_64_lib.tar.gz
+
+im-3.10_Linux26g4_64_lib.tar.gz :
+ wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ mv download im-3.10_Linux26g4_64_lib.tar.gz
+
+lua-5.3.2_Linux26g4_64_lib.tar.gz :
+ wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ mv download lua-5.3.2_Linux26g4_64_lib.tar.gz
+
+iup/installall.sh : $(PREFIX)/lib/libiup.so \
+ cd-5.9_Linux26g4_64_lib.tar.gz \
+ iup-3.17_Linux26g4_64_lib.tar.gz \
+ im-3.10_Linux26g4_64_lib.tar.gz \
+ lua-5.3.2_Linux26g4_64_lib.tar.gz # iuplib.fossil
mkdir -p iup
- cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+ pwd
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
-iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
- cd iup && ./makeall.sh $(IUPCONFIG)
+iup/alldone : $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so # iup/makeall.sh
+# cd iup && ./makeall.sh $(IUPCONFIG)
$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
- cd iup && ./makeall.sh $(IUPCONFIG)
+# cd iup && ./makeall.sh $(IUPCONFIG)
# $(PREFIX)/lib/libiup.so : iup/iup/alldone
# touch -c $(PREFIX)/lib/libiup.so
$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
- LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks iup
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
# -feature disable-iup-web
$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
clean :
rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
ADDED utils/Makefile.latest.installall
Index: utils/Makefile.latest.installall
==================================================================
--- /dev/null
+++ utils/Makefile.latest.installall
@@ -0,0 +1,320 @@
+
+# Copyright 2013-2015 Matthew Welland.
+#
+# This program is made available under the GNU GPL version 2.0 or
+# greater. See the accompanying file COPYING for details.
+#
+# This program is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.
+
+help :
+ @echo You may need to do the following setup first:
+ @echo
+ @echo sudo apt-get install libreadline-dev
+ @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \
+ libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \
+ libwebkitgtk-3.0-dev
+ @echo -- nb// adding monodevelop gets more packages of which some might be needed...
+ @echo sudo apt-get install libmotif3
+ @echo
+ @echo Set up your PATH, setting it in the Makefile does not work as expected
+ @echo export PATH=$(PREFIX)/bin:\$$PATH
+ @echo
+ @echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
+ @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files
+ @echo You are using PREFIX=$(PREFIX)
+ @echo You are using PROXY="$(PROXY)"
+ @echo If needed set PROXY to host.dom:port
+ @echo http_proxy=$(http_proxy)
+ @echo
+ @echo To make all do: make all
+ @echo make minimal: make nogui
+ @echo
+ @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG=
+
+FPIC=-C "-fPIC"
+
+# Put the installation here
+ifeq ($(PREFIX),)
+PREFIX=$(PWD)/target
+endif
+
+# Set this on the command line of your make call if needed: make PROXY=host.com:1234
+PROXY=
+
+# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+# Select version of chicken, sqlite3 etc
+CHICKEN_VERSION=4.10.1
+SQLITE3_VERSION=3090200
+# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
+# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
+# Override IUPBRANCH to use other than trunk
+IUPBRANCH=trunk
+IUPCONFIG=ubuntu-15.04.inc
+# iup-3.15
+
+# 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 sql-de-lite \
+ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
+ crypt parley zlib shell udp loops foof-loop lazy-seq ansi-escape-sequences rfc3339 slice \
+ slice-utf8 scsh-process functional-lists srfi-101 uuid-lib filepath srfi-78 srfi-42 sexp-diff \
+ low-level-macros symbol-utils expand-full chicken-doc irc silex lalr lalr-driver sha1 refdb
+
+#
+# Derived variables
+#
+
+ifeq ($(PROXY),)
+PROX:=
+else
+http_proxy:=http://$(PROXY)
+PROX:=-proxy $(PROXY)
+endif
+
+BUILDHOME=$(PWD)
+PATH:=$(PREFIX)/bin:$(PATH)
+LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
+LD_LIBRARY_PATH=$(LIBPATH)
+CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+
+VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
+
+vpath %.so $(CHICKEN_EGG_DIR)
+vpath %.flag eggflags
+
+EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS)))
+EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS)))
+
+# Stuff needed for IUP
+ISARCHX86_64=$(shell uname -a | grep x86_64)
+ifeq ($(ISARCHX86_64),)
+ARCHSIZE=
+else
+ARCHSIZE=64_
+endif
+
+CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
+CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
+# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
+
+nogui : base mutils
+
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
+
+base : chkn eggs
+
+# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
+# NOTE TO SELF: eggifying these would be great...
+mutils : base logprobin $(PREFIX)/bin/hs \
+ $(PREFIX)/lib/chicken/7/mutils.so \
+ $(PREFIX)/lib/chicken/7/dbi.so \
+ $(PREFIX)/lib/chicken/7/stml.so \
+ $(PREFIX)/lib/chicken/7/margs.so
+
+chkn : $(CHICKEN_INSTALL)
+
+eggs : $(EGGSOFILES)
+
+# libiup : $(PREFIX)/lib/libavcall.a
+libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so
+
+logprobin : $(PREFIX)/bin/logpro
+
+$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
+ $(CHICKEN_INSTALL) logpro
+
+# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
+$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
+ $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)
+
+$(EGGFLAGS) : # $(CHICKEN_INSTALL)
+ mkdir -p eggflags
+ touch $(EGGFLAGS)
+
+# some setup stuff
+#
+$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh)
+ (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh)
+
+$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
+ (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+
+chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
+ tar xf chicken-$(CHICKEN_VERSION).tar.gz
+ ln -sf chicken-$(CHICKEN_VERSION) chicken-core
+
+
+chicken-4.9.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
+
+chicken-4.9.0.1.tar.gz :
+ wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz
+
+chicken-4.10.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+
+chicken-4.10.0.tar.gz :
+ wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+
+chicken-4.10.1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+
+# git clone git://code.call-cc.org/chicken-core
+# git clone http://code.call-cc.org/git/chicken-core.git
+
+$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh
+ cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
+ cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install
+
+#======================================================================
+# S Q L I T E 3
+#======================================================================
+# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz
+sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
+ wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+ tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
+ cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install
+
+$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3
+
+#======================================================================
+# N A N O M S G
+#======================================================================
+
+# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
+# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz
+
+nanomsg-0.6-beta.tar.gz :
+ wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz
+
+nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
+ tar xf nanomsg-0.6-beta.tar.gz
+
+$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
+ cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install
+
+$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg
+
+# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg
+
+#======================================================================
+# M A T T S U T I L S
+#======================================================================
+
+# opensrc
+
+opensrc.fossil :
+ fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+
+opensrc/histstore/histstore.scm : opensrc.fossil
+ mkdir -p opensrc
+ cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
+
+$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+ cd opensrc/mutils;chicken-install
+
+$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+ cd opensrc/dbi;chicken-install
+
+$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+ cd opensrc/margs;chicken-install
+
+opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
+ cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
+
+$(PREFIX)/bin/hs : opensrc/histstore/hs
+ cp -f opensrc/histstore/hs $(PREFIX)/bin/hs
+
+# stml
+stml.fossil :
+ fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
+
+# open touches the .fossil :(
+stml/requirements.scm.template : stml.fossil
+ mkdir -p stml
+ cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi
+
+stml/requirements.scm : stml/requirements.scm.template
+ cp stml/install.cfg.template stml/install.cfg
+ cp stml/requirements.scm.template stml/requirements.scm
+
+$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+ cd stml;make
+
+#======================================================================
+# F F C A L L (Used by IUP)
+#======================================================================
+
+ffcall.fossil :
+ fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil
+
+ffcall/README : ffcall.fossil
+ mkdir -p ffcall
+ cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi
+
+# NOTE: This worked fine *without* the enable-shared
+#
+$(PREFIX)/lib/libavcall.a : ffcall/README
+ cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install
+
+#======================================================================
+# I U P
+#======================================================================
+
+iuplib.fossil :
+ #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
+ touch iuplib.fossil
+iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so
+ mkdir -p iup
+ pwd
+ #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+
+#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+# $(PREFIX)/lib/libiup.so : iup/iup/alldone
+# touch -c $(PREFIX)/lib/libiup.so
+
+$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
+
+# -feature disable-iup-web
+
+$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
+
+
+clean :
+ rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
ADDED vg-test.scm
Index: vg-test.scm
==================================================================
--- /dev/null
+++ vg-test.scm
@@ -0,0 +1,98 @@
+(use canvas-draw iup foof-loop)
+(import canvas-draw-iup)
+
+(load "vg.scm")
+
+(define numtorun 1000)
+;; (if (> (length (argv)) 1)
+;; (string->number (cadr (argv)))
+;; 1000))
+
+ (use trace)
+ (trace
+ ;; vg:draw-rect
+ ;; vg:grow-rect
+ vg:get-extents-for-objs
+ vg:components-get-extents
+ vg:instances-get-extents
+ vg:get-extents-for-two-rects)
+
+(define d1 (vg:drawing-new))
+(define l1 (vg:lib-new))
+(define c1 (vg:comp-new))
+(define c2 (vg:comp-new))
+(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10"))
+
+(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20"))
+ (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10"))
+ (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10")))
+ (vg:add-objs-to-comp c1 r1 r2 t1 bt1))
+
+(loop ((for x (up-from 0 (to 20))))
+ (loop ((for y (up-from 0 (to 20))))
+ (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5)))))
+
+(let ((start (current-seconds)))
+ (let loop ((i 0))
+ (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100))
+ (if (< i numtorun)(loop (+ i 1))))
+ (print "Run time: " (- (current-seconds) start)))
+
+;; add the c1 component to lib l1 with name firstcomp
+(vg:add-comp-to-lib l1 "firstcomp" c1)
+(vg:add-comp-to-lib l1 "secondcomp" c2)
+
+;; add the l1 lib to drawing with name firstlib
+(vg:add-lib d1 "firstlib" l1)
+
+;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0
+(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0)
+(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200)
+
+;; (vg:drawing-scalex-set! d1 1.1)
+;; (vg:drawing-scaley-set! d1 0.5)
+
+;; (define xtnts (vg:scale-offset-xy
+;; (vg:component-get-extents c1)
+;; 1.1 1.1 -2 -2))
+
+;; get extents of c1 and put a rectange around it
+;;
+(define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1)))
+(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts))
+
+(define bt1xt (vg:obj-get-extents d1 bt1))
+(print "bt1xt: " bt1xt)
+(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt))
+
+;; get extents of all objects and put rectangle around it
+;;
+(define big-xtnts (vg:instances-get-extents d1))
+(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts))
+(vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0)
+
+(vg:drawing-scalex-set! d1 1.5)
+(vg:drawing-scaley-set! d1 1.5)
+
+(define cnv #f)
+(define the-cnv (canvas
+ #:size "500x400"
+ #:expand "YES"
+ #:scrollbar "YES"
+ #:posx "0.5"
+ #:posy "0.5"
+ #:action (make-canvas-action
+ (lambda (c xadj yadj)
+ (set! cnv c)))))
+
+(show
+ (dialog
+ (vbox
+ the-cnv)))
+
+(vg:drawing-cnv-set! d1 cnv)
+(vg:draw d1 #t)
+
+;; (canvas-rectangle! cnv 10 100 10 80)
+
+(main-loop)
ADDED vg.scm
Index: vg.scm
==================================================================
--- /dev/null
+++ vg.scm
@@ -0,0 +1,642 @@
+;;
+;; Copyright 2016 Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use defstruct srfi-1)
+
+(declare (unit vg))
+(use canvas-draw iup)
+(import canvas-draw-iup)
+
+(include "vg_records.scm")
+
+;; ;; structs
+;; ;;
+;; (defstruct vg:lib comps)
+;; (defstruct vg:comp objs name file)
+;; ;; extents caches extents calculated on draw
+;; ;; proc is called on draw and takes the obj itself as a parameter
+;; ;; attrib is an alist of parameters
+;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc)
+;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
+;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst
+
+;; inits
+;;
+(define (vg:comp-new)
+ (make-vg:comp objs: '() name: #f file: #f))
+
+(define (vg:lib-new)
+ (make-vg:lib comps: (make-hash-table)))
+
+(define (vg:drawing-new)
+ (make-vg:drawing scalex: 1
+ scaley: 1
+ xoff: 0
+ yoff: 0
+ libs: (make-hash-table)
+ insts: (make-hash-table)
+ cache: '()))
+
+;;======================================================================
+;; scaling and offsets
+;;======================================================================
+
+(define-inline (vg:scale-offset val s o)
+ (+ o (* val s)))
+ ;; (* (+ o val) s))
+
+;; apply scale and offset to a list of x y values
+;;
+(define (vg:scale-offset-xy lstxy sx sy ox oy)
+ (if (> (length lstxy) 1) ;; have at least one xy pair
+ (let loop ((x (car lstxy))
+ (y (cadr lstxy))
+ (tal (cddr lstxy))
+ (res '()))
+ (let ((newres (cons (vg:scale-offset y sy oy)
+ (cons (vg:scale-offset x sx ox)
+ res))))
+ (if (> (length tal) 1)
+ (loop (car tal)(cadr tal)(cddr tal) newres)
+ (reverse newres))))
+ '()))
+
+;; apply drawing offset and scaling to the points in lstxy
+;;
+(define (vg:drawing-apply-scale drawing lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:drawing-scalex drawing)
+ (vg:drawing-scaley drawing)
+ (vg:drawing-xoff drawing)
+ (vg:drawing-yoff drawing)))
+
+;; apply instance offset and scaling to the points in lstxy
+;;
+(define (vg:inst-apply-scale inst lstxy)
+ (vg:scale-offset-xy
+ lstxy
+ (vg:inst-scalex inst)
+ (vg:inst-scaley inst)
+ (vg:inst-xoff inst)
+ (vg:inst-yoff inst)))
+
+;; apply both drawing and instance scaling to a list of xy points
+;;
+(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy)
+ (vg:drawing-apply-scale
+ drawing
+ (vg:inst-apply-scale inst lstxy)))
+
+;;======================================================================
+;; objects
+;;======================================================================
+
+;; (vg:inst-apply-scale
+;; inst
+;; (vg:drawing-apply-scale drawing lstxy)))
+
+;; make a rectangle obj
+;;
+(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents))
+
+;; make a rectangle obj
+;;
+(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f))
+ (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents))
+
+;; make a text obj
+;;
+(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f)
+ (angle #f)(scale-with-zoom #f)(font #f)
+ (font-size #f))
+ (make-vg:obj type: 't pts: (list x1 y1) text: text
+ line-color: line-color fill-color: fill-color
+ angle: angle font: font extents: #f
+ attributes: (vg:make-attrib 'font-size font-size)))
+
+;; proc takes startnum and endnum and yields scalef, per-grad and unitname
+;;
+(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f))
+ (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc))
+
+;;======================================================================
+;; obj modifiers and queries
+;;======================================================================
+
+;; get extents, use knowledge of type ...
+;;
+(define (vg:obj-get-extents drawing obj)
+ (let ((type (vg:obj-type obj)))
+ (case type
+ ((r)(vg:rect-get-extents obj))
+ ((t)(vg:draw-text drawing obj draw: #f))
+ (else #f))))
+
+(define (vg:rect-get-extents obj)
+ (vg:obj-pts obj)) ;; extents are just the points for a rectangle
+
+(define (vg:grow-rect borderx bordery x1 y1 x2 y2)
+ (list
+ (- x1 borderx)
+ (- y1 bordery)
+ (+ x2 borderx)
+ (+ y2 bordery)))
+
+(define (vg:make-attrib . attrib-list)
+ #f)
+
+;;======================================================================
+;; components
+;;======================================================================
+
+;; add obj to comp
+;;
+(define (vg:add-objs-to-comp comp . objs)
+ (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs)))
+
+(define (vg:add-obj-to-comp comp obj)
+ (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp))))
+
+;; use the struct. leave this here to remind of this!
+;;
+;; (define (vg:comp-get-objs comp)
+;; (vg:comp-objs comp))
+
+;; add comp to lib
+;;
+(define (vg:add-comp-to-lib lib compname comp)
+ (hash-table-set! (vg:lib-comps lib) compname comp))
+
+;; instanciate component in drawing
+;;
+(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f))
+ (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) )
+ (hash-table-set! (vg:drawing-insts drawing) instname inst)))
+
+(define (vg:instance-move drawing instname newx newy)
+ (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname)))
+ (vg:inst-xoff-set! inst newx)
+ (vg:inst-yoff-set! inst newy)))
+
+;; get component from drawing (look in apropriate lib) given libname and compname
+(define (vg:get-component drawing libname compname)
+ (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname))
+ (inst (hash-table-ref (vg:lib-comps lib) compname)))
+ inst))
+
+(define (vg:get-extents-for-objs drawing objs)
+ (if (or (not objs)
+ (null? objs))
+ #f
+ (let loop ((hed (car objs))
+ (tal (cdr objs))
+ (extents (vg:obj-get-extents drawing (car objs))))
+ (let ((newextents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:obj-get-extents drawing hed))))
+ (if (null? tal)
+ extents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;; (let ((extents #f))
+;; (for-each
+;; (lambda (obj)
+;; (set! extents
+;; (vg:get-extents-for-two-rects
+;; extents
+;; (vg:obj-get-extents drawing obj))))
+;; objs)
+;; extents))
+
+;; given rectangles r1 and r2, return the box that bounds both
+;;
+(define (vg:get-extents-for-two-rects r1 r2)
+ (if (not r1)
+ r2
+ (if (not r2)
+ r1 ;; #f ;; no extents from #f #f
+ (list (min (car r1)(car r2)) ;; llx
+ (min (cadr r1)(cadr r2)) ;; lly
+ (max (caddr r1)(caddr r2)) ;; ulx
+ (max (cadddr r1)(cadddr r2)))))) ;; uly
+
+(define (vg:components-get-extents drawing . comps)
+ (if (null? comps)
+ #f
+ (let loop ((hed (car comps))
+ (tal (cdr comps))
+ (extents #f))
+ (let* ((objs (vg:comp-objs hed))
+ (newextents (if extents
+ (vg:get-extents-for-two-rects
+ extents
+ (vg:get-extents-for-objs drawing objs))
+ (vg:get-extents-for-objs drawing objs))))
+ (if (null? tal)
+ newextents
+ (loop (car tal)(cdr tal) newextents))))))
+
+;;======================================================================
+;; libraries
+;;======================================================================
+
+;; register lib with drawing
+
+;;
+(define (vg:add-lib drawing libname lib)
+ (hash-table-set! (vg:drawing-libs drawing) libname lib))
+
+(define (vg:get-lib drawing libname)
+ (hash-table-ref/default (vg:drawing-libs drawing) libname #f))
+
+(define (vg:get/create-lib drawing libname)
+ (let ((lib (vg:get-lib drawing libname)))
+ (if lib
+ lib
+ (let ((newlib (vg:lib-new)))
+ (vg:add-lib drawing libname newlib)
+ newlib))))
+
+;;======================================================================
+;; map objects given offset, scale and mirror, resulting obj is displayed
+;;======================================================================
+
+;; dispatch the drawing of obj off to the correct drawing routine
+;;
+(define (vg:map-obj drawing inst obj)
+ (case (vg:obj-type obj)
+ ((l)(vg:map-line drawing inst obj))
+ ((r)(vg:map-rect drawing inst obj))
+ ((t)(vg:map-text drawing inst obj))
+ ((x)(vg:map-xaxis drawing inst obj))
+ (else #f)))
+
+;; given a drawing and a inst map a rectangle to it screen coordinates
+;;
+(define (vg:map-rect drawing inst obj)
+ (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy?
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-line drawing inst obj)
+ (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;; given a drawing and a inst map a text to it screen coordinates
+;;
+(define (vg:map-text drawing inst obj)
+ (let ((res (make-vg:obj type: 't
+ fill-color: (vg:obj-fill-color obj)
+ text: (vg:obj-text obj)
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)
+ angle: (vg:obj-angle obj)
+ attrib: (vg:obj-attrib obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing)))
+ res))
+
+;; given a drawing and a inst map a line to it screen coordinates
+;;
+(define (vg:map-xaxis drawing inst obj)
+ (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy?
+ line-color: (vg:obj-line-color obj)
+ font: (vg:obj-font obj)))
+ (pts (vg:obj-pts obj)))
+ (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts))
+ (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) ))
+ res))
+
+;;======================================================================
+;; instances
+;;======================================================================
+
+(define (vg:instances-get-extents drawing . instance-names)
+ (let ((xtnt-lst (vg:draw drawing #f)))
+ (if (null? xtnt-lst)
+ #f
+ (let loop ((extents (car xtnt-lst))
+ (tal (cdr xtnt-lst))
+ (llx #f)
+ (lly #f)
+ (ulx #f)
+ (uly #f))
+ (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0)))
+ (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1)))
+ (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2)))
+ (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3))))
+ (if (null? tal)
+ (list llx lly ulx uly)
+ (loop (car tal)(cdr tal) nllx nlly nulx nuly)))))))
+
+(define (vg:lib-get-component lib instname)
+ (hash-table-ref/default (vg:lib-comps lib) instname #f))
+
+;;======================================================================
+;; color
+;;======================================================================
+
+(define (vg:rgb->number r g b #!key (a 0))
+ (bitwise-ior
+ (arithmetic-shift a 24)
+ (arithmetic-shift r 16)
+ (arithmetic-shift g 8)
+ b))
+
+(define (vg:iup-color->number iup-color)
+ (apply vg:rgb->number (map string->number (string-split iup-color))))
+
+;;======================================================================
+;; graphing
+;;======================================================================
+
+(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc)
+ (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2)))
+ #f))
+
+;;======================================================================
+;; Unravel and draw the objects
+;;======================================================================
+
+;; with get-extents = #t return the extents
+;; with draw = #f don't actually draw the object
+;;
+(define (vg:draw-obj drawing obj #!key (draw #t))
+ ;; (print "obj type: " (vg:obj-type obj))
+ (case (vg:obj-type obj)
+ ((r)(vg:draw-rect drawing obj draw: draw))
+ ((t)(vg:draw-text drawing obj draw: draw))))
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-rect drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ (if fill-color
+ (begin
+ (canvas-foreground-set! cnv fill-color)
+ (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-rectangle! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax)))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts ;; no text
+ (if (and text-xmax text-ymax) ;; have text
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-line drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-xaxis drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ ;; (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (llx (car pts))
+ (lly (cadr pts))
+ (ulx (caddr pts))
+ (uly (cadddr pts))
+ (w (- ulx llx))
+ (h (- uly lly))
+ (text-xmax #f)
+ (text-ymax #f))
+ (if draw
+ (let ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv)))
+ ;; (if fill-color
+ ;; (begin
+ ;; (canvas-foreground-set! cnv fill-color)
+ ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (canvas-line! cnv llx ulx lly uly)
+ (canvas-foreground-set! cnv prev-foreground-color)
+ (if text
+ (let* ((prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv (+ 2 llx)(+ 2 lly) text)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (set! text-xmax xmax)(set! text-ymax ymax))
+ (if font-changed (canvas-font-set! cnv prev-font))))))
+ (print "text-xmax: " text-xmax " text-ymax: " text-ymax)
+ (if (vg:obj-extents obj)
+ (vg:obj-extents obj)
+ (if (not text)
+ pts
+ (if (and text-xmax text-ymax)
+ (let ((xt (list llx lly
+ (max ulx (+ llx text-xmax))
+ (max uly (+ lly text-ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt)
+ (if cnv
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (let ((xt (list llx lly
+ (max ulx (+ llx xmax))
+ (max uly (+ lly ymax)))))
+ (vg:obj-extents-set! obj xt)
+ xt))
+ pts)))))) ;; return extents
+
+;; given a rect obj draw it on the canvas applying first the drawing
+;; scale and offset
+;;
+(define (vg:draw-text drawing obj #!key (draw #t))
+ (let* ((cnv (vg:drawing-cnv drawing))
+ (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj)))
+ (text (vg:obj-text obj))
+ (font (vg:obj-font obj))
+ (fill-color (vg:obj-fill-color obj))
+ (line-color (vg:obj-line-color obj))
+ (llx (car pts))
+ (lly (cadr pts)))
+ (if draw
+ (let* ((prev-background-color (canvas-background cnv))
+ (prev-foreground-color (canvas-foreground cnv))
+ (prev-font (canvas-font cnv))
+ (font-changed (and font (not (equal? font prev-font)))))
+ (if line-color
+ (canvas-foreground-set! cnv line-color)
+ (if fill-color
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if font-changed (canvas-font-set! cnv font))
+ (canvas-text! cnv llx lly text)
+ ;; NOTE: we do not set the font back!!
+ (canvas-foreground-set! cnv prev-foreground-color)))
+ (if cnv
+ (if (eq? draw 'get-extents)
+ (let-values (((xmax ymax)(canvas-text-size cnv text)))
+ (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated?
+ (append pts pts))
+ (append pts pts))))
+
+(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '()))
+ (let* ((libname (vg:inst-libname inst))
+ (compname (vg:inst-compname inst))
+ (comp (vg:get-component drawing libname compname))
+ (objs (vg:comp-objs comp)))
+ ;; (print "comp: " comp)
+ (if (null? objs)
+ prev-extents
+ (let loop ((obj (car objs))
+ (tal (cdr objs))
+ (res prev-extents))
+ (let* ((obj-xfrmd (vg:map-obj drawing inst obj))
+ (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
+
+(define (vg:draw drawing draw-mode . instnames)
+ (let* ((insts (vg:drawing-insts drawing))
+ (all-inst-names (hash-table-keys insts))
+ (master-list (if (null? instnames)
+ all-inst-names
+ instnames)))
+ (if (null? master-list)
+ '()
+ (let loop ((instname (car master-list))
+ (tal (cdr master-list))
+ (res '()))
+ (let* ((inst (hash-table-ref/default insts instname #f))
+ (newres (if inst
+ (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res)
+ res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres)))))))
ADDED vg_records.scm
Index: vg_records.scm
==================================================================
--- /dev/null
+++ vg_records.scm
@@ -0,0 +1,153 @@
+;; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead
+;; Generated using make-vector-record -safe vg lib comps
+
+(use simple-exceptions)
+(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
+(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
+(define (make-vg:lib #!key
+ (comps #f)
+ )
+ (vector 'vg:lib comps))
+
+(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
+
+(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
+;; Generated using make-vector-record -safe vg comp objs name file
+
+(use simple-exceptions)
+(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
+(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
+(define (make-vg:comp #!key
+ (objs #f)
+ (name #f)
+ (file #f)
+ )
+ (vector 'vg:comp objs name file))
+
+(define-inline (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
+(define-inline (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
+(define-inline (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
+
+(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
+(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
+(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
+;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
+
+(use simple-exceptions)
+(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
+(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
+(define (make-vg:obj #!key
+ (type #f)
+ (pts #f)
+ (fill-color #f)
+ (text #f)
+ (line-color #f)
+ (call-back #f)
+ (angle #f)
+ (font #f)
+ (attrib #f)
+ (extents #f)
+ (proc #f)
+ )
+ (vector 'vg:obj type pts fill-color text line-color call-back angle font attrib extents proc))
+
+(define-inline (vg:obj-type vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 1)(raise (vg:obj-exn 'vg:obj-type 'xpr))))
+(define-inline (vg:obj-pts vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 2)(raise (vg:obj-exn 'vg:obj-pts 'xpr))))
+(define-inline (vg:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 3)(raise (vg:obj-exn 'vg:obj-fill-color 'xpr))))
+(define-inline (vg:obj-text vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 4)(raise (vg:obj-exn 'vg:obj-text 'xpr))))
+(define-inline (vg:obj-line-color vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 5)(raise (vg:obj-exn 'vg:obj-line-color 'xpr))))
+(define-inline (vg:obj-call-back vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 6)(raise (vg:obj-exn 'vg:obj-call-back 'xpr))))
+(define-inline (vg:obj-angle vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 7)(raise (vg:obj-exn 'vg:obj-angle 'xpr))))
+(define-inline (vg:obj-font vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 8)(raise (vg:obj-exn 'vg:obj-font 'xpr))))
+(define-inline (vg:obj-attrib vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 9)(raise (vg:obj-exn 'vg:obj-attrib 'xpr))))
+(define-inline (vg:obj-extents vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 10)(raise (vg:obj-exn 'vg:obj-extents 'xpr))))
+(define-inline (vg:obj-proc vec)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-ref vec 11)(raise (vg:obj-exn 'vg:obj-proc 'xpr))))
+
+(define-inline (vg:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 1 val)(raise (vg:obj-exn 'type))))
+(define-inline (vg:obj-pts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 2 val)(raise (vg:obj-exn 'pts))))
+(define-inline (vg:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 3 val)(raise (vg:obj-exn 'fill-color))))
+(define-inline (vg:obj-text-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 4 val)(raise (vg:obj-exn 'text))))
+(define-inline (vg:obj-line-color-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 5 val)(raise (vg:obj-exn 'line-color))))
+(define-inline (vg:obj-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 6 val)(raise (vg:obj-exn 'call-back))))
+(define-inline (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
+(define-inline (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
+(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
+(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
+(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
+;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
+
+(use simple-exceptions)
+(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
+(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
+(define (make-vg:inst #!key
+ (libname #f)
+ (compname #f)
+ (theta #f)
+ (xoff #f)
+ (yoff #f)
+ (scalex #f)
+ (scaley #f)
+ (mirrx #f)
+ (mirry #f)
+ (call-back #f)
+ (cache #f)
+ )
+ (vector 'vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache))
+
+(define-inline (vg:inst-libname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 1)(raise (vg:inst-exn 'vg:inst-libname 'xpr))))
+(define-inline (vg:inst-compname vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 2)(raise (vg:inst-exn 'vg:inst-compname 'xpr))))
+(define-inline (vg:inst-theta vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 3)(raise (vg:inst-exn 'vg:inst-theta 'xpr))))
+(define-inline (vg:inst-xoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 4)(raise (vg:inst-exn 'vg:inst-xoff 'xpr))))
+(define-inline (vg:inst-yoff vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 5)(raise (vg:inst-exn 'vg:inst-yoff 'xpr))))
+(define-inline (vg:inst-scalex vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 6)(raise (vg:inst-exn 'vg:inst-scalex 'xpr))))
+(define-inline (vg:inst-scaley vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 7)(raise (vg:inst-exn 'vg:inst-scaley 'xpr))))
+(define-inline (vg:inst-mirrx vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 8)(raise (vg:inst-exn 'vg:inst-mirrx 'xpr))))
+(define-inline (vg:inst-mirry vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 9)(raise (vg:inst-exn 'vg:inst-mirry 'xpr))))
+(define-inline (vg:inst-call-back vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 10)(raise (vg:inst-exn 'vg:inst-call-back 'xpr))))
+(define-inline (vg:inst-cache vec)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-ref vec 11)(raise (vg:inst-exn 'vg:inst-cache 'xpr))))
+
+(define-inline (vg:inst-libname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 1 val)(raise (vg:inst-exn 'libname))))
+(define-inline (vg:inst-compname-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 2 val)(raise (vg:inst-exn 'compname))))
+(define-inline (vg:inst-theta-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 3 val)(raise (vg:inst-exn 'theta))))
+(define-inline (vg:inst-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 4 val)(raise (vg:inst-exn 'xoff))))
+(define-inline (vg:inst-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 5 val)(raise (vg:inst-exn 'yoff))))
+(define-inline (vg:inst-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 6 val)(raise (vg:inst-exn 'scalex))))
+(define-inline (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
+(define-inline (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
+(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
+(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
+(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
+;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
+
+(use simple-exceptions)
+(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
+(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
+(define (make-vg:drawing #!key
+ (libs #f)
+ (insts #f)
+ (scalex #f)
+ (scaley #f)
+ (xoff #f)
+ (yoff #f)
+ (cnv #f)
+ (cache #f)
+ )
+ (vector 'vg:drawing libs insts scalex scaley xoff yoff cnv cache))
+
+(define-inline (vg:drawing-libs vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 1)(raise (vg:drawing-exn 'vg:drawing-libs 'xpr))))
+(define-inline (vg:drawing-insts vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 2)(raise (vg:drawing-exn 'vg:drawing-insts 'xpr))))
+(define-inline (vg:drawing-scalex vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 3)(raise (vg:drawing-exn 'vg:drawing-scalex 'xpr))))
+(define-inline (vg:drawing-scaley vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 4)(raise (vg:drawing-exn 'vg:drawing-scaley 'xpr))))
+(define-inline (vg:drawing-xoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 5)(raise (vg:drawing-exn 'vg:drawing-xoff 'xpr))))
+(define-inline (vg:drawing-yoff vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 6)(raise (vg:drawing-exn 'vg:drawing-yoff 'xpr))))
+(define-inline (vg:drawing-cnv vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 7)(raise (vg:drawing-exn 'vg:drawing-cnv 'xpr))))
+(define-inline (vg:drawing-cache vec)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-ref vec 8)(raise (vg:drawing-exn 'vg:drawing-cache 'xpr))))
+
+(define-inline (vg:drawing-libs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 1 val)(raise (vg:drawing-exn 'libs))))
+(define-inline (vg:drawing-insts-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 2 val)(raise (vg:drawing-exn 'insts))))
+(define-inline (vg:drawing-scalex-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 3 val)(raise (vg:drawing-exn 'scalex))))
+(define-inline (vg:drawing-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 4 val)(raise (vg:drawing-exn 'scaley))))
+(define-inline (vg:drawing-xoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 5 val)(raise (vg:drawing-exn 'xoff))))
+(define-inline (vg:drawing-yoff-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 6 val)(raise (vg:drawing-exn 'yoff))))
+(define-inline (vg:drawing-cnv-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 7 val)(raise (vg:drawing-exn 'cnv))))
+(define-inline (vg:drawing-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:drawing)(vector-set! vec 8 val)(raise (vg:drawing-exn 'cache))))