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,32 +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
@@ -167,12 +168,21 @@
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
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
@@ -202,29 +212,29 @@
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
@@ -248,6 +258,6 @@
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: 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))
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -29,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)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -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))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -14,11 +14,11 @@
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
@@ -30,10 +30,11 @@
(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))
@@ -40,26 +41,29 @@
(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
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
- -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
- -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"
@@ -75,10 +79,11 @@
"-guimonitor"
"-main"
"-v"
"-q"
"-use-local"
+ "-skip-version-check"
)
args:arg-hash
0))
(if (args:get-arg "-h")
@@ -113,70 +118,127 @@
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
-(define (dboard:common-get-tabdat commondat)
+(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(hash-table-ref/default
(dboard:commondat-tabdats commondat)
- (dboard:commondat-curr-tab-num 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
- allruns
- allruns-by-id
- buttondat
- command
- command-tb
- curr-run-id
- curr-test-ids
- db
- dbdir
- dbfpath
- dbkeys
- filters-changed
- header
- hide-empty-runs
- hide-not-hide ;; toggle for hide/not hide
- hide-not-hide-button
- item-test-names
- keys
- last-db-update
- logs-textbox
- monitor-db-path
- num-tests
- numruns
- path-run-ids
- ro
- run-keys
- run-name
- runs
- runs-listbox
- runs-matrix
- runs-tree
- searchpatts
- start-run-offset
- start-test-offset
- state-ignore-hash
- states
- status-ignore-hash
- statuses
- target
- test-patts
- tests
- tests-tree
- tot-runs
-;; uidat
- updater-for-runs
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns 16) : number) ;;
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list)
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f)
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update 0) : number) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+
+ tests-tree ;; used in newdashboard
)
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
@@ -184,37 +246,14 @@
(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)))
+ (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: '()
- 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
- num-tests: 15
- numruns: 16
- path-run-ids: (make-hash-table)
- run-ids: (make-hash-table)
- run-keys: (make-hash-table)
- searchpatts: (make-hash-table)
- start-run-offset: 0
- start-test-offset: 0
- state-ignore-hash: (make-hash-table)
- status-ignore-hash: (make-hash-table)
- )))
+ (let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
@@ -228,44 +267,80 @@
(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
+;; data for runs, tests etc. was used in run summary?
;;
-(defstruct dboard:rundat
+(defstruct dboard:runsdat
;; new system
runs-index ;; target/runname => colnum
tests-index ;; testname/itempath => rownum
matrix-dat ;; vector of vectors rows/cols
)
-(define (dboard:rundat-make-init)
- (make-dboard:rundat
+(define (dboard:runsdat-make-init)
+ (make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
+;; used to keep the rundata from rmt:get-tests-for-run
+;; in sync.
+;;
+(defstruct dboard:rundat
+ run
+ tests-drawn ;; list of id's already drawn on screen
+ tests-notdrawn ;; list of id's NOT already drawn
+ rowsused ;; hash of lists covering what areas used - replace with quadtree
+ hierdat ;; put hierarchial sorted list here
+ tests ;; hash of id => testdat
+ tests-by-name ;; hash of testfullname => testdat
+ key-vals
+ last-update ;; last query to db got records from before last-update
+ data-changed
+ )
+
+(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began
+ (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
+ data-changed: #t
+ ))
+
+(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 (dboard:rundat-get-col-num dat target runname force-set)
- (let* ((runs-index (dboard: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 (dboard:rundat-get-row-num dat testname itempath force-set)
- (let* ((tests-index (dboard: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
@@ -273,19 +348,19 @@
(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 (dboard:rundat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
- (let* ((col-num (dboard:rundat-get-col-num dat target runname force-set))
- (row-num (dboard: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 (dboard:testdat
id: test-id
state: state
status: status)))
- (sparse-array-set! (dboard:rundat-matrix-dat dat) col-num row-num tdat)
+ (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat)
tdat)
#f)))
(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
@@ -381,10 +456,14 @@
(if same-time
(string>? test-name1 test-name2)
test1-older))))
;; 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))
@@ -391,76 +470,108 @@
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath))
- (prev-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) 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 (rmt:get-tests-for-run run-id testnamepatt states statuses
- #f #f
- (dboard:tabdat-hide-not-hide tabdat)
- sort-by
- sort-order
- 'shortlist
- (if (dboard:tabdat-filters-changed tabdat)
- 0
- last-update)
- *dashboard-mode*)) ;; use dashboard mode
- (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 (dboard:tabdat-filters-changed tabdat)
- tmptests
- (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 dboard:compare-tests)
- newdat))))
- (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured.
- ;; (debug:print 0 *default-log-port* "(dboard:get-tests-for-run-duplicate: filters-changed=" (dboard:tabdat-filters-changed tabdat) " last-update=" last-update " got " (length tmptests) " test records for run " run-id)
- tests))
-
+ ;; note: the rundat is normally created in "update-rundat".
+ (run-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
+ (if rec
+ rec
+ (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
+ rd))))
+ ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
+ (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3))
+ (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)))
+ (dboard:rundat-data-changed-set! run-dat #t)
+ (if (equal? state "DELETED")
+ (hash-table-delete! tests-ht test-id)
+ (hash-table-set! tests-ht test-id tdat))))
+ tmptests)
+ (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* ((referenced-run-ids '())
- (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) 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))
- (result '())
- (maxtests 0))
+ (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 (rmt:get-key-vals run-id))
- (tests (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))
- ;; 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? tests))
+ (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
- (set! referenced-run-ids (cons run-id referenced-run-ids))
- (if (> (length tests) maxtests)
- (set! maxtests (length tests)))
- (if (or (not (dboard:tabdat-hide-empty-runs tabdat)) ;; this reduces the data burden when set
- (not (null? tests)))
- (let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
- (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id dstruct)
- (set! result (cons dstruct result))))))))
- runs)
-
- (dboard:tabdat-header-set! tabdat header)
- (dboard:tabdat-allruns-set! tabdat result)
- (debug:print-info 6 *default-log-port* "(dboard:tabdat-allruns tabdat) has " (length (dboard:tabdat-allruns tabdat)) " runs")
- maxtests))
+ (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 (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
@@ -598,10 +709,13 @@
(let ((newres (append res (hash-table-ref tests hed))))
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres))))))))
+;; 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))
@@ -610,41 +724,47 @@
(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 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)
+ ;; 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 (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
(update-labels uidat)
(for-each
(lambda (rundat)
- (if (not rundat) ;; handle padded runs
+ (if (or (not rundat) ;; handle padded runs
+ (not (dboard:rundat-run rundat)))
;; ;; 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) "") (dboard:tabdat-keys tabdat)))));; 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 (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")))
+ (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)
@@ -658,31 +778,34 @@
(let ((rown 0)
(columndat (vector-ref table coln)))
(for-each
(lambda (testname)
(let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (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))
+ (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))
@@ -690,11 +813,11 @@
(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)))
@@ -770,53 +893,63 @@
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
-(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
+(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
+ (key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (rmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
- (all-targets (append db-targets
- (map (lambda (x)
- (list->vector
- (take (append (string-split x "/")
- (make-list (length header) "na"))
- (length header))))
- runconf-targs)))
+ (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
+ (list->vector
+ (take (append (string-split x "/")
+ (make-list (length header) "na"))
+ (length header)))))
+ (all-targets (append (list (munge-target (string-intersperse
+ (map (lambda (x) "%") header)
+ "/")))
+ db-targets
+ (map munge-target
+ runconf-targs)
+ ))
(key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
+ (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes))
(let loop ((key (car header))
(remkeys (cdr header))
(refvals '())
(indx 0)
(lbs '()))
(let* ((lb (let ((lb (list-ref key-listboxes indx)))
(if lb
lb
(iup:listbox
- #:size "45x50"
+ #:size "x60"
#:fontsize "10"
#:expand "YES" ;; "VERTICAL"
;; #:dropdown "YES"
#:editbox "YES"
#:action (lambda (obj a b c)
- (action-proc))
- #:caret_cb (lambda (obj a b c)(action-proc))
+ (debug:catch-and-dump action-proc "update-target-selector"))
+ #:caret_cb (lambda (obj a b c)
+ (debug:catch-and-dump action-proc "update-target-selector"))
))))
;; loop though all the targets and build the list for this dropdown
(selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
(if (null? remkeys)
;; return a list of the listbox items and an iup:hbox with the labels and listboxes
- (let ((listboxes (append lbs (list lb))))
- (list listboxes
- (map (lambda (htxt lb)
- (iup:vbox
- (iup:label htxt)
- lb))
- header
- listboxes)))
+ (let* ((listboxes (append lbs (list lb)))
+ (res (list listboxes
+ (map (lambda (htxt lb)
+ (iup:vbox
+ (iup:label htxt)
+ lb))
+ header
+ listboxes))))
+ (dboard:tabdat-key-listboxes-set! tabdat res)
+ res)
(loop (car remkeys)
(cdr remkeys)
(append refvals (list selected-value))
(+ indx 1)
(append lbs (list lb))))))))
@@ -828,17 +961,21 @@
(let ((alltgls (make-hash-table)))
(apply iup:vbox
(map (lambda (item)
(iup:toggle
item
+ #:fontsize 8
#:expand "YES"
#:action (lambda (obj tstate)
- (if (eq? tstate 0)
- (hash-table-delete! alltgls item)
- (hash-table-set! alltgls item #t))
- (let ((all (hash-table-keys alltgls)))
- (proc all)))))
+ (debug:catch-and-dump
+ (lambda ()
+ (if (eq? tstate 0)
+ (hash-table-delete! alltgls item)
+ (hash-table-set! alltgls item #t))
+ (let ((all (hash-table-keys alltgls)))
+ (proc all)))
+ "text-list-toggle-box"))))
items))))
;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
@@ -911,33 +1048,35 @@
;;======================================================================
;;
;; A gui for launching tests
;;
-(define (dashboard:run-controls commondat tabdat)
+(define (dboard:target-updater tabdat) ;; key-listboxes)
+ (let ((targ (map (lambda (x)
+ (iup:attribute x "VALUE"))
+ (car (dashboard:update-target-selector tabdat))))
+ (curr-runname (dboard:tabdat-run-name tabdat)))
+ (dboard:tabdat-target-set! tabdat targ)
+ ;; (if (dboard:tabdat-updater-for-runs tabdat)
+ ;; ((dboard:tabdat-updater-for-runs tabdat)))
+ (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
+ (equal? (dboard:tabdat-run-name tabdat) ""))
+ (dboard:tabdat-run-name-set! tabdat curr-runname))
+ (dashboard:update-run-command tabdat)))
+
+(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 "-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))))
- (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))))
+ ;;; (key-listboxes #f)
+ (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
+ (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
@@ -955,13 +1094,13 @@
;; Target, testpatt, state and status input boxes
;;
(iup:vbox
;; Command to run, placed over the top of the canvas
- (dcommon:command-action-selector tabdat)
- (dcommon:command-runname-selector tabdat tabdat)
- (dcommon:command-testname-selector tabdat tabdat update-keyvals key-listboxes))
+ (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
@@ -975,74 +1114,422 @@
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
-(define (dashboard:run-times commondat tabdat)
- (let* ((tabdat tabdat) ;; (dboard:tabdat-make-data)) ;; (make-vector 25 #f))
- (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 "-run")
- (cmdln "")
- (runlogs (make-hash-table))
- (key-listboxes #f)
- (updater-for-runs (dboard:tabdat-updater-for-runs tabdat))
+(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")))
+ (key-listboxes #f) ;;
(update-keyvals (lambda ()
- (let ((targ (map (lambda (x)
- (iup:attribute x "VALUE"))
- (car (dashboard:update-target-selector key-listboxes))))
- (curr-runname (dboard:tabdat-run-name tabdat)))
- (dboard:tabdat-target-set! tabdat targ)
- (if updater-for-runs (updater-for-runs))
- (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 (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
+ (dboard:target-updater tabdat))))
+ (dboard:tabdat-drawing-set! tabdat drawing)
+ (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 150
+ (iup:vbox
+ (let* ((tb (iup:treebox
+ #:value 0
+ #:name "Runs"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ (dboard:tabdat-target-set! 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:hbox
+ (iup:toggle
+ "Compact layout"
+ #:fontsize 8
+ #:expand "YES"
+ #:value 1
+ #:action (lambda (obj tstate)
+ (debug:catch-and-dump
+ (lambda ()
+ (print "tstate: " tstate)
+ (if (eq? tstate 0)
+ (dboard:tabdat-compact-layout-set! tabdat #f)
+ (dboard:tabdat-compact-layout-set! tabdat #t))
+ (dboard:tabdat-last-filter-str-set! tabdat "")
+ )
+ "text-list-toggle-box"))))
+ (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
+ (dcommon:command-testname-selector commondat tabdat update-keyvals))
+ (iup:vbox
+ (let* ((cnv-obj (iup:canvas
+ ;; #:size "500x400"
+ #:expand "YES"
+ #:scrollbar "YES"
+ #:posx "0.5"
+ #:posy "0.5"
+ #:action (make-canvas-action
+ (lambda (c xadj yadj)
+ (debug:catch-and-dump
+ (lambda ()
+ (if (not (dboard:tabdat-cnv tabdat))
+ (let ((cnv (dboard:tabdat-cnv tabdat)))
+ (dboard:tabdat-cnv-set! tabdat c)
+ (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)
+ (dboard:tabdat-cnv tabdat))))
+ (let ((drawing (dboard:tabdat-drawing tabdat))
+ (old-xadj (dboard:tabdat-xadj tabdat))
+ (old-yadj (dboard:tabdat-yadj tabdat)))
+ (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj)))
+ (begin
+ (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5)))
+ (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5)))
+ ))))
+ "iup:canvas action")))
+ #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((drawing (dboard:tabdat-drawing tabdat))
+ (scalex (vg:drawing-scalex drawing)))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex)
+ (vg:drawing-scalex-set! drawing
+ (+ scalex
+ (if (> step 0)
+ (* scalex 0.02)
+ (* scalex -0.02))))))
+ "wheel-cb"))
+ )))
+ cnv-obj)))))
+
+;;======================================================================
+;; 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
- (dcommon:command-execution-control tabdat)
(iup:split
- #:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 200
- ;; (iup:split
- ;; #:value 300
-
- ;; Target, testpatt, state and status input boxes
- ;;
+ #: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
- ;; Command to run, placed over the top of the canvas
- (dcommon:command-action-selector tabdat)
- (dcommon:command-runname-selector tabdat tabdat)
- (dcommon:command-testname-selector tabdat 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))
- )))
+ (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 tabdat)
- (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"
@@ -1054,11 +1541,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
@@ -1066,11 +1553,11 @@
;; (iup:frame
;; #:title "Disks Areas"
(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
(iup:frame
#:title "Run statistics"
- (dcommon:run-stats tabdat)))))
+ (dcommon:run-stats commondat tabdat tab-num: tab-num)))))
;;======================================================================
;; R U N
;;======================================================================
;;
@@ -1079,22 +1566,22 @@
(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 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-state-ignore-hash tabdat)) ;; '()
(hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
- #f #f
- (dboard:tabdat-hide-not-hide tabdat)
- #f #f
- "id,testname,item_path,state,status"
+ #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
@@ -1106,13 +1593,151 @@
(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)
+(define (dashboard:one-run commondat tabdat #!key (tab-num #f))
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
@@ -1122,11 +1747,12 @@
(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))
+ ;; (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
@@ -1136,128 +1762,23 @@
(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)))))
- (updater (lambda ()
- (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)
- ;; (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"))))))
-
- (set! dashboard:update-run-summary-tab updater)
+ (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 commondat tabdat)
+(define (dashboard:new-view db commondat tabdat #!key (tab-num #f))
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
@@ -1267,11 +1788,12 @@
(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-new-view-tab))
+ ;; (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
@@ -1281,119 +1803,119 @@
(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)))))
- (updater (lambda ()
- (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"))))))
-
- (set! dashboard:update-new-view-tab updater)
+ (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)))
@@ -1408,32 +1930,38 @@
#:title "filter test and items"
(iup:hbox
(iup:vbox
(iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
#:action (lambda (obj unk val)
- (mark-for-update tabdat)
- (update-search commondat tabdat "test-name" 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)
- (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))))
+ (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))
@@ -1478,11 +2006,11 @@
(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
@@ -1609,11 +2137,12 @@
" " tconfig " &")))
(system cmd))))
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
- (let* ((runs-dat (dboard:tabdat-make-data))
+ (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))
@@ -1639,12 +2168,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 tabdat)
- (update-search commondat tabdat 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 '()))
@@ -1768,18 +2297,21 @@
;; controls
))
;; (data (dboard:tabdat-init (make-d:data)))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:commondat-curr-tab-num-set! commondat curr))
- (dashboard:summary runs-dat)
+ (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 commondat onerun-dat)
- ;; (dashboard:new-view db data new-view-dat)
- (dashboard:run-controls commondat runcontrols-dat)
- (dashboard:run-times commondat runtimes-dat)
+ (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")
@@ -1789,15 +2321,15 @@
;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
;; 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 runs-dat)
+ (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 3 runtimes-dat)
+ (dboard:common-set-tabdat! commondat 4 runtimes-dat)
(iup:vbox
tabs
controls))))
(vector keycol lftcol header runsvec)))
@@ -1844,54 +2376,613 @@
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(apply max (map (lambda (filen)
(file-modification-time filen))
(glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
-(define (dashboard:run-update x commondat)
- (let* ((tabdat (dboard:common-get-tabdat commondat))) ;; uses curr-tab-num
- (if tabdat ;; if there is no tabdat then likely we are in a test control panel, no update calls needed
- (let* ((monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
- (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!!
- (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
- (file-modification-time monitor-db-path)
- -1))
- (run-update-time (current-seconds))
- (uidat (dboard:commondat-uidat commondat))
- (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat))))
- (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 (dboard:commondat-curr-tab-num commondat)
- ((0)
- (if dashboard:update-summary-tab (dashboard:update-summary-tab)))
- ((1) ;; The runs table is active
- (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))
- (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
- ((2)
- (dashboard:update-run-summary-tab))
- ((3)
- (dashboard:update-new-view-tab))
- (else
- (let ((updater (dboard:common-get-tabdat commondat)))
- (if updater (updater)))))
- (dboard:commondat-please-update-set! commondat #f)
- (dboard:tabdat-last-db-update-set! tabdat modtime)
- (set! *last-recalc-ended-time* (current-milliseconds))))))))
+(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)
+ #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")
+ (if (dboard:tabdat-keys tabdat) ;; have keys yet?
+ (let* ((num-keys (length (dboard:tabdat-keys tabdat)))
+ (targpatt (map (lambda (k v)
+ (list k v))
+ (dboard:tabdat-keys tabdat)
+ (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
+ '("%" "%"))
+ (make-list num-keys "%"))
+ num-keys)
+ ))
+ (runpatt (if (dboard:tabdat-target tabdat)
+ (last (dboard:tabdat-target tabdat))
+ "%"))
+ (testpatt (or (dboard:tabdat-test-patts tabdat) "%"))
+ (filtrstr (conc targpatt "/" runpatt "/" testpatt)))
+ (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt)
+
+ (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
+ (let ((dwg (dboard:tabdat-drawing tabdat)))
+ (print "reseting drawing")
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (vg:drawing-libs-set! dwg (make-hash-table))
+ (vg:drawing-insts-set! dwg (make-hash-table))
+ (vg:drawing-cache-set! dwg '())
+ (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
+ ;; (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-max-row-set! tabdat 0)
+ (dboard:tabdat-last-filter-str-set! tabdat filtrstr)))
+ (update-rundat tabdat
+ runpatt
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
+ 10 ;; (dboard:tabdat-numruns tabdat)
+ testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
+
+ targpatt
+
+ ;; old method
+ ;; (let ((res '()))
+ ;; (for-each (lambda (key)
+ ;; (if (not (equal? key "runname"))
+ ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
+ ;; (if val (set! res (cons (list key val) res))))))
+ ;; (dboard:tabdat-dbkeys tabdat))
+ ;; res)
+ )))))
+
+;; run times canvas updater
+;;
+(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
+ (let ((cnv (dboard:tabdat-cnv tabdat))
+ (dwg (dboard:tabdat-drawing tabdat))
+ (mtx (dboard:tabdat-runs-mutex tabdat))
+ (vch (dboard:tabdat-view-changed tabdat)))
+ (if (and cnv dwg vch)
+ (begin
+ (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
+ (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
+ (mutex-lock! mtx)
+ (canvas-clear! cnv)
+ (vg:draw dwg tabdat)
+ (mutex-unlock! mtx)
+ (dboard:tabdat-view-changed-set! tabdat #f)))))
+
+;; doesn't work.
+;;
+;;(define (gotoescape tabdat escape)
+;; (or (dboard:tabdat-layout-update-ok tabdat)
+;; (escape #t)))
+
+(define (dboard:graph-db-open dbstr)
+ (let* ((parts (string-split dbstr ":"))
+ (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
+ dbstr
+ (if (equal? (car parts) "sqlite3")
+ (cadr parts)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
+ #f)))))
+ (if (and dbpth (file-read-access? dbpth))
+ (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ db)
+ #f)))
+
+;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
+;;
+(define (dboard:graph-read-data cmdstring tstart tend)
+ (let* ((parts (string-split cmdstring))) ;; spaces not allowed
+ (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ...
+ (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring)
+ (let* ((dbdef (list-ref parts 0))
+ (tablen (list-ref parts 1))
+ (timef (list-ref parts 2))
+ (varfn (list-ref parts 3))
+ (valfn (list-ref parts 4))
+ (fields (cdr (cddddr parts)))
+ (db (dboard:graph-db-open dbdef))
+ (res-ht (make-hash-table)))
+ (if db
+ (begin
+ (for-each
+ (lambda (fieldname) ;; fields
+ (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC"))
+ (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
+ (print "all-dat-qrystr: " all-dat-qrystr)
+ (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res t var val)
+ (cons (vector t var val) res))
+ '() db all-dat-qrystr)))
+ (let ((zeropt (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-row db all-dat-qrystr))))
+ (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
+ (hash-table-set! res-ht
+ fieldname
+ (cons
+ (apply vector tstart (cdr zeropt))
+ (hash-table-ref/default res-ht fieldname '())))))))
+ fields)
+ res-ht)
+ #f)))))
+
+;; graph data
+;; tsc=timescale, tfn=function; time->x
+;;
+(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin)
+ (let* ((dwg (dboard:tabdat-drawing tabdat))
+ (lib (vg:get/create-lib dwg "runslib"))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (dur (- tstart tend)) ;; time duration
+ (cmp (vg:get-component dwg "runslib" compname))
+ (cfg (configf:get-section *configdat* "graph"))
+ (stdcolor (vg:rgb->number 120 130 140)))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj llx lly ulx uly))
+ (for-each
+ (lambda (cf)
+ (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend)))
+ (if alldat
+ (for-each
+ (lambda (fieldn)
+ (let* ((dat (hash-table-ref alldat fieldn ))
+ (vals (map (lambda (x)(vector-ref x 2)) dat)))
+ (if (not (null? vals))
+ (let* ((maxval (apply max vals))
+ (minval (apply min vals))
+ (yoff (- lly minval))
+ (deltaval (- maxval minval))
+ (yscale (/ (- uly lly)(if (eq? deltaval 0) 1 deltaval)))
+ (yfunc (lambda (y)(* (+ y yoff) yscale))))
+ ;; (print (car cf) ": " (hash-table->alist
+ (fold
+ (lambda (next prev) ;; #(time ? val) #(time ? val)
+ (if prev
+ (let* ((last-tval (tfn (vector-ref prev 0)))
+ (last-yval (+ lly (* yscale (vector-ref prev 2))))
+ (curr-tval (tfn (vector-ref next 0))))
+ (if (> curr-tval last-tval)
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ fill-color: stdcolor
+ line-color: stdcolor))
+ (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
+ next)
+ ;; for init create vector tstart,0
+ #f ;; (vector tstart minval minval)
+ dat)
+ ;; (for-each
+ ;; (lambda (dpt)
+ ;; (let* ((tval (vector-ref dpt 0))
+ ;; (yval (vector-ref dpt 2))
+ ;; (stval (tfn tval))
+ ;; (syval (yfunc yval)))
+ ;; (vg:add-obj-to-comp
+ ;; cmp
+ ;; (vg:make-rect-obj (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ ;; fill-color: stdcolor))))
+ ;; dat)
+ )))) ;; for each data point in the series
+ (hash-table-keys alldat)))))
+ cfg)))
+
+
+;; run times tab
+;;
+(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
+ ;; each test is an object in the run component
+ ;; each run is a component
+ ;; all runs stored in runslib library
+ (let escapeloop ((escape #f))
+ (if (and (not escape)
+ tabdat)
+ (let* ((canvas-margin 10)
+ (not-done-runs (dboard:tabdat-not-done-runs tabdat))
+ (mtx (dboard:tabdat-runs-mutex tabdat))
+ (drawing (dboard:tabdat-drawing tabdat))
+ (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
+ (allruns (dboard:tabdat-allruns tabdat))
+ (num-runs (length allruns))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (compact-layout (dboard:tabdat-compact-layout tabdat))
+ (row-height (if compact-layout 2 10))
+ (graph-height 120)
+ (run-to-run-margin 20))
+ (dboard:tabdat-layout-update-ok-set! tabdat #t)
+ (if (canvas? cnv)
+ (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
+ ((originx originy) (canvas-origin cnv))
+ ((calc-y) (lambda (rownum)
+ (- (/ sizey 2)
+ (* rownum row-height))))
+ ((fixed-originx) (if (dboard:tabdat-originx tabdat)
+ (dboard:tabdat-originx tabdat)
+ (begin
+ (dboard:tabdat-originx-set! tabdat originx)
+ originx)))
+ ((fixed-originy) (if (dboard:tabdat-originy tabdat)
+ (dboard:tabdat-originy tabdat)
+ (begin
+ (dboard:tabdat-originy-set! tabdat originy)
+ originy))))
+ ;; (print "allruns: " allruns)
+ (let runloop ((rundat (car allruns))
+ (runtal (cdr allruns))
+ (run-num 1)
+ (doneruns '()))
+ (let* ((run (dboard:rundat-run rundat))
+ (rowhash (make-hash-table)) ;; store me in tabdat
+ (key-val-dat (dboard:rundat-key-vals rundat))
+ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
+ (key-vals (append key-val-dat
+ (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
+ (if x x "")))))
+ (run-key (string-intersperse key-vals "\n"))
+ (run-full-name (string-intersperse key-vals "/"))
+ (curr-run-start-row (dboard:tabdat-max-row tabdat)))
+ ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
+ (if (not (vg:lib-get-component runslib run-full-name))
+ (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible.
+ (not (dboard:rundat-hierdat rundat)))
+ (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids
+ (dboard:rundat-hierdat-set! rundat hd)
+ hd)
+ (dboard:rundat-hierdat rundat)))
+ (tests-ht (dboard:rundat-tests rundat))
+ (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
+ (testsdat (hash-table-values tests-ht))
+ (runcomp (vg:comp-new));; new component for this run
+ (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
+ ;; (row-height 4)
+ (run-start (dboard:min-max < (map db:test-get-event_time testsdat)))
+ (run-end (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))
+ (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start))
+ (run-duration (- run-end run-start))
+ (timescale (/ (- sizex (* 2 canvas-margin))
+ (if (> run-duration 0)
+ run-duration
+ (current-seconds)))) ;; a least lously guess
+ (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
+ (num-tests (length hierdat))
+ (tot-tests (length testsdat))
+ (width (* timescale run-duration))
+ (graph-lly (calc-y (/ -50 row-height)))
+ (graph-uly (- (calc-y 0) canvas-margin))
+ (sec-per-50pt (/ 50 timescale))
+ )
+ (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt)
+ ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
+ (mutex-lock! mtx)
+ (vg:add-comp-to-lib runslib run-full-name runcomp)
+ ;; Have to keep moving the instantiated box as it is anchored at the lower left
+ ;; this should have worked for x in next statement? (maptime run-start)
+ ;; add 60 to make room for the graph
+ (vg:instantiate drawing "runslib" run-full-name run-full-name 0 (- (calc-y curr-run-start-row) (+ graph-height run-to-run-margin)))
+ (mutex-unlock! mtx)
+ ;; (set! run-start-row (+ max-row 2))
+ ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
+ ;; get tests in list sorted by event time ascending
+ (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
+ (tests-tal (cdr hierdat))
+ (test-num 1))
+ (let ((iterated (> (length test-ids) 1))
+ (first-rownum #f)
+ (num-items (length test-ids)))
+ (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items
+ (tidstal (cdr test-ids))
+ (item-num 1)
+ (test-objs '()))
+ (let* ((testdat (hash-table-ref tests-ht test-id))
+ (event-time (maptime (db:test-get-event_time testdat)))
+ (test-duration (* timescale (db:test-get-run_duration testdat)))
+ (end-time (+ event-time test-duration))
+ (test-name (db:test-get-testname testdat))
+ (item-path (db:test-get-item-path testdat))
+ (state (db:test-get-state testdat))
+ (status (db:test-get-status testdat))
+ (test-fullname (conc test-name "/" item-path))
+ (name-color (gutils:get-color-for-state-status state status))
+ (new-test-objs
+ (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1)))
+ (if (dashboard:row-collision rowhash rownum event-time end-time)
+ (loop (+ rownum 1))
+ (let* ((title (if iterated (if compact-layout #f item-path) test-name))
+ (lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
+ (uly (+ lly row-height))
+ (use-end (if (< (- end-time event-time) 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
+ (if compact-layout
+ 0
+ (* (string-length title) 10))))))) ;; 8 pixels per letter
+ ;; (if iterated
+ ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
+ ;; (if (not first-rownum)
+ ;; (begin
+ ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
+ ;; (set! first-rownum rownum)))
+ (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
+ (dboard:tabdat-max-row tabdat))) ;; track the max row used
+ ;; bar-end has some margin for text - accounting for text in extents not yet working.
+ (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5))
+ (vg:add-obj-to-comp runcomp obj)
+ ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (cons obj test-objs))))))
+ ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time)
+ ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
+ (if (> item-num 50)
+ (if (eq? 0 (modulo item-num 50))
+ (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
+ ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? tidstal)
+ (if iterated
+ (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
+ (llx (- (car xtents) 10))
+ (lly (- (cadr xtents) 10))
+ (ulx (+ 5 (caddr xtents)))
+ (uly (+ 10 (cadddr xtents))))
+ ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items)
+ ;; This is the box around the tests of an iterated test
+ (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
+ text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
+ line-color: (vg:rgb->number 0 0 255 a: 128)
+ font: "Helvetica -10"))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
+ (if (or (dboard:tabdat-layout-update-ok tabdat)
+ (escape #t)) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (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")
+ (if (or (dboard:tabdat-layout-update-ok tabdat)
+ (escape #t)) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (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 -5 lly ulx uly
+ text: run-full-name
+ line-color: (vg:rgb->number 255 0 255 a: 128))))
+ ; (vg:components-get-extents d1 c1)))
+ ;; this is the box around the run
+ (mutex-lock! mtx)
+ (vg:add-obj-to-comp runcomp outln)
+ (mutex-unlock! mtx)
+ ;; this is where we have enough info to place the graph
+ (dboard:graph commondat tabdat tab-num -5 (+ uly 3) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ ))
+ ;; end of the run handling loop
+ (if (or (dboard:tabdat-layout-update-ok tabdat)
+ (escape #t)) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? runtal)
+ (begin
+ (dboard:rundat-data-changed-set! rundat #f)
+ (dboard:tabdat-not-done-runs-set! tabdat '())
+ (dboard:tabdat-done-runs-set! tabdat allruns))
+ (if #f ;; (> (- (current-seconds) update-start-time) 5)
+ (begin
+ (print "drawing runs taking too long.... have " (length runtal) " remaining")
+ ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
+ ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
+ (dboard:tabdat-not-done-runs-set! tabdat runtal))
+ (begin
+ (if (or (dboard:tabdat-layout-update-ok tabdat)
+ (escape #t)) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))))) ;; new-run-start-row
+ )))
+ (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
+
+(define (dashboard:runs-tab-updater commondat tab-num)
+ (debug:catch-and-dump
+ (lambda ()
+ (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (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
;;======================================================================
@@ -1899,11 +2990,11 @@
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
- (common:exit-on-version-changed)
+ (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 "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
@@ -1925,34 +3016,50 @@
(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! (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)
- (begin
- (dashboard:run-update x commondat)
- (mutex-lock! (dboard:commondat-update-mutex commondat))
- (dboard:commondat-updating-set! commondat #f)
- (mutex-unlock! (dboard:commondat-update-mutex commondat)))
- ))
- 1))))
+ (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)
+ (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
(dboard:commondat-please-update-set! commondat #t)
- (dashboard:run-update 1 commondat)
+ ;; (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: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -36,11 +36,11 @@
;;======================================================================
;; 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-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))))
@@ -2302,11 +2302,11 @@
;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
;;
(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)
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -64,20 +64,34 @@
;; 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
@@ -109,11 +123,12 @@
(> 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
+ (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))))
@@ -128,12 +143,12 @@
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:tabdat-run-keys data) run-id run-path)
- (iup:attribute-set! (dboard:tabdat-runs-matrix data)
- (conc rownum ":" colnum) col-name)
+ ;; 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:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
(set! colnum (+ colnum 1))))
@@ -187,40 +202,64 @@
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 *default-log-port* "node-num: " node-num ", color: " color)
- (iup:attribute-set! tb (conc "COLOR" node-num) 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:tabdat-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 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
- (iup:attribute-set! (dboard:tabdat-runs-matrix data)
- (conc rownum ":" colnum)
- (if (member state '("ARCHIVED" "COMPLETED"))
- status
- state))
- (iup:attribute-set! (dboard:tabdat-runs-matrix data)
- (conc "BGCOLOR" rownum ":" colnum)
- (car (gutils:get-color-for-state-status 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:commondat-updaters commondat) window-id #f)))
(if updater (updater (hash-table-ref/default data get-details-sig #f))))
- (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")
+ (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)))
;;======================================================================
@@ -356,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 alldat)
+(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(changed #f)
- (updater (lambda ()
- (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 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
@@ -431,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)
@@ -853,109 +896,117 @@
(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 data)
+(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! data val)
- (dashboard:update-run-command data))))
+ (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! data default-cmd)
+ (dboard:tabdat-command-set! tabdat default-cmd)
lb))))
-(define (dcommon:command-runname-selector alldat data)
+(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! data txt) ;; (iup:attribute obj "VALUE"))
- (dashboard:update-run-command data))
- #:value (or default-run-name (dboard:tabdat-run-name data))))
+ (debug:catch-and-dump
+ (lambda ()
+ ;; (print "obj: " obj " val: " val " unk: " unk)
+ (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
+ (dashboard:update-run-command tabdat))
+ "command-runname-selector tb action"))
+ #:value (or default-run-name (dboard:tabdat-run-name tabdat))))
(lb (iup:listbox #:expand "HORIZONTAL"
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
- (if (not (equal? val ""))
- (begin
- (iup:attribute-set! tb "VALUE" val)
- (dboard:tabdat-run-name-set! data val)
- (dashboard:update-run-command data))))))
+ (debug:catch-and-dump
+ (lambda ()
+ (if (not (equal? val ""))
+ (begin
+ (iup:attribute-set! tb "VALUE" val)
+ (dboard:tabdat-run-name-set! tabdat val)
+ (dashboard:update-run-command tabdat))))
+ "command-runname-selector lb action"))))
(refresh-runs-list (lambda ()
- (let* ((target (dboard:tabdat-target-string data))
- (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-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)))))
- (dboard:tabdat-updater-for-runs-set! data refresh-runs-list)
+ (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! data default-run-name)
+ (dboard:tabdat-run-name-set! tabdat default-run-name)
(iup:hbox
tb
lb))))
-(define (dcommon:command-testname-selector alldat data 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
- data
- (dboard:lines->test-patt b))
- (dashboard:update-run-command data))
- #:value (dboard:test-patt->lines
- (dboard:tabdat-test-patts-use 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:tabdat-states-set! data all)
- (dashboard:update-run-command data))))
- ;; 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! data all)
- (dashboard:update-run-command data))))))))
+(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;; key-listboxes)
+ (iup:vbox
+ ;; Text box for test patterns
+ (iup:frame
+ #:title "Test patterns (one per line)"
+ (let ((tb (iup:textbox #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ (dboard:tabdat-test-patts-set!-use
+ tabdat
+ (dboard:lines->test-patt b))
+ (dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #:expand "YES"
+ #:size "10x30"
+ #:multiline "YES")))
+ (set! test-patterns-textbox tb)
+ tb))
+;; (iup:frame
+;; #:title "Target"
+;; ;; Target selectors
+;; (apply iup:hbox
+;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals))
+;; (key-lb (car dat))
+;; (combos (cadr dat)))
+;; combos)))
+ (iup:hbox
+ ;; Text box for STATES
+ (iup:frame
+ #:title "States"
+ (dashboard:text-list-toggle-box
+ ;; Move these definitions to common and find the other useages and replace!
+ (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
+ (lambda (all)
+ (dboard:tabdat-states-set! tabdat all)
+ (dashboard:update-run-command tabdat))))
+ ;; Text box for STATES
+ (iup:frame
+ #:title "Statuses"
+ (dashboard:text-list-toggle-box
+ (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
+ (lambda (all)
+ (dboard:tabdat-statuses-set! tabdat all)
+ (dashboard:update-run-command tabdat)))))))
(define (dcommon:command-tests-tasks-canvas data test-records sorted-testnames tests-draw-state)
(iup:frame
#:title "Tests and Tasks"
(let* ((updater #f)
Index: docs/Makefile
==================================================================
--- docs/Makefile
+++ docs/Makefile
@@ -1,6 +1,14 @@
-all : html/megatest.html megatest.pdf
+ASCPATH = $(shell which asciidoc)
+EXEPATH = $(shell readlink -f $(ASCPATH))
+BINPATH = $(shell dirname $(EXEPATH))
+DISPATH = $(shell dirname $(BINPATH))
+
+api.html : api.txt
+ asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 api.txt
+
+# all : html/megatest.html megatest.pdf
html/megatest.html : megatest.lyx
elyxer megatest.lyx html/megatest.html
fossil add html/*
ADDED docs/api.html
Index: docs/api.html
==================================================================
--- /dev/null
+++ docs/api.html
@@ -0,0 +1,872 @@
+
+
+
+
+
+Megatest Web App API Specificiation
+
+
+
+
+
+
+
+
+
+
+-
+
+See runs
+
+
+-
+
+Manage jobs
+
+
+-
+
+Debug
+
+
+
+
+
+
+
Example Abstract
+
+
The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.
+
+
+
+
1. Common
+
+
This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.
+
+
+
+
All API errors are returned in the following format:
+
+
+
{ "error" : "Error message" }
+
+
+
+
1.2. Get List of Runs
+
+
+
Params: target, testpatt, offset, limit
+
+
+
+
{ "us" : "United States of America" }
+
+
+
+
+
{ "places": [ [ "place_name", "place_description ], … ],
+ "friends": [ [ "short_name", "username", "location", uid, frequency ], … ],
+ "iousum": [ [ "nick:location", est_iou ], …] }
+
+
+
+
+
+
2. Notes
+
+
+
+-
+
+blah
+
+
+-
+
+baz
+
+
+
+
+
+
+
+
+
+
ADDED docs/api.txt
Index: docs/api.txt
==================================================================
--- /dev/null
+++ docs/api.txt
@@ -0,0 +1,66 @@
+Megatest Web App API Specificiation
+===================================
+Matt Welland
+v1.0, 2013-12
+
+Megatest Web App
+
+. See runs
+. Manage jobs
+. Debug
+
+:numbered!:
+[abstract]
+Example Abstract
+----------------
+
+The Megatest Web App aims to make as much of the power of the dashboard available to the web based user.
+
+:numbered:
+
+Common
+------
+
+This is an example endpoint. You will need to use your own cgi server to serve out your megatest runs.
+
+Endpoint: http://kiatoa.com/cgi-bin/megatest
+
+Error format response
+~~~~~~~~~~~~~~~~~~~~~
+All API errors are returned in the following format:
+
+===================
+{ "[blue]#error#" : "[red]#Error message#" }
+===================
+
+Get List of Runs
+~~~~~~~~~~~~~~~~
+
+URL: /get_runs
+
+Method: GET
+
+Params: target, testpatt, offset, limit
+
+Response:
+
+=================
+{ "[blue]#us#" : "[red]#United States of America#" }
+=================
+
+Another example ....
+
+==================
+{ "[blue]#places#": [ [ "[red]#place_name#", "[red]#place_description# ], ... ],
+ "[blue]#friends#": [ [ "[red]#short_name#", "[red]#username#", "[red]#location#", [red]#uid#, [red]#frequency# ], ... ],
+ "[blue]#iousum#": [ [ "[red]#nick:location#", [red]#est_iou# ], ...] }
+==================
+
+
+Notes
+-----
+
+Misc ...
+
+ 1. blah
+ 2. baz
ADDED gen-data-for-graph.scm
Index: gen-data-for-graph.scm
==================================================================
--- /dev/null
+++ gen-data-for-graph.scm
@@ -0,0 +1,55 @@
+(use foof-loop sql-de-lite posix)
+
+(define beginning-2016 1451636435.0)
+(define now (current-seconds))
+(define one-year-ago (- now (* 365 24 60 60)))
+
+(define db (open-database "example.db"))
+
+(exec (sql db "CREATE TABLE IF NOT EXISTS alldat (event_time,var,val)"))
+
+;; sin(time)
+(with-transaction
+ db
+ (lambda ()
+ (loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year
+ (let ((thetime (* m 60))
+ (thehour (round (/ m 60))))
+ (let loop ((lastsec -1)
+ (sec (random 60))
+ (count 0))
+ (if (> sec lastsec)
+ (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
+ (+ thetime sec) ;; (* sec 60))
+ "stuff"
+ (if (even? thehour)
+ (random 1000)
+ (random 6))))
+ (if (< count 20)
+ (loop (max sec lastsec)(random 60)(+ count 1))))))))
+
+(close-database db)
+
+
+;; (with-transaction
+;; db
+;; (lambda ()
+;; (loop ((for d (up-from 0 (to 365)))) ;; days of the year
+;; (print "Day: " d)
+;; (loop ((for h (up-from 1 (to 24))))
+;; (loop ((for m (up-from 1 (to 60))))
+;; (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60))))
+;; (let loop ((lastsec -1)
+;; (sec (random 60))
+;; (count 0))
+;; (if (> sec lastsec)
+;; (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
+;; (+ thetime sec) ;; (* sec 60))
+;; "stuff"
+;; (if (even? h)
+;; (random 100)
+;; (random 6))))
+;; (if (< count 20)
+;; (loop (max sec lastsec)(random 60)(+ count 1))))))))))
+;;
+;; (close-database db)
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 ()
+ ((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 )))
+ (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))))))
ADDED records.sh
Index: records.sh
==================================================================
--- /dev/null
+++ records.sh
@@ -0,0 +1,18 @@
+#! /bin/bash
+
+# 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
+# libs: hash of name->lib, insts: hash of instname->inst
+#
+# Add -safe when doing development
+#
+export MODE='-safe'
+(echo ";; Created by records.sh. DO NOT EDIT THIS FILE. Edit records.sh instead"
+make-vector-record $MODE vg lib comps
+make-vector-record $MODE vg comp objs name file
+make-vector-record $MODE vg obj type pts fill-color text line-color call-back angle font attrib extents proc
+make-vector-record $MODE vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
+make-vector-record $MODE vg drawing libs insts scalex scaley xoff yoff cnv cache
+) > vg_records.scm
+
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -622,11 +622,13 @@
;; if found then return that matching test record
(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 'normal)))
+ (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
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -85,12 +85,11 @@
(getenv "MT_RUNNAME") "/"
(getenv "MT_TEST_NAME")
(if (and itempath
(not (equal? itempath "")))
(conc "/" itempath)
- ""))))
- ))
+ ""))))))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
@@ -127,12 +126,11 @@
#f)))
(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 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
+ (if (runs:lownoise "waiting on tasks" 60)(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)))
@@ -147,11 +145,11 @@
(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
+ ;; than it then cannot run more jobs
((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
(if (runs:lownoise "mcj msg" 60)
(debug:print 0 *default-log-port* "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs))
#t)
@@ -932,13 +930,13 @@
(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 "%" '() '()
- #f #f
- #f ;; hide/not-hide
+ (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)))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -529,11 +529,11 @@
(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)
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)
@@ -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/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -1,10 +1,13 @@
[fields]
sysname TEXT
fsname TEXT
datapath TEXT
+[graph]
+g1 sqlite3:../../example.db alldat event_time var val stuff
+
# refareas can be searched to find previous runs
# the path points to where megatest.db exists
[refareas]
area1 /tmp/oldarea/megatest
Index: vg-test.scm
==================================================================
--- vg-test.scm
+++ vg-test.scm
@@ -1,26 +1,80 @@
-(use canvas-draw iup)
+(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))
-(let ((r1 (vg:make-rect 10 10 100 80))
- (r2 (vg:make-rect 100 80 190 150)))
- (vg:add-objs-to-comp c1 r1 r2))
+(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 0)
-(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200 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"
@@ -35,10 +89,10 @@
(dialog
(vbox
the-cnv)))
(vg:drawing-cnv-set! d1 cnv)
-(vg:draw d1)
+(vg:draw d1 #t)
;; (canvas-rectangle! cnv 10 100 10 80)
(main-loop)
Index: vg.scm
==================================================================
--- vg.scm
+++ vg.scm
@@ -8,21 +8,28 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use defstruct)
+(use typed-records srfi-1)
(declare (unit vg))
-
-;; structs
-;;
-(defstruct vg:lib comps)
-(defstruct vg:comp objs name file)
-(defstruct vg:obj type pts fill-color text line-color call-back font)
-(defstruct vg:inst libname compname theta xoff yoff scale mirrx mirry call-back)
-(defstruct vg:drawing libs insts cnv) ;; libs: hash of name->lib, insts: hash of instname->inst
+(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))
@@ -29,102 +36,607 @@
(define (vg:lib-new)
(make-vg:lib comps: (make-hash-table)))
(define (vg:drawing-new)
- (make-vg:drawing libs: (make-hash-table) insts: (make-hash-table)))
+ (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:make-rect x1 y1 x2 y2 #!key (line-color #f)(fill-color #f))
- (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: #f line-color: line-color fill-color: fill-color))
+(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 t #!key (scale 1)(mirrx #f)(mirry #f))
- (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: t scale: scale mirrx: mirrx mirry: mirry)) )
+(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
+;; map objects given offset, scale and mirror, resulting obj is displayed
;;======================================================================
-(define (vg:map-obj xoff yoff theta scale mirrx mirry obj)
+;; dispatch the drawing of obj off to the correct drawing routine
+;;
+(define (vg:map-obj drawing inst obj)
(case (vg:obj-type obj)
- ((r)(vg:map-rect xoff yoff theta scale mirrx mirry 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)))
-(define (vg:map-rect xoff yoff theta scale mirrx mirry obj)
- (let ((res (make-vg:obj type: 'r
+;; 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
- (list (+ xoff (car pts))
- (+ yoff (cadr pts))
- (+ xoff (caddr pts))
- (+ yoff (cadddr pts))))
+ (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
;;======================================================================
-(define (vg:draw-obj cnv obj)
- (print "obj type: " (vg:obj-type obj))
+;; 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 cnv obj))))
-
-(define (vg:draw-rect cnv obj)
- (let* ((pts (vg:obj-pts obj))
- (llx (car pts))
- (lly (cadr pts))
- (urx (caddr pts))
- (ury (cadddr pts)))
- (print "(canvas-rectangle! " cnv " " llx " " urx " " lly " " ury ")")
- (canvas-rectangle! cnv llx urx lly ury)
- ))
-
-(define (vg:draw drawing)
- (let ((insts (vg:drawing-insts drawing))
- (cnv (vg:drawing-cnv drawing)))
- (for-each
- (lambda (inst)
- (let* ((xoff (vg:inst-xoff inst))
- (yoff (vg:inst-yoff inst))
- (theta (vg:inst-theta inst))
- (scale (vg:inst-scale inst))
- (mirrx (vg:inst-mirrx inst))
- (mirry (vg:inst-mirry inst))
- (libname (vg:inst-libname inst))
- (compname (vg:inst-compname inst))
- (comp (vg:get-component drawing libname compname)))
- (print "comp: " comp)
- (for-each
- (lambda (obj)
- (print "obj: " obj)
- (vg:draw-obj cnv (vg:map-obj xoff yoff theta scale mirrx mirry obj)))
- (vg:comp-objs comp))))
- (hash-table-values insts))))
+ ((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))))