ADDED attic/dashboard.scm
Index: attic/dashboard.scm
==================================================================
--- /dev/null
+++ attic/dashboard.scm
@@ -0,0 +1,3771 @@
+;;======================================================================
+;; Copyright 2006-2016, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+(declare (uses ducttape-lib))
+
+(declare (uses debugprint))
+(declare (uses bigmod))
+;; (declare (uses gutils))
+;; (declare (uses bigmod.import))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dashboard-context-menu))
+(declare (uses dashboard-tests))
+(declare (uses dbmod))
+(declare (uses dcommon))
+;; (declare (uses debugprint.import))
+(declare (uses itemsmod))
+(declare (uses launchmod))
+(declare (uses mtargs))
+(declare (uses mtmod))
+(declare (uses mtver))
+(declare (uses processmod))
+(declare (uses runsmod))
+(declare (uses rmtmod))
+(declare (uses subrunmod))
+(declare (uses tree))
+(declare (uses vgmod))
+(declare (uses testsmod))
+(declare (uses tasksmod))
+(declare (uses dbi))
+
+;; needed for configf scripts, scheme etc.
+;; (declare (uses apimod.import))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs.import))
+;; (declare (uses commonmod.import))
+;; (declare (uses configfmod.import))
+;; (declare (uses bigmod.import))
+;; (declare (uses dbmod.import))
+;; (declare (uses rmtmod.import))
+;; ;; (declare (uses servermod.import))
+;; (declare (uses launchmod.import))
+;; (declare (uses dashboard-guimonitor))
+;; (declare (uses dashboard-main))
+
+(module dashboard
+ *
+
+(import scheme
+ chicken.base
+ chicken.bitwise
+ chicken.condition
+ chicken.eval
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.irregex
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.random
+ chicken.repl
+ chicken.sort
+ chicken.string
+ chicken.tcp
+ chicken.time
+ chicken.time.posix
+
+ (prefix iup iup:)
+ canvas-draw
+ canvas-draw-iup
+ (prefix sqlite3 sqlite3:)
+ (prefix dbi dbi:)
+ srfi-1
+ regex regex-case srfi-69
+ typed-records
+ sparse-vectors
+ format
+ srfi-4
+ srfi-14
+ srfi-18
+ )
+
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; (include "task_records.scm")
+;; (include "megatest-version.scm")
+(include "megatest-fossil-hash.scm")
+;; (include "vg_records.scm")
+
+(import (prefix mtargs args:)
+ ;; gutils
+ bigmod
+ commonmod
+ configfmod
+ dashboard-context-menu
+ dashboard-tests
+ dbmod
+ dcommon
+ debugprint
+ itemsmod
+ launchmod
+ mtmod
+ mtver
+ processmod
+ rmtmod
+ runsmod
+ subrunmod
+ tasksmod
+ testsmod
+ tree
+ vgmod
+ ducttape-lib
+ )
+
+(define help (conc
+ "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright (C) Matt Welland 2012-2017
+
+Usage: dashboard [options]
+ -h : this help
+ -test run-id,test-id : control test identified by testid
+ -skip-version-check : skip the version check
+ -use-db-cache : access database via cache
+
+Misc
+ -rows R : set number of rows
+ -cols C : set number of columns
+"))
+
+;; -server host:port : connect to host:port instead of db access
+;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
+;; -guimonitor : control panel for runs
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-rows"
+ "-cols"
+ "-run"
+ "-test"
+ "-xterm"
+ "-debug"
+ "-host"
+ "-transport"
+ "-start-dir"
+ )
+ (list "-h"
+ "-use-server"
+ "-guimonitor"
+ "-main"
+ "-v"
+ "-q"
+ "-use-db-cache"
+ "-skip-version-check"
+ "-repl"
+ "-rh5.11" ;; fix to allow running on rh5.11
+ "-:p" ;; ignore the built in chicken profiling switch
+ )
+ args:arg-hash
+ 0))
+
+(make-and-init-bigdata)
+;; check for MT_* environment variables and exit if found
+(if (not (args:get-arg "-test"))
+ (begin
+ (display "Checking for MT_ vars: ")
+ (for-each (lambda (var)
+ (display " ")(display var)
+ (if (get-environment-variable var)
+ (begin
+ (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
+ (exit 1))))
+ '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
+ (print ". Done. All ok.")))
+
+(if (not (null? remargs))
+ (begin
+ (print "Unrecognised arguments: " (string-intersperse remargs " "))
+ ))
+
+(if (args:get-arg "-h")
+ (begin
+ (print help)
+ (exit)))
+
+(if (args:get-arg "-start-dir")
+ (if (directory-exists? (args:get-arg "-start-dir"))
+ (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
+ (setenv "PWD" fullpath)
+ (change-directory fullpath))
+ (begin
+ (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
+ (exit 1))))
+
+;; TODO: Move this inside (main)
+;;
+(if (not (launch:setup))
+ (begin
+ (print "Failed to find megatest.config, exiting")
+ (exit 1)))
+
+;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
+;; first check for the switch
+;;
+(if (or (args:get-arg "-rh5.11")
+ (configf:lookup *configdat* "dashboard" "no-detachbox")
+ (not (file-exists? "/etc/os-release")))
+ (set! iup:detachbox iup:vbox))
+
+#;(if (not (common:on-homehost?))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
+
+;; RA => Might require revert for filters
+;; create a watch dog to move changes from lt/.db/*.db to megatest.db
+;;
+;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
+;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")
+
+(thread-start! (make-thread common:watchdog "Watchdog thread"))
+
+;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
+;; (if (not (args:get-arg "-use-db-cache"))
+;; (begin
+;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
+;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
+;;)
+
+;; data common to all tabs goes here
+;;
+(defstruct dboard:commondat
+ ((curr-tab-num 0) : number)
+ please-update
+ tabdats
+ update-mutex
+ updaters
+ updating
+ uidat ;; needs to move to tabdat at some time
+ hide-not-hide-tabs
+ )
+
+(define (dboard:commondat-make)
+ (make-dboard:commondat
+ curr-tab-num: 0
+ tabdats: (make-hash-table)
+ please-update: #t
+ update-mutex: (make-mutex)
+ updaters: (make-hash-table)
+ updating: #f
+ hide-not-hide-tabs: #f
+ ))
+
+;;======================================================================
+;; buttons color using image
+;;======================================================================
+
+(define *images* (make-hash-table))
+
+(define (make-image images name color)
+ (if (hash-table-exists? images name)
+ name
+ (let* ((img-bits1 (u8vector->blob (u8vector
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ )))
+ ;; w h
+ (img1 (iup:image/palette 16 24 img-bits1)))
+ (iup:handle-name-set! img1 name)
+ ;; (iup:attribute-set! img1 "0" "0 0 0")
+ (iup:attribute-set! img1 "1" color) ;; "BGCOLOR")
+ ;; (iup:attribute-set! img1 "2" "255 0 0")
+ (hash-table-set! images name img1)
+ name)))
+
+
+;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
+;;
+(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
+ (let* ((tnum (or tab-num
+ (dboard:commondat-curr-tab-num commondat)
+ 0)) ;; tab-num value is curr-tab-num value in passed commondat
+ (ht (dboard:commondat-tabdats commondat))
+ (res (hash-table-ref/default ht tnum #f)))
+ (or res
+ (let ((new-tabdat (dboard:tabdat-make-data)))
+ (hash-table-set! ht tnum new-tabdat)
+ new-tabdat))))
+
+;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
+;;
+(define (dboard:common-set-tabdat! commondat tabnum tabdat)
+ (hash-table-set!
+ (dboard:commondat-tabdats commondat)
+ tabnum
+ tabdat))
+
+;; gets and calls updater list 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 ;; perform the function calls for the complete updaters list
+ (lambda (updater)
+ ;; (debug:print 3 *default-log-port* "Running " updater)
+ (updater))
+ updaters))))
+
+;; register tabdat with BBpp
+;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
+#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
+ (cons dboard:tabdat?
+ (lambda (tabdat-item)
+ (filter
+ (lambda (alist-entry)
+ (member (car alist-entry)
+ '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
+ (dboard:tabdat->alist tabdat-item)))))
+
+
+
+(define (dboard:tabdat-target-string vec)
+ (let ((targ (dboard:tabdat-target vec)))
+ (if (list? targ)(string-intersperse targ "/") "no-target-specified")))
+
+(define (dboard:tabdat-make-data)
+ (let ((dat (make-dboard:tabdat)))
+ (dboard:setup-tabdat dat)
+ (dboard:setup-num-rows dat)
+ dat))
+
+(define (dboard:setup-tabdat tabdat)
+ (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
+ (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
+
+ ;; HACK ALERT: this is a hack, please fix.
+ (dboard:tabdat-ro-set! tabdat (not (file-readable? (dboard:tabdat-dbfpath tabdat))))
+
+ (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
+ (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
+ (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
+ )
+
+;; RADT => Matrix defstruct addition
+(defstruct dboard:graph-dat
+ ((id #f) : string)
+ ((color #f) : vector)
+ ((flag #t) : boolean)
+ ((cell #f) : number)
+ )
+
+;; data for runs, tests etc. was used in run summary?
+;;
+(defstruct dboard:runsdat
+ ;; new system
+ runs-index ;; target/runname => colnum
+ tests-index ;; testname/itempath => rownum
+ matrix-dat ;; vector of vectors rows/cols
+ )
+
+(define (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 (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
+ key-vals
+ ((last-update 0) : number) ;; last query to db got records from before last-update
+ ((last-db-time 0) : number) ;; last timestamp on megatest.db
+ ((data-changed #f) : boolean)
+ ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
+ (db-path #f))
+
+;; for the new runs view lets build up a few new record types and then consolidate later
+;;
+;; this is a two level deep pipeline for the incoming data:
+;; sql query data ==> filters ==> data for display
+;;
+(defstruct dboard:rdat
+ ;; view related items
+ (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
+ (leftcol 0) ;; number of the leftmost visible column
+ (toprow 0) ;; topmost visible row
+ (numcols 24) ;; number of columns visible
+ (numrows 20) ;; number of rows visible
+
+ ;; data from sql db
+ (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
+ (runs (make-sparse-vector)) ;; id => runrec
+ (runsbynum (make-vector 100 #f)) ;; vector num => runrec
+ (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
+ (tests (make-hash-table)) ;; test[/itempath] => list of test rec
+ (path-run-ids (make-hash-table)) ;; path => run-id (this is a guess based on code reference)
+
+ ;; run sql filters
+ (targ-sql-filt "%")
+ (runname-sql-filt "%")
+ (run-state-sql-filt "%")
+ (run-status-sql-filt "%")
+
+ ;; test sql filter
+ (testname-sql-filt "%")
+ (itempath-sql-filt "%")
+ (test-state-sql-filt "%")
+ (test-status-sql-filt "%")
+
+ ;; other sql related fields
+ (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
+
+ ;; filtered data
+ (cols (make-sparse-vector)) ;; columnnum => run-id
+ (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec)
+
+ ;; various
+ (prev-run-ids '()) ;; push previously looked at runs on this
+ (view-changed #f)
+
+ ;; widgets
+ (runs-tree #f) ;;
+ )
+
+(define (dboard:rdat-push-run-id rdat run-id)
+ (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
+
+(defstruct dboard:runrec
+ id
+ target ;; a/b/c...
+ tdef ;; for future use
+ )
+
+(defstruct dboard:testrec
+ id
+ runid
+ testname ;; test[/itempath]
+ state
+ status
+ start-time
+ duration
+ )
+
+;; register dboard:rundat with BBpp
+;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
+#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
+ (cons dboard:rundat?
+ (lambda (tabdat-item)
+ (filter
+ (lambda (alist-entry)
+ (member (car alist-entry)
+ '(run run-data-offset ))) ;; FIELDS OF INTEREST
+ (dboard:rundat->alist tabdat-item)))))
+
+
+
+
+(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
+ (make-dboard:rundat
+ run: run
+ tests: (or tests (make-hash-table))
+ key-vals: key-vals
+ ))
+
+(defstruct dboard:testdat
+ id ;; testid
+ state ;; test state
+ status ;; test status
+ )
+
+;; default is to NOT set the cell if the column and row names are not pre-existing
+;;
+#;(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
+ (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set))
+ (row-num (dcommon: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:runsdat-matrix-dat dat) col-num row-num tdat)
+ tdat)
+ #f)))
+
+(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
+
+
+;; sorting global data (would apply to many testsuites so leave it global for now)
+;;
+(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
+ (vector "Sort -a" 'testname "DESC")
+ (vector "Sort +t" 'event_time "ASC")
+ (vector "Sort -t" 'event_time "DESC")
+ (vector "Sort +s" 'statestatus "ASC")
+ (vector "Sort -s" 'statestatus "DESC")
+ (vector "Sort +a" 'testname "ASC")))
+
+(define *tests-sort-type-index* '(("+testname" 0)
+ ("-testname" 1)
+ ("+event_time" 2)
+ ("-event_time" 3)
+ ("+statestatus" 4)
+ ("-statestatus" 5)))
+
+;; Don't forget to adjust the >= below if you add to the sort-options above
+(define (next-sort-option)
+ (if (>= *tests-sort-reverse* 5)
+ (set! *tests-sort-reverse* 0)
+ (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
+ *tests-sort-reverse*)
+
+(define *tests-sort-reverse*
+ (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
+ (if t-sort
+ (cadr t-sort)
+ 3)))
+
+(define (get-curr-sort)
+ (vector-ref *tests-sort-options* *tests-sort-reverse*))
+
+;;======================================================================
+
+(debug:setup)
+
+;; (define uidat #f)
+
+(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
+(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
+(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2))
+(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))
+
+(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+(define (dboard:compare-tests test1 test2)
+ (let* ((test-name1 (db:test-get-testname test1))
+ (item-path1 (db:test-get-item-path test1))
+ (eventtime1 (db:test-get-event_time test1))
+ (test-name2 (db:test-get-testname test2))
+ (item-path2 (db:test-get-item-path test2))
+ (eventtime2 (db:test-get-event_time test2))
+ (same-name (equal? test-name1 test-name2))
+ (test1-top (equal? item-path1 ""))
+ (test2-top (equal? item-path2 ""))
+ (test1-older (> eventtime1 eventtime2))
+ (same-time (equal? eventtime1 eventtime2)))
+ (if same-name
+ (if same-time
+ (string>? item-path1 item-path2)
+ test1-older)
+ (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* ((start-time (current-seconds))
+ (access-mode (dboard:tabdat-access-mode tabdat))
+ (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
+ "200")))
+ (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
+ (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
+ (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
+ (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
+ (sort-info (get-curr-sort))
+ (sort-by (vector-ref sort-info 1))
+ (sort-order (vector-ref sort-info 2))
+ (bubble-type (if (member sort-order '(testname))
+ 'testname
+ 'itempath))
+ ;; note: the rundat is normally created in "update-rundat".
+ (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
+ (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
+ rd)))
+ ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
+ (last-update (if ;;(or
+ do-not-use-query-timestamps
+ ;;(dboard:tabdat-filters-changed tabdat))
+ 0
+ (dboard:rundat-last-update run-dat)))
+ (last-db-time (if do-not-use-db-file-timestamps
+ 0
+ (dboard:rundat-last-db-time run-dat)))
+ (db-path (or (dboard:rundat-db-path run-dat)
+ (let* ((db-dir (common:get-db-tmp-area))
+ (db-pth (conc db-dir "/megatest.db")))
+ (dboard:rundat-db-path-set! run-dat db-pth)
+ db-pth)))
+ (db-mod-time (common:lazy-sqlite-db-modification-time db-path))
+ (db-modified (>= db-mod-time last-db-time))
+ (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress
+ (tmptests (if (or do-not-use-db-file-timestamps
+ (dboard:tabdat-filters-changed tabdat)
+ db-modified)
+ (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
+ (dboard:rundat-run-data-offset run-dat) ;; query offset
+ num-to-get
+ (dboard:tabdat-hide-not-hide tabdat) ;; no-in
+ sort-by ;; sort-by
+ sort-order ;; sort-order
+ #f ;; 'shortlist ;; qrytype
+ last-update ;; last-update
+ *dashboard-mode*) ;; use dashboard mode
+ '()))
+ (use-new (dboard:tabdat-hide-not-hide tabdat))
+ (tests-ht (if (dboard:tabdat-filters-changed tabdat)
+ (let ((ht (make-hash-table)))
+ (dboard:rundat-tests-set! run-dat ht)
+ ht)
+ (dboard:rundat-tests run-dat)))
+ (got-all (< (length tmptests) num-to-get)) ;; got all for this round
+ )
+
+ ;; if we saw the db modified, reset it (the signal has already been used)
+ (if (and got-all ;; (not multi-get)
+ db-modified)
+ (dboard:rundat-last-db-time-set! run-dat (- start-time 2)))
+
+ ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
+ ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the
+ ;; data has been read
+ ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above
+ ;;
+ ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path)
+ (if got-all
+ (begin
+ (dboard:rundat-last-update-set! run-dat (- start-time 2))
+ (dboard:rundat-run-data-offset-set! run-dat 0))
+ (begin
+ (dboard:rundat-run-data-offset-set! run-dat
+ (+ num-to-get (dboard:rundat-run-data-offset run-dat)))))
+
+ (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)
+
+ 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* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (keys (rmt:get-keys))
+ (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
+ (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
+ (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
+ (start-time (current-seconds))
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run header "id") run))
+ runs-tree) ;; (vector-ref runs-dat 1))
+ ht))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ ;;(BB> "In update-rundat")
+ ;;(inspect allruns runs-hash)
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (dboard:tabdat-header-set! tabdat header)
+ ;;
+ ;; trim runs to only those that are changing often here
+ ;;
+ (if (null? runs)
+ (begin
+ (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-all-test-names-set! tabdat '())
+ (dboard:tabdat-item-test-names-set! tabdat '())
+ (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
+ (let loop ((run (car runs))
+ (tal (cdr runs))
+ (res '())
+ (maxtests 0))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
+ (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
+ (key-vals (rmt:get-key-vals run-id))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
+ ;; dboard:get-tests-for-run-duplicate - returns a hash table
+ ;; (dboard:get-tests-dat tabdat run-id last-update))
+ (all-test-ids (hash-table-keys tests-ht))
+ (num-tests (length all-test-ids)))
+ ;; (print "run-struct: " run-struct)
+ ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
+ ;; (tests (bubble-up tmptests priority: bubble-type))
+ ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
+ ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
+ ;; Not sure this is needed?
+ (let* ((newmaxtests (max num-tests maxtests))
+ (last-update (- (current-seconds) 10))
+ (run-struct (or run-struct
+ (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals)))
+ (new-res (if (null? all-test-ids) res (cons run-struct res)))
+ (elapsed-time (- (current-seconds) start-time)))
+ (if (null? all-test-ids)
+ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
+ (if (or (null? tal)
+ (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
+ (begin
+ (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (if (> (dboard:rundat-run-data-offset run-struct) 0)
+ (loop run tal new-res newmaxtests) ;; not done getting data for this run
+ (loop (car tal)(cdr tal) new-res newmaxtests)))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (dboard:update-tree tabdat runs-hash header tb)))
+
+;; 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 (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys)))
+ (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
+ (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
+ ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
+ (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
+ (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
+ (start-time (current-seconds))
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run header "id") run))
+ runs-tree) ;; (vector-ref runs-dat 1))
+ ht))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (dboard:tabdat-header-set! tabdat header)
+ ;;
+ ;; trim runs to only those that are changing often here
+ ;;
+ (if (null? runs)
+ (begin
+ (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-all-test-names-set! tabdat '())
+ (dboard:tabdat-item-test-names-set! tabdat '())
+ (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
+ (let loop ((run (car runs))
+ (tal (cdr runs))
+ (res '())
+ (maxtests 0))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
+ ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
+ (key-vals (rmt:get-key-vals run-id))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
+ ;; dboard:get-tests-for-run-duplicate - returns a hash table
+ ;; (dboard:get-tests-dat tabdat run-id last-update))
+ (all-test-ids (hash-table-keys tests-ht))
+ (num-tests (length all-test-ids)))
+ ;; (print "run-struct: " run-struct)
+ ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
+ ;; (tests (bubble-up tmptests priority: bubble-type))
+ ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
+ ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
+ ;; Not sure this is needed?
+ (let* ((newmaxtests (max num-tests maxtests))
+ ;; (last-update (- (current-seconds) 10))
+ (run-struct (or run-struct
+ (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals)))
+ (new-res (if (null? all-test-ids)
+ res
+ (delete-duplicates
+ (cons run-struct res)
+ (lambda (a b)
+ (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
+ (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
+ (elapsed-time (- (current-seconds) start-time)))
+ (if (null? all-test-ids)
+ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
+ (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
+ (if (or (null? tal)
+ (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
+ (begin
+ (when (> elapsed-time 2)
+ (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
+ (let* ((old-val (iup:attribute *tim* "TIME"))
+ (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
+ (if (< (string->number new-val) 5000)
+ (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
+ (iup:attribute-set! *tim* "TIME" new-val))))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (if (> (dboard:rundat-run-data-offset run-struct) 0)
+ (loop run tal new-res newmaxtests) ;; not done getting data for this run
+ (loop (car tal)(cdr tal) new-res newmaxtests)))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (dboard:update-tree tabdat runs-hash header tb)))
+
+(define *collapsed* (make-hash-table))
+
+(define (toggle-hide lnum uidat) ; fulltestname)
+ (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
+ (fulltestname (iup:attribute btn "TITLE"))
+ (parts (string-split fulltestname "("))
+ (basetestname (if (null? parts) "" (car parts))))
+ ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
+ (if (hash-table-ref/default *collapsed* basetestname #f)
+ (begin
+ ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s
+ (hash-table-delete! *collapsed* basetestname))
+ (begin
+ ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
+ (hash-table-set! *collapsed* basetestname #t)))))
+
+(define blank-line-rx (regexp "^\\s*$"))
+
+(define (run-item-name->vectors lst)
+ (map (lambda (x)
+ (let ((splst (string-split x "("))
+ (res (vector "" "")))
+ (vector-set! res 0 (car splst))
+ (if (> (length splst) 1)
+ (vector-set! res 1 (car (string-split (cadr splst) ")"))))
+ res))
+ lst))
+
+(define (collapse-rows tabdat inlst)
+ (let* ((sort-info (get-curr-sort))
+ (sort-by (vector-ref sort-info 1))
+ (sort-order (vector-ref sort-info 2))
+ (bubble-type (if (member sort-order '(testname))
+ 'testname
+ 'itempath))
+ (newlst (filter (lambda (x)
+ (let* ((tparts (string-split x "("))
+ (basetname (if (null? tparts) x (car tparts))))
+ ;(print "x " x " tparts: " tparts " basetname: " basetname)
+ (cond
+ ((string-match blank-line-rx x) #f)
+ ((equal? x basetname) #t)
+ ((hash-table-ref/default *collapsed* basetname #f)
+ ;(print "Removing " basetname " from items")
+ #f)
+ (else #t))))
+ inlst))
+ (vlst (run-item-name->vectors newlst))
+ (vlst2 (bubble-up tabdat vlst priority: bubble-type)))
+ (map (lambda (x)
+ (if (equal? (vector-ref x 1) "")
+ (vector-ref x 0)
+ (conc (vector-ref x 0) "(" (vector-ref x 1) ")")))
+ vlst2)))
+
+(define (update-labels uidat alltestnames)
+ (let* ((rown 0)
+ (keycol (dboard:uidat-get-keycol uidat))
+ (lftcol (dboard:uidat-get-lftcol uidat))
+ (numcols (vector-length lftcol))
+ (maxn (- numcols 1))
+ (allvals (make-vector numcols "")))
+ (for-each (lambda (name)
+ (if (<= rown maxn)
+ (vector-set! allvals rown name)) ;)
+ (set! rown (+ 1 rown)))
+ alltestnames)
+ (let loop ((i 0))
+ (let* ((lbl (vector-ref lftcol i))
+ (keyval (vector-ref keycol i))
+ (oldval (iup:attribute lbl "TITLE"))
+ (newval (vector-ref allvals i)))
+ (if (not (equal? oldval newval))
+ (let ((munged-val (let ((parts (string-split newval "(")))
+ (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval))))
+ (vector-set! keycol i newval)
+ (iup:attribute-set! lbl "TITLE" munged-val)))
+ (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
+ (if (< i maxn)
+ (loop (+ i 1)))))))
+
+;;
+(define (get-itemized-tests test-dats)
+ (let ((tnames '()))
+ (for-each (lambda (tdat)
+ (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat))
+ (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat)))
+ (if (not (equal? ipath ""))
+ (if (and (list? tnames)
+ (string? tname)
+ (not (member tname tnames)))
+ (set! tnames (append tnames (list tname)))))))
+ test-dats)
+ tnames))
+
+;; Bubble up the top tests to above the items, collect the items underneath
+;; all while preserving the sort order from the SQL query as best as possible.
+;;
+(define (bubble-up tabdat test-dats #!key (priority 'itempath))
+ (if (null? test-dats)
+ test-dats
+ (begin
+ (let* ((tnames '()) ;; list of names used to reserve order
+ (tests (make-hash-table)) ;; hash of lists, used to build as we go
+ (itemized (get-itemized-tests test-dats)))
+ (for-each
+ (lambda (testdat)
+ (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat))
+ (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat)))
+ ;; (seen (hash-table-ref/default tests tname #f)))
+ (if (not (member tname tnames))
+ (if (or (and (eq? priority 'itempath)
+ (not (equal? ipath "")))
+ (and (eq? priority 'testname)
+ (equal? ipath ""))
+ (not (member tname itemized)))
+ (set! tnames (append tnames (list tname)))))
+ (if (equal? ipath "")
+ ;; This a top level, prepend it
+ (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
+ ;; This is item, append it
+ (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
+ test-dats)
+ ;; Set all tests with items
+ (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames)
+ '()
+ (filter (lambda (tname)
+ (let ((tlst (hash-table-ref tests tname)))
+ (and (list tlst)
+ (> (length tlst) 1))))
+ tnames))
+ (dboard:tabdat-item-test-names tabdat)))
+ (let loop ((hed (car tnames))
+ (tal (cdr tnames))
+ (res '()))
+ (let ((newres (append res (hash-table-ref tests hed))))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))))
+
+;; optimized to get runs constrained by what is visible on the screen
+;; - not appropriate for where all the runs are needed
+;;
+(define (update-buttons tabdat uidat numruns numtests)
+ (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns)
+ (take-right (dboard:tabdat-allruns tabdat) numruns)
+ (pad-list (dboard:tabdat-allruns tabdat) numruns)))
+ (lftcol (dboard:uidat-get-lftcol uidat))
+ (tableheader (dboard:uidat-get-header uidat))
+ (table (dboard:uidat-get-runsvec uidat))
+ (coln 0)
+ (all-test-names (make-hash-table))
+ (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work
+ )
+ ;; create a concise list of test names
+ ;;
+ (for-each
+ (lambda (rundat)
+ (if rundat
+ (let* ((testdats (dboard:rundat-tests rundat))
+ (testnames (map test:test-get-fullname (hash-table-values testdats))))
+ (dcommon: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)
+ (hash-table-set! all-test-names testname #t))
+ testnames)))))
+ runs)
+
+ ;; create the minimize list of testnames to be displayed. Sorting
+ ;; happens here *before* trimming
+ ;;
+ (dboard:tabdat-all-test-names-set!
+ tabdat
+ (collapse-rows
+ tabdat
+ (sort (filter string? (hash-table-keys all-test-names)) string>?))) ;; FIXME: Sorting needs to happen here
+
+ ;; Trim the names list to fit the matrix of buttons
+ ;;
+ (dboard:tabdat-all-test-names-set!
+ tabdat
+ (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat))
+ (drop (dboard:tabdat-all-test-names tabdat)
+ (dboard:tabdat-start-test-offset tabdat))
+ '())))
+ (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
+ (update-labels uidat (dboard:tabdat-all-test-names tabdat))
+ (for-each
+ (lambda (rundat)
+ ;; if rundat is junk clobber it with a decent placeholder
+ (if (or (not rundat) ;; handle padded runs
+ (not (dboard:rundat-run rundat)))
+ (set! rundat (dboard:rundat-make-init
+ key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat)))))
+ (let* ((run (dboard:rundat-run rundat))
+ (testsdat-by-name (dboard:rundat-tests-by-name rundat))
+ (key-val-dat (dboard:rundat-key-vals rundat))
+ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
+ (key-vals (append key-val-dat
+ (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
+ (if (string? x) x "")))))
+ (run-key (string-intersperse key-vals "\n")))
+
+ ;; fill in the run header key values
+ ;;
+ (let ((rown 0)
+ (headercol (vector-ref tableheader coln)))
+ (for-each (lambda (kval)
+ (let* ((labl (vector-ref headercol rown)))
+ (if (not (equal? kval (iup:attribute labl "TITLE")))
+ (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
+ (set! rown (+ rown 1))))
+ key-vals))
+
+ ;; For this run now fill in the buttons for each test
+ ;;
+ (let ((rown 0)
+ (columndat (vector-ref table coln)))
+ (for-each
+ (lambda (testname)
+ (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f)))
+ (if (and buttondat
+ (hash-table? testsdat-by-name))
+ (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f)))
+ ;; (filter
+ ;; (lambda (x)(equal? (test:test-get-fullname x) testname))
+ ;; testsdat)))
+ (if (not matching)
+ (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
+ ;; (car matching))))
+ matching)))
+ (testname (db:test-get-testname testdat))
+ (itempath (db:test-get-item-path testdat))
+ (testfullname (test:test-get-fullname testdat))
+ (teststatus (db:test-get-status testdat))
+ (teststate (db:test-get-state testdat))
+ ;;(teststart (db:test-get-event_time test))
+ ;;(runtime (db:test-get-run_duration test))
+ (buttontxt (cond
+ ((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
+ ((and (equal? teststate "NOT_STARTED")
+ (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
+ teststatus)
+ (else
+ teststate)))
+ (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))
+ (if use-bgcolor
+ (iup:attribute-set! button "BGCOLOR" color)
+ (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color))))
+ (if (and (not use-bgcolor) ;; bgcolor does not work with text
+ (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 testdat)
+ (vector-set! buttondat 4 run-key)))
+ (set! rown (+ rown 1))))
+ (dboard:tabdat-all-test-names tabdat)))
+ (set! coln (+ coln 1))))
+ runs)))
+
+(define (mkstr . x)
+ (string-intersperse (map conc x) ","))
+
+(define (set-bg-on-filter commondat tabdat)
+ (let ((search-changed (not (null? (filter (lambda (key)
+ (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%")))
+ (hash-table-keys (dboard:tabdat-searchpatts tabdat))))))
+ (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))))
+ (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))))))
+ (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR"
+ (if (or search-changed
+ state-changed
+ status-changed)
+ "190 180 190"
+ "190 190 190"
+ ))
+ (dboard:tabdat-filters-changed-set! tabdat #t)))
+
+(define (update-search commondat tabdat x val)
+ (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
+ (dboard:tabdat-filters-changed-set! tabdat #t)
+ (mark-for-update tabdat)
+ (set-bg-on-filter commondat tabdat))
+
+;; force ALL updates to zero (effectively)
+;;
+(define (mark-for-update tabdat)
+ (dboard:tabdat-last-db-update-set! tabdat (make-hash-table)))
+
+;;======================================================================
+;; R U N C O N T R O L
+;;======================================================================
+
+;; target populating logic
+;;
+;; lb =
+;; field = target field name for this dropdown
+;; referent-vals = selected value in the left dropdown
+;; targets = list of targets to use to build the dropdown
+;;
+;; each node is chained: key1 -> key2 -> key3
+;;
+;; must select values from only apropriate targets
+;; a b c
+;; a d e
+;; a b f
+;; a/b => c f
+;;
+(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs)
+ ;; is the current value in the new list? choose new default if not
+ (let* ((remvalues (map (lambda (row)
+ (common:list-is-sublist referent-vals (vector->list row)))
+ targets))
+ (values (delete-duplicates (map car (filter list? remvalues))))
+ (sel-valnum (iup:attribute lb "VALUE"))
+ (sel-val (iup:attribute lb sel-valnum))
+ (val-num 1))
+ ;; first check if the current value is in the new list, otherwise replace with
+ ;; first value from values
+ (iup:attribute-set! lb "REMOVEITEM" "ALL")
+ (for-each (lambda (val)
+ ;; (iup:attribute-set! lb "APPENDITEM" val)
+ (iup:attribute-set! lb (conc val-num) val)
+ (if (equal? sel-val val)
+ (iup:attribute-set! lb "VALUE" val-num))
+ (set! val-num (+ val-num 1)))
+ values)
+ (let ((val (iup:attribute lb "VALUE")))
+ (if val
+ val
+ (if (not (null? values))
+ (let ((newval (car values)))
+ (iup:attribute-set! lb "VALUE" newval)
+ newval))))))
+
+(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
+ (let* ((runconf-targs (common:get-runconfig-targets *runconfigdat*))
+ (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))
+ (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 "x60"
+ #:fontsize "10"
+ #:expand "YES" ;; "VERTICAL"
+ ;; #:dropdown "YES"
+ #:editbox "YES"
+ #:action (lambda (obj a b c)
+ (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)))
+ (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))))))))
+
+;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string
+;; interspersed with commas
+;;
+(define (dashboard:text-list-toggle-box items proc)
+ (let ((alltgls (make-hash-table)))
+ (apply iup:vbox
+ (map (lambda (item)
+ (iup:toggle
+ item
+ #:fontsize 8
+ #:expand "YES"
+ #:action (lambda (obj tstate)
+ (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))))
+
+;;======================================================================
+;; R U N C O N T R O L S
+;;======================================================================
+;;
+;; A gui for launching tests
+;;
+
+(define (dboard:target-updater tabdat) ;; key-listboxes)
+ (let ((targ (map (lambda (x)
+ (iup:attribute x "VALUE"))
+ (car (dashboard:update-target-selector tabdat))))
+ (curr-runname (dboard:tabdat-run-name tabdat)))
+ (dboard:tabdat-target-set! tabdat targ)
+ ;; (if (dboard:tabdat-updater-for-runs tabdat)
+ ;; ((dboard:tabdat-updater-for-runs tabdat)))
+ (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
+ (equal? (dboard:tabdat-run-name tabdat) ""))
+ (dboard:tabdat-run-name-set! tabdat curr-runname))
+ (dashboard:update-run-command tabdat)))
+
+;; used by run-controls
+;;
+(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
+ (let* ((tb (dboard:tabdat-runs-tree tabdat))
+ (runconf-targs (common:get-runconfig-targets *runconfigdat*))
+ (db-target-dat (rmt:get-targets))
+ (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
+ (header (vector-ref db-target-dat 0))
+ (db-targets (vector-ref db-target-dat 1))
+ (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
+ (take (append (string-split x "/")
+ (make-list (length header) "na"))
+ (length header))))
+ (all-targets (append (list (munge-target (string-intersperse
+ (map (lambda (x) "%") header)
+ "/")))
+ (map vector->list db-targets)
+ (map munge-target
+ runconf-targs)
+ )))
+ (for-each
+ (lambda (target)
+ (if (not (hash-table-ref/default runs-tree-ht target #f))
+ ;; (let ((existing (tree:find-node tb target)))
+ ;; (if (not existing)
+ (begin
+ (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name))
+ (hash-table-set! runs-tree-ht target #t))))
+ all-targets)))
+
+;; Run controls panel
+;;
+(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)
+ (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
+ (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
+ (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
+ (test-patterns-textbox #f))
+ (hash-table-set! tests-draw-state 'first-time #t)
+ ;; (hash-table-set! tests-draw-state 'scalef 1)
+ (tests:get-full-data test-names test-records '() all-tests-registry)
+ (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
+
+ ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
+ (let* ((result
+ (iup:vbox
+ (dcommon:command-execution-control tabdat)
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 200
+ ;;
+ ;; (iup:split
+ ;; #:value 300
+
+ ;; Target, testpatt, state and status input boxes
+ ;;
+ (iup:split
+ #:orientation "HORIZONTAL"
+ (iup:vbox
+ ;; Command to run, placed over the top of the canvas
+ (dcommon:command-action-selector commondat tabdat tab-num: tab-num)
+ (dboard:runs-tree-browser commondat tabdat))
+ (iup:vbox
+ (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
+ (dcommon:command-testname-selector commondat tabdat update-keyvals)))
+ ;; key-listboxes))
+ (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
+ (tb (dboard:tabdat-runs-tree tabdat)))
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
+ (dashboard:update-tree-selector tabdat)))
+ tab-num: tab-num)
+ result)))
+
+ ;;(iup:frame
+ ;; #:title "Logs" ;; To be replaced with tabs
+ ;; (let ((logs-tb (iup:textbox #:expand "YES"
+ ;; #:multiline "YES")))
+ ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
+ ;; logs-tb))
+
+;; browse runs as a tree. Used in both "Runs" tab and
+;; in the runs control panel.
+;;
+(define (dboard:runs-tree-browser commondat tabdat)
+ (let* ((txtbox (iup:textbox
+ #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; for the Runs view we put the list
+ ;; of keyvals into tabdat target for
+ ;; the Run Controls we put then update
+ ;; the run-command
+ (if b (dboard:tabdat-target-set! tabdat
+ (string-split b "/")))
+ (dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #:expand "HORIZONTAL"
+ ;; #:size "10x30"
+ ))
+ (tb
+ (iup:treebox
+ #:value 0
+ #:title "Runs" ;; was #:name -- iup 3.19 changed
+ ;; this... "Changed: [DEPRECATED
+ ;; REMOVED] removed the old attribute
+ ;; NAMEid from IupTree to avoid
+ ;; conflict with the common attribute
+ ;; NAME. Use the TITLEid attribute."
+ #:expand "YES"
+ #:addexpanded "YES"
+ #:size "10x"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+ ;; done below when run-id is a number
+ (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
+ ;; "run-path:
+ ;; "
+ ;; run-path)
+ (iup:attribute-set! txtbox "VALUE"
+ (string-intersperse (cdr run-path) "/"))
+ (dashboard:update-run-command tabdat)
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (if (number? run-id)
+ (begin
+ ;; capture last two in tabdat.
+ (dboard:tabdat-prev-run-id-set!
+ tabdat
+ (dboard:tabdat-curr-run-id tabdat))
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-view-changed-set! tabdat #t))
+ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+ "treebox"))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
+ (dboard:tabdat-runs-tree-set! tabdat tb)
+ (iup:detachbox
+ (iup:vbox
+ txtbox
+ tb
+ ))))
+
+;; browse runs as a tree. Used in both "Runs" tab and
+;; in the runs control panel.
+;;
+;; THIS IS THE NEW ONE
+;;
+(define (dboard:runs-tree-new-browser commondat rdat)
+ (let* ((txtbox (iup:textbox
+ #:action (lambda (val a b)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; for the Runs view we put the list
+ ;; of keyvals into tabdat target for
+ ;; the Run Controls we put then update
+ ;; the run-command
+ (if b (dboard:rdat-targ-sql-filt-set! rdat
+ (string-split b "/")))
+ #;(dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from?
+ ;; (dboard:tabdat-test-patts-use tabdat))
+ #:expand "HORIZONTAL"
+ ;; #:size "10x30"
+ ))
+ (tb
+ (iup:treebox
+ #:value 0
+ #:title "Runs" ;; was #:name -- iup 3.19 changed
+ ;; this... "Changed: [DEPRECATED
+ ;; REMOVED] removed the old attribute
+ ;; NAMEid from IupTree to avoid
+ ;; conflict with the common attribute
+ ;; NAME. Use the TITLEid attribute."
+ #:expand "YES"
+ #:addexpanded "YES"
+ #:size "10x"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (new-tree-path->run-id rdat (cdr run-path))))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+ ;; done below when run-id is a number
+ (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
+ ;; "run-path:
+ ;; "
+ ;; run-path)
+ (iup:attribute-set! txtbox "VALUE"
+ (string-intersperse (cdr run-path) "/"))
+ #;(dashboard:update-run-command tabdat)
+ #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (if (number? run-id)
+ (begin
+ ;; capture last two in tabdat.
+ (dboard:rdat-push-run-id rdat run-id)
+ (dboard:rdat-view-changed-set! rdat #t))
+ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+ "treebox"))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
+ (dboard:rdat-runs-tree-set! rdat tb)
+ (iup:detachbox
+ (iup:vbox
+ txtbox
+ tb
+ ))))
+
+;;======================================================================
+;; R U N C O N T R O L S
+;;======================================================================
+;;
+;; A gui for launching tests
+;;
+(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
+ (let* ((drawing (vg:drawing-new))
+ (run-times-tab-updater (lambda ()
+ (debug:catch-and-dump
+ (lambda ()
+ (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (if tabdat
+ (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
+ (now-time (current-seconds)))
+ (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
+ (if (> (- now-time last-data-update) 5)
+ (if (not (dboard:tabdat-running-layout tabdat))
+ (begin
+ (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
+ (dboard:tabdat-last-data-update-set! tabdat now-time)
+ ;; this is threadified to return control to the gui for a redraw.
+ ;; it relies on the running-layout flag to prevent overlapping
+ ;; calls.
+ (thread-start! (make-thread
+ (lambda ()
+ (dboard:tabdat-running-layout-set! tabdat #t)
+ (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
+ (dboard:tabdat-running-layout-set! tabdat #f))
+ "run-times-tab-layout-updater")))
+ ))))))
+ "dashboard:run-times-tab-updater")))
+ (key-listboxes #f) ;;
+ (update-keyvals (lambda ()
+ (dboard:target-updater tabdat))))
+ (dboard:tabdat-drawing-set! tabdat drawing)
+ (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 150
+ (iup:vbox
+
+ (dboard:runs-tree-browser commondat tabdat)
+
+ (iup:hbox
+ (iup:toggle
+ "Compact layout"
+ #:fontsize 8
+ #:expand "HORIZONTAL"
+ #:value 1
+ #:action (lambda (obj tstate)
+ (debug:catch-and-dump
+ (lambda ()
+ (print "tstate: " tstate)
+ (if (eq? tstate 0)
+ (dboard:tabdat-compact-layout-set! tabdat #f)
+ (dboard:tabdat-compact-layout-set! tabdat #t))
+ (dboard:tabdat-last-filter-str-set! tabdat "")
+ )
+ "text-list-toggle-box"))))
+ (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
+ (dcommon:command-testname-selector commondat tabdat update-keyvals))
+ (iup:vbox
+ (iup:split
+ #:orientation "HORIZONTAL"
+ #:value 800
+ (let* ((cnv-obj (iup:canvas
+ ;; #:size "250x250" ;; "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)
+ (let* ((hb1 (iup:hbox))
+ (graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
+ (changed #f)
+ (graph-matrix (iup:matrix
+ #:alignment1 "ALEFT"
+ ;; #:expand "YES" ;; "HORIZONTAL"
+ #:scrollbar "YES"
+ #:numcol 10
+ #:numlin 20
+ #:numcol-visible 5 ;; (min 8)
+ #:numlin-visible 1
+ #:click-cb
+ (lambda (obj row col status)
+ (let*
+ ((graph-cell (conc row ":" col))
+ (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f))
+ (graph-flag (dboard:graph-dat-flag graph-dat)))
+ (if graph-flag
+ (dboard:graph-dat-flag-set! graph-dat #f)
+ (dboard:graph-dat-flag-set! graph-dat #t))
+ (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 (current-seconds))
+ (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"))))
+ ;;(dboard:tabdat-view-changed-set! tabdat #t)
+ )))))
+ (dboard:tabdat-graph-matrix-set! tabdat graph-matrix)
+ (iup:attribute-set! graph-matrix "WIDTH0" 0)
+ (iup:attribute-set! graph-matrix "HEIGHT0" 0)
+ graph-matrix))
+ (iup:hbox
+ (iup:vbox
+ (iup:button "Show All" #:action (lambda (obj)
+ (for-each (lambda (graph-cell)
+ (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
+ (dboard:graph-dat-flag-set! graph-dat #t)))
+ (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))
+ (iup:hbox
+ (iup:button "Hide All" #:action (lambda (obj)
+ (for-each (lambda (graph-cell)
+ (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
+ (dboard:graph-dat-flag-set! graph-dat #f)))
+ (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))))
+ ))))
+
+;;======================================================================
+;; 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 (new-tree-path->run-id rdat path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f)
+ #f))
+
+;; (define (dboard:get-tests-dat tabdat run-id last-update)
+;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
+;; run-id
+;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
+;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
+;; #f #f ;; offset limit
+;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in
+;; #f #f ;; sort-by sort-order
+;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
+;; (if (dboard:tabdat-filters-changed tabdat)
+;; 0
+;; last-update)
+;; *dashboard-mode*)
+;; '()))) ;; get 'em all
+;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
+;; (sort tdat (lambda (a b)
+;; (let* ((aval (vector-ref a 2))
+;; (bval (vector-ref b 2))
+;; (anum (string->number aval))
+;; (bnum (string->number bval)))
+;; (if (and anum bnum)
+;; (< anum bnum)
+;; (string<= aval bval)))))))
+
+
+(define (dashboard:safe-cadr-assoc name lst)
+ (let ((res (assoc name lst)))
+ (if (and res (> (length res) 1))
+ (cadr res)
+ #f)))
+
+(define (dboard:update-tree tabdat runs-hash runs-header tb)
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (run-ids (sort (filter number? (hash-table-keys runs-hash))
+ (lambda (a b)
+ (let* ((record-a (hash-table-ref runs-hash a))
+ (record-b (hash-table-ref runs-hash b))
+ (time-a (db:get-value-by-header record-a runs-header "event_time"))
+ (time-b (db:get-value-by-header record-b runs-header "event_time")))
+ (< time-a time-b)))))
+ (changed #f)
+ (last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (for-each (lambda (run-id)
+ (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
+ (key-vals (map (lambda (key)
+ (let ((val (db:get-value-by-header run-record runs-header key)))
+ (if (string? val) val "")))
+ (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))))
+ (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
+ ;; (let ((existing (tree:find-node tb run-path)))
+ ;; (if (not existing)
+ (begin
+ (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
+ ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
+ ;; (conc rownum ":" colnum) col-name)
+ ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
+ ;; Here we update the tests treebox and tree keys
+ (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
+ ;; userdata: (conc "run-id: " run-id))))
+ (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
+ ;; (set! colnum (+ colnum 1))
+ ))))
+ run-ids)))
+
+(define (dashboard:tests-ht->tests-dat tests-ht)
+ (reverse
+ (sort
+ (hash-table-values tests-ht)
+ (lambda (a b)
+ (let ((a-test-name (db:test-get-testname a))
+ (a-item-path (db:test-get-item-path a))
+ (b-test-name (db:test-get-testname b))
+ (b-item-path (db:test-get-item-path b))
+ (a-event-time (db:test-get-event_time a))
+ (b-event-time (db:test-get-event_time b)))
+ (if (not (equal? a-test-name b-test-name))
+ (> a-event-time b-event-time)
+ (cond
+ ((< 0 (string-compare3 a-test-name b-test-name)) #t)
+ ((> 0 (string-compare3 a-test-name b-test-name)) #f)
+ ((< 0 (string-compare3 a-item-path b-item-path)) #t)
+ (else #f))))))))
+
+
+(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
+ (let* ((run (hash-table-ref/default runs-hash run-id #f))
+ (key-vals (rmt:get-key-vals run-id))
+ (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ (tests-dat (dashboard:tests-ht->tests-dat tests-ht))
+ (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
+ (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
+ (when (not run)
+ (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
+ (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
+ )
+ tests-mindat))
+
+(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
+ (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
+ (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
+ (if (and src-run-id dest-run-id)
+ (dcommon:xor-tests-mindat
+ (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
+ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
+ hide-clean: hide-clean)
+ #f)))
+
+
+(define (dashboard:get-runs-hash tabdat)
+ (let* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (runs (vector-ref runs-dat 1))
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
+ runs) ht)))
+ runs-hash))
+
+
+(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
+ ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
+ (dashboard:do-update-rundat tabdat) ;; )
+ (dboard:runs-summary-control-panel-updater tabdat)
+ (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (runs (vector-ref runs-dat 1))
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (runs-hash (dashboard:get-runs-hash tabdat))
+ ;; (runs-hash (let ((ht (make-hash-table)))
+ ;; (for-each (lambda (run)
+ ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
+ ;; runs)
+ ;; ht))
+ )
+ (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
+ (dboard:update-tree tabdat runs-hash runs-header tb))
+ (if run-id
+ (let* ((matrix-content
+ (case (dboard:tabdat-runs-summary-mode tabdat)
+ ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
+ ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
+ ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
+ (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
+ (when matrix-content
+ (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell))
+ (row-indices (cadr indices))
+ (col-indices (car indices))
+ (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
+ (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
+ (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
+ (numrows 1)
+ (numcols 1)
+ (changed #f)
+ )
+
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (let loop ((pass-num 0)
+ (changed #f))
+ ;; Update the runs tree
+ ;; (dboard:update-tree tabdat runs-hash runs-header tb)
+
+ (if (eq? pass-num 1)
+ (begin ;; big reset
+ (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
+ (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
+ (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
+
+ (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
+ (iup:attribute-set! run-matrix "NUMCOL" max-col ))
+
+ (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
+ (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
+ (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
+
+ ;; Row labels
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc num ":0")))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)))))
+ row-indices)
+ ;; (print "row-indices: " row-indices " col-indices: " col-indices)
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass
+
+ ;; Cell contents
+ (for-each (lambda (entry)
+ ;; (print "entry: " entry)
+ (let* ((row-name (cadr entry))
+ (col-name (car entry))
+ (valuedat (caddr entry))
+ (test-id (list-ref valuedat 0))
+ (test-name row-name) ;; (list-ref valuedat 1))
+ (item-path col-name) ;; (list-ref valuedat 2))
+ (state (list-ref valuedat 1))
+ (status (list-ref valuedat 2))
+ (value (gutils:get-color-for-state-status state status))
+ (row-num (cadr (assoc row-name row-indices)))
+ (col-num (cadr (assoc col-name col-indices)))
+ (key (conc row-num ":" col-num)))
+ (hash-table-set! cell-lookup key test-id)
+ (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key (cadr value))
+ (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
+ matrix-content)
+
+ ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
+
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)
+ (if (<= num max-col)
+ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
+ col-indices)
+
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass due to column labels changing
+
+ ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)
+ ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num)
+ (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))))))
+
+;;======================================================================
+;; S U M M A R Y
+;;======================================================================
+;;
+;; General info about the run(s) and megatest area
+(define (dashboard:summary commondat tabdat #!key (tab-num #f))
+ (let* ((rawconfig (configf: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 300
+ (iup:frame
+ #:title "General Info"
+ (iup:vbox
+ (iup:hbox
+ (iup:label "Area Path")
+ (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
+ (iup:hbox
+ (dcommon:keys-matrix rawconfig)
+ (dcommon:general-info)
+ )))
+ (iup:frame
+ #:title "Server"
+ (dcommon:servers-table commondat tabdat)))
+ (iup:frame
+ #:title "Megatest config settings"
+ (iup:hbox
+ (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
+ (iup:vbox
+ (dcommon:section-matrix rawconfig "server" "Varname" "Value")
+ ;; (iup:frame
+ ;; #:title "Disks Areas"
+ (dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
+ (iup:frame
+ #:title "Run statistics"
+ (dcommon:run-stats commondat tabdat tab-num: tab-num)))))
+
+;;======================================================================
+;; H A N D L E U S E R C O N T R I B U T E D V I E W S
+;;======================================================================
+
+(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num)
+ (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load.
+ (source (configf:lookup views-cfgdat view-name "source"))
+ (viewgen (configf:lookup views-cfgdat view-name "viewgen"))
+ (updater (configf:lookup views-cfgdat view-name "updater"))
+ (result-child #f))
+ (if (and (common:file-exists? source)
+ (file-readable? source))
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl")
+ (set! success #f))
+ (load source))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name)))
+ ;; now run the user supplied definition for the tab view
+ (if success
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen
+ ", with; tab-num=" tab-num ", view-name=" view-name
+ ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
+ (set! success #f))
+ (print "Adding tab " view-name " with proc " viewgen)
+ ;; (iup:child-add! tabs
+ (set! result-child
+ ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
+ ;; and finally set the updater
+ (if success
+ (dboard:commondat-add-updater commondat
+ (lambda ()
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater
+ "\", with; tabnum=" tab-num ", view-name=" view-name
+ ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
+ (set! success #f))
+ (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num)
+ ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*)))
+ tab-num: tab-num))
+ ;;(if success
+ ;; (begin
+ ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name)
+ ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data))))
+ result-child))
+
+
+
+(define (dboard:runs-summary-buttons-updater tabdat)
+ (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat))
+ (modes-left (dboard:tabdat-runs-summary-modes tabdat)))
+ (if (or (null? buttons-left) (null? modes-left))
+ #t
+ (let* ((this-button (car buttons-left))
+ (mode-item (car modes-left))
+ (this-mode (car mode-item))
+ (sel-color "180 100 100")
+ (nonsel-color "170 170 170")
+ (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
+ (if (eq? this-mode current-mode)
+ (iup:attribute-set! this-button "BGCOLOR" sel-color)
+ (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
+ (loop (cdr buttons-left) (cdr modes-left))))))
+
+(define (dboard:runs-summary-xor-labels-updater tabdat)
+ (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
+ (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
+ (mode (dboard:tabdat-runs-summary-mode tabdat)))
+ (when (and source-runname-label dest-runname-label)
+ (case mode
+ ((xor-two-runs xor-two-runs-hide-clean)
+ (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
+ (prev-run-id (dboard:tabdat-prev-run-id tabdat))
+ (curr-runname (if curr-run-id
+ (rmt:get-run-name-from-id curr-run-id)
+ "None"))
+ (prev-runname (if prev-run-id
+ (rmt:get-run-name-from-id prev-run-id)
+ "None")))
+ (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
+ (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
+ (else
+ (iup:attribute-set! source-runname-label "TITLE" "")
+ (iup:attribute-set! dest-runname-label "TITLE" ""))))))
+
+(define (dboard:runs-summary-control-panel-updater tabdat)
+ (dboard:runs-summary-xor-labels-updater tabdat)
+ (dboard:runs-summary-buttons-updater tabdat))
+
+
+;; setup buttons and callbacks to switch between modes in runs summary tab
+;;
+(define (dashboard:runs-summary-control-panel tabdat)
+ (let* ((summary-buttons ;; build buttons
+ (map
+ (lambda (mode-item)
+ (let* ((this-mode (car mode-item))
+ (this-mode-label (cdr mode-item)))
+ (iup:button this-mode-label
+ #:action
+ (lambda (obj)
+ (debug:catch-and-dump
+ (lambda ()
+ (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
+ (dboard:runs-summary-control-panel-updater tabdat))
+ "runs summary control panel updater")))))
+ (dboard:tabdat-runs-summary-modes tabdat)))
+ (summary-buttons-hbox (apply iup:hbox summary-buttons))
+ (xor-runname-labels-hbox
+ (iup:hbox
+ (let ((temp-label
+ (iup:label "" #:size "125x15" #:fontsize "10" )))
+ (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
+ temp-label
+ )
+ (let ((temp-label
+ (iup:label "" #:size "125x15" #:fontsize "10")))
+ (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
+ temp-label))))
+ (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
+
+ ;; maybe wrap in a frame
+ (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
+ (dboard:runs-summary-control-panel-updater tabdat)
+ res
+ )))
+
+
+
+;;======================================================================
+;; R U N
+;;======================================================================
+;;
+;; display and manage a single run at a time
+
+;; This is the Run Summary tab
+;;
+(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
+ (let* ((update-mutex (dboard:commondat-update-mutex commondat))
+ (tb (iup:treebox
+ #:value 0
+ ;;#:name "Runs"
+ #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
+ #:expand "YES"
+ #:addexpanded "YES"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ (if (number? run-id)
+ (begin
+ (dboard:tabdat-prev-run-id-set!
+ tabdat
+ (dboard:tabdat-curr-run-id tabdat))
+
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ ;; (dashboard:update-run-summary-tab)
+ )
+ ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
+ )))
+ "selection-cb in runs-summary")
+ ;; (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)
+ (debug:catch-and-dump
+ (lambda ()
+
+ ;; Bummer - we dont have the global get/set api mapped in chicken
+ ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
+ ;; (BB> "modkeys="modkeys))
+
+ (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
+ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
+ (let* ((toolpath (car (argv)))
+ (key (conc lin ":" col))
+ (test-id (hash-table-ref/default cell-lookup key -1))
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (run-info (rmt:get-run-info run-id))
+ (target (rmt:get-target run-id))
+ (runname (db:get-value-by-header (db:get-rows run-info)
+ (db:get-header run-info) "runname"))
+ (test-info (rmt:get-test-info-by-id run-id test-id))
+ (test-name (db:test-get-testname test-info))
+ (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
+ (if tlast
+ (let ((tpatt (tasks:task-get-testpatt tlast)))
+ (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
+ "%"
+ tpatt))
+ "%")))
+ (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
+ (item-test-path (conc test-name "/" (if (equal? item-path "")
+ "%"
+ item-path)))
+ (status-chars (char-set->list (string->char-set status)))
+ (run-id (dboard:tabdat-curr-run-id tabdat)))
+ (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
+ (cond
+ ((member #\1 status-chars) ;; 1 is left mouse button
+ (dboard:launch-testpanel run-id test-id))
+
+ ((member #\2 status-chars) ;; 2 is middle mouse button
+
+ (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ )
+ (else
+ (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ )
+ )
+
+ )) "runs-summary-click-callback"))))
+ (runs-summary-updater
+ (lambda ()
+ (mutex-lock! update-mutex)
+ (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater)
+ (dboard:tabdat-view-changed tabdat))
+ (debug:catch-and-dump
+ (lambda () ;; check that run-matrix is initialized before calling the updater
+ (if run-matrix
+ (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
+ "dashboard:runs-summary-updater")
+ )
+ (mutex-unlock! update-mutex)))
+ (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
+ )
+ (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
+ (dboard:tabdat-runs-tree-set! tabdat tb)
+ (iup:vbox
+ (iup:split
+ #:value 200
+ tb
+ run-matrix)
+ (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
+
+;;======================================================================
+;; R U N S
+;;======================================================================
+
+(define (dboard:squarify toggles size)
+ (let loop ((hed (car toggles))
+ (tal (cdr toggles))
+ (cur '())
+ (res '()))
+ (let* ((ovrflo (>= (length cur) size))
+ (newcur (if ovrflo
+ (list hed)
+ (cons hed cur)))
+ (newres (if ovrflo
+ (cons cur res)
+ res)))
+ (if (null? tal)
+ (if ovrflo
+ newres
+ (cons newcur res))
+ (loop (car tal)(cdr tal) newcur newres)))))
+
+(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
+ (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
+ (iup:hbox
+ (iup:vbox
+ (iup:frame
+ #:title "filter test and items"
+ (iup:vbox
+ (iup:hbox
+ (iup:vbox
+ (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
+ #:expand "NO"
+ #:action (lambda (obj unk val)
+ (debug:catch-and-dump
+ (lambda ()
+ (mark-for-update tabdat)
+ (update-search commondat tabdat "test-name" val))
+ "make-controls")))
+ (iup:hbox
+ (iup:button "Quit" #:action (lambda (obj)
+ (exit))
+ #:expand "NO" #:size "40x15")
+ (iup:button "Refresh" #:action (lambda (obj)
+ (dboard:tabdat-last-data-update-set! tabdat 0)
+ (dboard:tabdat-last-runs-update-set! tabdat 0)
+ (dboard:tabdat-run-update-times-set! tabdat (make-hash-table))
+ (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table))
+ (dboard:tabdat-allruns-set! tabdat '())
+ (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
+ (dboard:tabdat-done-runs-set! tabdat '())
+ (dboard:tabdat-not-done-runs-set! tabdat '())
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (dboard:commondat-please-update-set! commondat #t)
+ (mark-for-update tabdat))
+ #:expand "NO" #:size "40x15")
+ (iup:button "Collapse" #:action (lambda (obj)
+ (debug:catch-and-dump
+ (lambda ()
+ (let ((myname (iup:attribute obj "TITLE")))
+ (if (equal? myname "Collapse")
+ (begin
+ (for-each (lambda (tname)
+ (hash-table-set! *collapsed* tname #t))
+ (dboard:tabdat-item-test-names tabdat))
+ (iup:attribute-set! obj "TITLE" "Expand"))
+ (begin
+ (for-each (lambda (tname)
+ (hash-table-delete! *collapsed* tname))
+ (hash-table-keys *collapsed*))
+ (iup:attribute-set! obj "TITLE" "Collapse"))))
+ (mark-for-update tabdat))
+ "make-controls collapse button"))
+ #:expand "NO" #:size "40x15")))
+ (iup:vbox
+ ;; (iup:button "Sort -t" #:action (lambda (obj)
+ ;; (next-sort-option)
+ ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
+ ;; (mark-for-update tabdat)))
+
+ (let* ((hide #f)
+ (show #f)
+ (hide-empty #f)
+ (sel-color "180 100 100")
+ (nonsel-color "170 170 170")
+ (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
+ (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL"
+ #:size "80x15"
+ #:dropdown "YES"
+ #:action (lambda (obj val index lbstate)
+ (set! *tests-sort-reverse* index)
+ (mark-for-update tabdat))))
+ (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
+
+ (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
+
+ ;; (set! hide-empty (iup:button "HideEmpty"
+ ;; ;; #:expand HORIZONTAL"
+ ;; #:expand "NO" #:size "80x15"
+ ;; #:action (lambda (obj)
+ ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
+ ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
+ ;; (mark-for-update tabdat))))
+ (set! hide (iup:button "Hide"
+ #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
+ ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
+ (iup:attribute-set! hide "BGCOLOR" sel-color)
+ (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ (mark-for-update tabdat))))
+ (set! show (iup:button "Show"
+ #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj)
+ (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
+ (iup:attribute-set! show "BGCOLOR" sel-color)
+ (iup:attribute-set! hide "BGCOLOR" nonsel-color)
+ (mark-for-update tabdat))))
+ (iup:attribute-set! hide "BGCOLOR" sel-color)
+ (iup:attribute-set! show "BGCOLOR" nonsel-color)
+ ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
+ (iup:vbox
+ (iup:hbox hide show)
+ sort-lb)))
+ )
+
+ ;; insert extra widget here
+ (if extra-widget
+ extra-widget
+ (iup:hbox)) ;; empty widget
+
+
+
+
+ )))
+
+ (let* ((status-toggles (map (lambda (status)
+ (iup:toggle (conc status)
+ #:fontsize 8 ;; btn-fontsz ;; "10"
+ ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj val)
+ (mark-for-update tabdat)
+ (if (eq? val 1)
+ (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
+ (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
+ (set-bg-on-filter commondat tabdat))))
+ (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
+ (state-toggles (map (lambda (state)
+ (iup:toggle (conc state)
+ #:fontsize 8 ;; btn-fontsz
+ ;; #:expand "HORIZONTAL"
+ #:action (lambda (obj val)
+ (mark-for-update tabdat)
+ (if (eq? val 1)
+ (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
+ (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
+ (set-bg-on-filter commondat tabdat))))
+ (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
+ (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
+ (iup:vbox
+ (iup:hbox
+ (iup:frame
+ #:title "states"
+ (apply
+ iup:hbox
+ (map (lambda (colgrp)
+ (apply iup:vbox colgrp))
+ (dboard:squarify state-toggles 3))))
+ (iup:frame
+ #:title "statuses"
+ (apply
+ iup:hbox
+ (map (lambda (colgrp)
+ (apply iup:vbox colgrp))
+ (dboard:squarify status-toggles 3)))))
+ ;;
+ ;; (iup:frame
+ ;; #:title "state/status filter"
+ ;; (iup:vbox
+ ;; (apply
+ ;; iup:hbox
+ ;; (map
+ ;; (lambda (status-toggle state-toggle)
+ ;; (iup:vbox
+ ;; status-toggle
+ ;; state-toggle))
+ ;; status-toggles state-toggles))
+
+ ;; horizontal slider was here
+
+ )))))
+
+(define (dashboard:runs-horizontal-slider tabdat )
+ (iup:valuator #:valuechanged_cb (lambda (obj)
+ (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
+ (oldmax (string->number (iup:attribute obj "MAX")))
+ (maxruns (dboard:tabdat-tot-runs tabdat)))
+ (dboard:tabdat-start-run-offset-set! tabdat val)
+ (mark-for-update tabdat)
+ (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
+ (iup:attribute-set! obj "MAX" (* maxruns 10))))
+ #:expand "HORIZONTAL"
+ #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
+ #:min 0
+ #:step 0.01))
+
+;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
+;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004)
+;; simple-run-event_time procedure (x3834)
+;; simple-run-event_time-set! procedure (x3830 val3831)
+;; simple-run-id procedure (x3794)
+;; simple-run-id-set! procedure (x3790 val3791)
+;; simple-run-owner procedure (x3826)
+;; simple-run-owner-set! procedure (x3822 val3823)
+;; simple-run-runname procedure (x3802)
+;; simple-run-runname-set! procedure (x3798 val3799)
+;; simple-run-state procedure (x3810)
+;; simple-run-state-set! procedure (x3806 val3807)
+;; simple-run-status procedure (x3818)
+;; simple-run-status-set! procedure (x3814 val3815)
+;; simple-run-target procedure (x3786)
+;; simple-run-target-set! procedure (x3782 val3783)
+;; simple-run? procedure (x3780)
+
+
+;;======================================================================
+;; Extracting the data to display for runs
+;;
+;; This needs to be re-entrant such that it does one column per call
+;; on the zeroeth call update runs data
+;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
+;; on last run reset to zeroeth
+;;
+;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
+;; - put this information into two data structures:
+;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
+;; status, starttime, duration, non-deleted testcount>
+;; ordernum reflects order as received from sql query
+;; b. sparsevec of id => runstruct
+;; 2. for each run in runshash ordered by ordernum do:
+;; retrieve data since last update for that run
+;; if there is a deleted test - retrieve full data
+;; if there are non-deleted tests register this run in the columns sparsevec
+;; if this is the zeroeth column regenerate the rows sparsevec
+;; if this column is in the visible zone update visible cells
+;;
+;; Other factors:
+;; 1. left index handling:
+;; - add test/itempaths to left index as discovered, re-order and
+;; update row -> test/itempath mapping on each read run
+;;======================================================================
+
+;; runs is
+;; get ALL runs info
+;; update rdat-targ-run-id
+;; update rdat-runs
+;;
+(define (dashboard:update-runs-data rdat)
+ (let* ((tb (dboard:rdat-runs-tree rdat))
+ (targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
+ (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
+ (state-sql-filt (dboard:rdat-run-state-sql-filt rdat))
+ (status-sql-filt (dboard:rdat-run-status-sql-filt rdat))
+ ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+ (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
+ (numruns (length data)))
+ ;; store in the runsbynum vector
+ (dboard:rdat-runsbynum-set! rdat (list->vector data))
+ ;; update runs id => runrec
+ ;; update targ-runid target/runname => run-id
+ (for-each
+ (lambda (runrec)
+ (let* ((run-id (simple-run-id runrec))
+ (full-targ-runname (conc (simple-run-target runrec) "/"
+ (simple-run-runname runrec))))
+ (debug:print 0 *default-log-port* "Update run " run-id)
+ (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
+ (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
+ ))
+ data)
+ numruns))
+
+;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
+;;
+(define (dashboard:update-run-data runnum rdat)
+ (let* ((curr-time (current-seconds))
+ (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum))
+ (run-id (simple-run-id runrec))
+ (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
+ ;; filters
+ (testname-sql-filt (dboard:rdat-testname-sql-filt rdat))
+ ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat))
+ (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet
+ (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet
+ (tests (rmt:get-tests-for-run-state-status run-id
+ testname-sql-filt
+ last-update ;; last-update
+ )))
+ (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
+ (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
+ run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update)
+ (length tests)))
+
+(define (new-runs-updater commondat rdat)
+ (let* ((runnum (dboard:rdat-runnum rdat))
+ (start-time (current-milliseconds))
+ (tot-runs #f))
+ (if (eq? runnum 0)(dashboard:update-runs-data rdat))
+ (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
+ (let loop ((rn runnum))
+ (if (and (< (- (current-milliseconds) start-time) 250)
+ (< rn tot-runs))
+ (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
+ 0 ;; start over
+ (+ rn 1)))) ;; (+ runnum 1)))
+ (dashboard:update-run-data rn rdat)
+ (dboard:rdat-runnum-set! rdat newrn)
+ (if (> newrn 0)
+ (loop newrn)))))
+ (if (>= (dboard:rdat-runnum rdat) tot-runs)
+ (dboard:rdat-runnum-set! rdat 0))
+ ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
+ ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
+ ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
+ '()))
+
+(define (dboard:runs-new-matrix commondat rdat)
+ (iup:matrix
+ #:alignment1 "ALEFT"
+ ;; #:expand "YES" ;; "HORIZONTAL"
+ #:scrollbar "YES"
+ #:numcol 10
+ #:numlin 20
+ #:numcol-visible 5 ;; (min 8)
+ #:numlin-visible 1
+ #:click-cb
+ (lambda (obj row col status)
+ (let* ((cell (conc row ":" col)))
+ #f))
+ ))
+
+(define (make-runs-view commondat rdat tab-num)
+ ;; register an updater
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (new-runs-updater commondat rdat))
+ tab-num: tab-num)
+
+ (iup:vbox
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 100
+ (dboard:runs-tree-new-browser commondat rdat)
+ (dboard:runs-new-matrix commondat rdat)
+ )))
+
+(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
+ (let* ((stats-dat (dboard:tabdat-make-data))
+ (runs-dat (dboard:tabdat-make-data))
+ (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
+ (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
+ (runcontrols-dat (dboard:tabdat-make-data))
+ (runtimes-dat (dboard:tabdat-make-data))
+ (nruns (dboard:tabdat-numruns runs-dat))
+ (ntests (dboard:tabdat-num-tests runs-dat))
+ (keynames (dboard:tabdat-dbkeys runs-dat))
+ (nkeys (length keynames))
+ (runsvec (make-vector nruns))
+ (header (make-vector nruns))
+ (lftcol (make-vector ntests))
+ (keycol (make-vector ntests))
+ (controls (dboard:make-controls commondat runs-dat)) ;; '())
+ (lftlst '())
+ (hdrlst '())
+ (bdylst '())
+ (result '())
+ (i 0)
+ (btn-height (dboard:tabdat-runs-btn-height runs-dat))
+ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
+ (cell-width (dboard:tabdat-runs-cell-width runs-dat))
+ (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")))
+ ;; controls (along bottom)
+ ;; (set! controls (dboard:make-controls commondat runs-dat))
+
+ ;; create the left most column for the run key names and the test names
+ (set! lftlst
+ (list (iup:hbox
+ (iup:label) ;; (iup:valuator)
+ (apply iup:vbox
+ (map (lambda (x)
+ (let ((res (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:label x
+ #:size (conc 40 btn-height)
+ #:fontsize btn-fontsz
+ #:expand "NO") ;; "HORIZONTAL")
+ (iup:textbox
+ #:size (conc 35 btn-height)
+ #:fontsize btn-fontsz
+ #:value "%"
+ #:expand "NO" ;; "HORIZONTAL"
+ #:action (lambda (obj unk val)
+ ;; each field
+ ;; (field name is "x" var) live updates
+ ;; the search filter as it is typed
+ (dboard:tabdat-target-set! runs-dat #f)
+ ;; ensure fields text boxes are used
+ ;; and not the info from the tree
+ (mark-for-update runs-dat)
+ (update-search commondat runs-dat x val))))))
+ (set! i (+ i 1))
+ res))
+ keynames)))))
+ (let loop ((testnum 0)
+ (res '()))
+ (cond
+ ((>= testnum ntests)
+ ;; now lftlst will be an hbox with the test keys and the test name labels
+ (set! lftlst
+ (append
+ lftlst
+ (list
+ (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:valuator
+ #:valuechanged_cb
+ (lambda (obj)
+ (let ((val (string->number (iup:attribute obj "VALUE")))
+ (oldmax (string->number (iup:attribute obj "MAX")))
+ (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-start-test-offset-set! runs-dat
+ (inexact->exact (round (/ val 10))))
+ (debug:print 6 *default-log-port*
+ "(dboard:tabdat-start-test-offset runs-dat) "
+ (dboard:tabdat-start-test-offset runs-dat) " val: " val
+ " newmax: " newmax " oldmax: " oldmax)
+ (if (< val 10)
+ (iup:attribute-set! obj "MAX" newmax))
+ ))
+ #:expand "VERTICAL"
+ #:orientation "VERTICAL"
+ #:min 0
+ #:step 0.01)
+ (apply iup:vbox (reverse res)))))))
+ (else
+ (let ((labl (iup:button
+ "" ;; the testname labels
+ #:flat "YES"
+ #:alignment "ALEFT"
+ ; #:image img1
+ ; #:impress img2
+ #:size (conc cell-width btn-height)
+ #:expand "HORIZONTAL"
+ #:fontsize btn-fontsz
+ #:action (lambda (obj)
+ (mark-for-update runs-dat)
+ (toggle-hide testnum (dboard:commondat-uidat commondat))))))
+ (vector-set! lftcol testnum labl)
+ (loop (+ testnum 1)(cons labl res))))))
+ ;; These are the headers for each row
+ (let loop ((runnum 0)
+ (keynum 0)
+ (keyvec (make-vector nkeys))
+ (res '()))
+ (cond ;; nb// no else for this approach.
+ ((>= runnum nruns) #f)
+ ((>= keynum nkeys)
+ (vector-set! header runnum keyvec)
+ (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst))
+ (loop (+ runnum 1) 0 (make-vector nkeys) '()))
+ (else
+ (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15"
+ (vector-set! keyvec keynum labl)
+ (loop runnum (+ keynum 1) keyvec (cons labl res))))))
+ ;; By here the hdrlst contains a list of vboxes containing nkeys labels
+ (let loop ((runnum 0)
+ (testnum 0)
+ (testvec (make-vector ntests))
+ (res '()))
+ (cond
+ ((>= runnum nruns) #f) ;; (vector tableheader runsvec))
+ ((>= testnum ntests)
+ (vector-set! runsvec runnum testvec)
+ (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
+ (loop (+ runnum 1) 0 (make-vector ntests) '()))
+ (else
+ (let* ((button-key (mkstr runnum testnum))
+ (butn (iup:button
+ (if use-bgcolor #f " ") ;; button-key
+ #:size (conc cell-width btn-height )
+ #:expand "HORIZONTAL"
+ #:fontsize btn-fontsz
+ #:button-cb
+ (lambda (obj a pressed x y btn . rem)
+ ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
+ (if (substring-index "3" btn)
+ (if (eq? pressed 1)
+ (let* ((toolpath (car (argv)))
+ (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
+ (test-id (db:test-get-id (vector-ref buttndat 3)))
+ (run-id (db:test-get-run_id (vector-ref buttndat 3)))
+ (run-info (rmt:get-run-info run-id))
+ (target (rmt:get-target run-id))
+ (runname (db:get-value-by-header (db:get-rows run-info)
+ (db:get-header run-info) "runname"))
+ (test-info (rmt:get-test-info-by-id run-id test-id))
+ (test-name (db:test-get-testname test-info))
+ (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
+ (if tlast
+ (let ((tpatt (tasks:task-get-testpatt tlast)))
+ (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
+ "%"
+ tpatt))
+ "%")))
+ (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
+ (item-test-path (conc test-name "/" (if (equal? item-path "")
+ "%"
+ item-path))))
+ (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ ;; (print "got here")
+ ))
+ (if (eq? pressed 0)
+ (let* ((toolpath (car (argv)))
+ (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
+ (test-id (db:test-get-id (vector-ref buttndat 3)))
+ (run-id (db:test-get-run_id (vector-ref buttndat 3))))
+ (dboard:launch-testpanel run-id test-id))))))))
+ (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR")
+ (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f))
+ (vector-set! testvec testnum butn)
+ (loop runnum (+ testnum 1) testvec (cons butn res))))))
+ ;; now assemble the hdrlst and bdylst and kick off the dialog
+ (iup:show
+ (iup:dialog
+ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
+ #:menu (dcommon:main-menu)
+ (let* ((runs-view (iup:vbox
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 100
+ (dboard:runs-tree-browser commondat runs-dat)
+ (iup:split
+ #:value 100
+ ;; left most block, including row names
+ (apply iup:vbox lftlst)
+ ;; right hand block, including cells
+ (iup:vbox
+ #:expand "YES"
+ ;; the header
+ (apply iup:hbox (reverse hdrlst))
+ (apply iup:hbox (reverse bdylst))
+ (dashboard:runs-horizontal-slider runs-dat))))
+ controls
+ ))
+ (views-cfgdat (common:load-views-config))
+ (additional-tabnames '())
+ (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
+ ;; (data (dboard:tabdat-init (make-d:data)))
+ (additional-views ;; process views-dat
+ (let ((tab-num tab-start-num)
+ (result '()))
+ (for-each
+ (lambda (view-name)
+ (debug:print 0 *default-log-port* "Adding view " view-name)
+ (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
+ (if (not (string? cfgtype))
+ (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
+ "\" is missing needed sections. "
+ "Please consult the documenation and update ~/.mtviews.config or "
+ *toppath* "/.mtviews.config")
+ (case (string->symbol cfgtype)
+ ;; user supplied source for a tab
+ ;;
+ ((external) ;; was tabs
+ (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num)))
+ (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
+ (set! tab-num (+ tab-num 1))
+ (set! result (append result (list tab-content)))))))))
+ (sort (configf:get-sections views-cfgdat) ;; (hash-table-keys views-cfgdat)
+ (lambda (a b)
+ (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
+ (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
+ (> order-a order-b)))))
+ result))
+ (tabs (apply iup:tabs
+ #:tabchangepos-cb (lambda (obj curr prev)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
+ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (dboard:tabdat-layout-update-ok-set! tabdat #f))
+ (dboard:commondat-curr-tab-num-set! commondat curr)
+ (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
+ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-layout-update-ok-set! tabdat #t)))
+ "tabchangepos"))
+ (dashboard:summary commondat stats-dat tab-num: 0)
+ runs-view
+ ;; (make-runs-view commondat runs2-dat 2)
+ (dashboard:runs-summary commondat onerun-dat tab-num: 2)
+ (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
+ (dashboard:run-times commondat runtimes-dat tab-num: 4)
+ (iup:vbox (iup:button "Pushme")) ;; tab 5
+ additional-views)))
+ ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+ (iup:attribute-set! tabs "TABTITLE0" "Summary")
+ (iup:attribute-set! tabs "TABTITLE1" "Runs")
+ ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
+ (iup:attribute-set! tabs "TABTITLE2" "Run Summary")
+ (iup:attribute-set! tabs "TABTITLE3" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE4" "Run Times")
+ (iup:attribute-set! tabs "TABTITLE5" "Sys Status")
+
+ ;; (iup:attribute-set! tabs "TABTITLE3" "New View")
+ ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
+
+ ;; set the tab names for user added tabs
+ (for-each
+ (lambda (tab-info)
+ (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
+ additional-tabnames)
+
+ (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+ ;; make the iup tabs object available (for changing color for example)
+ (dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
+ ;; now set up the tabdat lookup
+ (dboard:common-set-tabdat! commondat 0 stats-dat)
+ (dboard:common-set-tabdat! commondat 1 runs-dat)
+ ;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
+ (dboard:common-set-tabdat! commondat 2 onerun-dat)
+ (dboard:common-set-tabdat! commondat 3 runcontrols-dat)
+ (dboard:common-set-tabdat! commondat 4 runtimes-dat)
+
+ (iup:vbox
+ tabs
+ ;; controls
+ ))))
+ (vector keycol lftcol header runsvec)))
+
+(define (dboard:setup-num-rows tabdat)
+ (dboard:tabdat-num-tests-set! tabdat (string->number
+ (or (args:get-arg "-rows")
+ (get-environment-variable "DASHBOARDROWS")
+ "15"))))
+
+(define *ord* #f)
+(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000"))
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define *last-recalc-ended-time* 0)
+
+(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
+ (or please-update-buttons
+ (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
+ (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
+ (> (current-seconds)(+ last-db-update-time 1)))))
+
+;; Force creation of the db in case it isn't already there.
+;; (tasks:open-db)
+
+(define (dashboard:get-youngest-run-db-mod-time dbdir)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
+ ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn)
+ (current-seconds)) ;; something went wrong - just print an error and return current-seconds
+ (common:max (map (lambda (filen)
+ (file-modification-time filen))
+ (glob (conc dbdir "/*.db*"))))))
+
+(define (dashboard:monitor-changed? commondat tabdat)
+ (let* ((run-update-time (current-seconds))
+ (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
+ (monitor-modtime (if (and monitor-db-path (common: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 (dboard:get-last-db-update tabdat context)
+ (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
+
+(define (dboard:set-last-db-update! tabdat context newtime)
+ (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
+
+;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
+;; is closed (I think). If db dir starts with /tmp always return true
+;;
+(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
+ (let* ((run-update-time (current-seconds))
+ (dbdir (dboard:tabdat-dbdir tabdat))
+ (modtime (dashboard:get-youngest-run-db-mod-time dbdir))
+ (recalc (dashboard:recalc modtime
+ (dboard:commondat-please-update commondat)
+ (dboard:get-last-db-update tabdat context-key))))
+ ;; (dboard:tabdat-last-db-update tabdat))))
+ (if recalc
+ (dboard:set-last-db-update! tabdat context-key run-update-time))
+ (dboard:commondat-please-update-set! commondat #f)
+ recalc))
+
+;; point inside line
+;;
+(define-inline (dashboard:px-between px lx1 lx2)
+ (and (< lx1 px)(> lx2 px)))
+
+;;Not reference anywhere
+;;
+;; 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)))))
+
+;; 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* ((access-mode (dboard:tabdat-access-mode tabdat))
+ (last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (runs-hash (let ((ht (make-hash-table)))
+ (for-each (lambda (run)
+ (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
+ (vector-ref runs-dat 1))
+ ht))
+ (run-ids (sort (filter number? (hash-table-keys runs-hash))
+ (lambda (a b)
+ (let* ((record-a (hash-table-ref runs-hash a))
+ (record-b (hash-table-ref runs-hash b))
+ (time-a (db:get-value-by-header record-a runs-header "event_time"))
+ (time-b (db:get-value-by-header record-b runs-header "event_time")))
+ (< time-a time-b)))))
+ (tb (dboard:tabdat-runs-tree tabdat))
+ (num-runs (length (hash-table-keys runs-hash)))
+ (update-start-time (current-seconds))
+ (inc-mode #f))
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ ;; fill in the tree
+ (if (and tb
+ (not inc-mode))
+ (for-each
+ (lambda (run-id)
+ (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
+ (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
+ (dboard:tabdat-keys tabdat)))
+ (run-name (db:get-value-by-header run-record runs-header "runname"))
+ (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
+ (run-path (append key-vals (list run-name))))
+ ;; (existing (tree:find-node tb run-path)))
+ (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
+ (begin
+ (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
+ ;; Here we update the tests treebox and tree keys
+ (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
+ ;; userdata: (conc "run-id: " run-id))
+ (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
+ ;; (set! colnum (+ colnum 1))
+ ))))
+ run-ids))
+ ;; (print "Updating rundat")
+ (if (dboard:tabdat-keys tabdat) ;; have keys yet?
+ (let* ((num-keys (length (dboard:tabdat-keys tabdat)))
+ (targpatt (map (lambda (k v)
+ (list k v))
+ (dboard:tabdat-keys tabdat)
+ (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
+ '("%" "%"))
+ (make-list num-keys "%"))
+ num-keys)
+ ))
+ (runpatt (if (and (dboard:tabdat-target tabdat)
+ (list? (dboard:tabdat-target tabdat))
+ (not (null? (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" "%")
+ (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-readable? dbpth))
+ (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
+ db)
+ #f)))
+
+;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
+;;
+(define (dboard:graph-read-data cmdstring tstart tend)
+ (let* ((parts (string-split cmdstring))) ;; spaces not allowed
+ (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ...
+ (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring)
+ (let* ((dbdef (list-ref parts 0))
+ (tablen (list-ref parts 1))
+ (timef (list-ref parts 2))
+ (varfn (list-ref parts 3))
+ (valfn (list-ref parts 4))
+ (fields (cdr (cddddr parts)))
+ (db (dboard:graph-db-open dbdef))
+ (res-ht (make-hash-table)))
+ (if db
+ (begin
+ (for-each
+ (lambda (fieldname) ;; fields
+ (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC"))
+ (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
+ (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res t var val)
+ (cons (vector t var val) res))
+ '() db all-dat-qrystr)))
+ (let ((zeropt (condition-case
+ (sqlite3:first-row db all-dat-qrystr)
+ (exn (busy)(db:generic-error-printout exn "ERROR: database " dbdef
+ " is locked. Try copying to another location, remove original and copy back.")))))
+ (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
+ (hash-table-set! res-ht
+ fieldname
+ (cons
+ (apply vector tstart (cdr zeropt))
+ (hash-table-ref/default res-ht fieldname '())))))))
+ fields)
+ res-ht)
+ #f)))))
+
+;; graph data
+;; tsc=timescale, tfn=function; time->x
+;;
+(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin)
+ (let* ((dwg (dboard:tabdat-drawing tabdat))
+ (lib (vg:get/create-lib dwg "runslib"))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (dur (- tstart tend)) ;; time duration
+ (cmp (vg:get-component dwg "runslib" compname))
+ (cfg (configf:get-section *configdat* "graph"))
+ (stdcolor (vg:rgb->number 120 130 140))
+ (delta-y (- uly lly))
+ (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat))
+ (graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
+ (graph-matrix (dboard:tabdat-graph-matrix tabdat))
+ (changed #f))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj llx lly ulx uly))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart)))
+ (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend)))
+ (let loop ((mark first)
+ (count 0))
+ (let* ((smark (tfn mark)) ;; scale the mark
+ (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark
+ (label (conc (* count span) timesym))) ;; was mark-delta
+ (if (> count 2)
+ (begin
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- smark 1)(- lly 10) label))))
+ (if (< mark (- tend time-blk))
+ (loop (+ mark time-blk)(+ count 1))))))
+ (for-each
+ (lambda (cf)
+ (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend)))
+ (if alldat
+ (for-each
+ (lambda (fieldn)
+ (let*-values (((dat) (hash-table-ref alldat fieldn))
+ ((vals minval maxval) (if (null? dat)
+ (values '() #f #f)
+ (let loop ((hed (car dat))
+ (tal (cdr dat))
+ (res '())
+ (min (vector-ref (car dat) 2))
+ (max (vector-ref (car dat) 2)))
+ (let* ((val (vector-ref hed 2))
+ (newmin (if (< val min) val min))
+ (newmax (if (> val max) val max))
+ (newres (cons val res)))
+ (if (null? tal)
+ (values (reverse res) (- newmin 2) (+ newmax 2))
+ (loop (car tal)(cdr tal) newres newmin newmax)))))))
+ (if (not (hash-table-exists? graph-matrix-table fieldn))
+ (begin
+ (let* ((graph-color-rgb (vg:generate-color-rgb))
+ (graph-color (vg:iup-color->number graph-color-rgb))
+ (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat))
+ (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat))
+ (graph-cell (conc graph-matrix-row ":" graph-matrix-col))
+ (graph-dat (make-dboard:graph-dat
+ id: fieldn
+ color: graph-color
+ flag: #t
+ cell: graph-cell
+ )))
+ (hash-table-set! graph-matrix-table fieldn graph-dat)
+ (hash-table-set! graph-cell-table graph-cell graph-dat)
+ ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ")
+ ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ")
+ (set! changed #t)
+ (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn)
+ (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb)
+ (if (> graph-matrix-col 10)
+ (begin
+ (dboard:tabdat-graph-matrix-col-set! tabdat 1)
+ (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1)))
+ (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1)))
+ )))
+ (if (not (null? vals))
+ (let* (;; (maxval (apply max vals))
+ ;; (minval (min 0 (apply min vals)))
+ (yoff (- minval lly)) ;; minval))
+ (deltaval (- maxval minval))
+ (yscale (/ delta-y (if (zero? deltaval) 1 deltaval)))
+ (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale))))
+ (graph-dat (hash-table-ref graph-matrix-table fieldn))
+ (graph-color (dboard:graph-dat-color graph-dat))
+ (graph-flag (dboard:graph-dat-flag graph-dat)))
+ (if graph-flag
+ (begin
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval)))
+ (vg:add-obj-to-comp
+ cmp
+ (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval)))
+ (fold
+ (lambda (next prev) ;; #(time ? val) #(time ? val)
+ (if prev
+ (let* ((yval (vector-ref prev 2))
+ (yval-next (vector-ref next 2))
+ (last-tval (tfn (vector-ref prev 0)))
+ (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2))))
+ (next-yval (yfunc yval-next))
+ (curr-tval (tfn (vector-ref next 0))))
+ (if (>= curr-tval last-tval)
+ (begin
+ (vg:add-obj-to-comp
+ cmp
+ ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ (vg:make-line-obj last-tval last-yval curr-tval last-yval
+ line-color: graph-color))
+ (vg:add-obj-to-comp
+ cmp
+ ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
+ (vg:make-line-obj curr-tval last-yval curr-tval next-yval
+ line-color: graph-color)))
+ (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
+ next)
+ #f ;; (vector tstart minval minval)
+ dat)
+ )))))) ;; for each data point in the series
+ (hash-table-keys alldat)))))
+ cfg)
+ (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL"))))
+
+;; run times tab
+;;
+(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
+ ;; each test is an object in the run component
+ ;; each run is a component
+ ;; all runs stored in runslib library
+ (let escapeloop ((escape #f))
+ (if (and (not escape)
+ tabdat)
+ (let* ((canvas-margin 10)
+ (not-done-runs (dboard:tabdat-not-done-runs tabdat))
+ (mtx (dboard:tabdat-runs-mutex tabdat))
+ (drawing (dboard:tabdat-drawing tabdat))
+ (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
+ (allruns (dboard:tabdat-allruns tabdat))
+ (num-runs (length allruns))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (compact-layout (dboard:tabdat-compact-layout tabdat))
+ (row-height (if compact-layout 2 10))
+ (graph-height 120)
+ (run-to-run-margin 25))
+ (dboard:tabdat-layout-update-ok-set! tabdat #t)
+ (if (and (canvas? cnv)
+ (not (null? allruns))) ;; allruns can go null when browsing the runs tree
+ (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 (common:min-max < (map db:test-get-event_time testsdat)))
+ (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))))
+ (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero
+ (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start))
+ (run-duration (- run-end run-start))
+ (timescale (/ (- sizex (* 2 canvas-margin))
+ (if (> run-duration 0)
+ run-duration
+ (current-seconds)))) ;; a least lously guess
+ (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
+ (num-tests (length hierdat))
+ (tot-tests (length testsdat))
+ (width (* timescale run-duration))
+ (graph-lly (calc-y (/ -50 row-height)))
+ (graph-uly (- (calc-y 0) canvas-margin))
+ (sec-per-50pt (/ 50 timescale))
+ )
+ ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt)
+ ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
+ (mutex-lock! mtx)
+ (vg:add-comp-to-lib runslib run-full-name runcomp)
+ ;; Have to keep moving the instantiated box as it is anchored at the lower left
+ ;; this should have worked for x in next statement? (maptime run-start)
+ ;; add 60 to make room for the graph
+ (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
+ (mutex-unlock! mtx)
+ ;; (set! run-start-row (+ max-row 2))
+ ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
+ ;; get tests in list sorted by event time ascending
+ (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
+ (tests-tal (cdr hierdat))
+ (test-num 1))
+ (let ((iterated (> (length test-ids) 1))
+ (first-rownum #f)
+ (num-items (length test-ids)))
+ (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items
+ (tidstal (cdr test-ids))
+ (item-num 1)
+ (test-objs '()))
+ (let* ((testdat (hash-table-ref tests-ht test-id))
+ (event-time (maptime (db:test-get-event_time testdat)))
+ (test-duration (* timescale (db:test-get-run_duration testdat)))
+ (end-time (+ event-time test-duration))
+ (test-name (db:test-get-testname testdat))
+ (item-path (db:test-get-item-path testdat))
+ (state (db:test-get-state testdat))
+ (status (db:test-get-status testdat))
+ (test-fullname (conc test-name "/" item-path))
+ (name-color (gutils:get-color-for-state-status state status))
+ (new-test-objs
+ (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1)))
+ (if (dashboard:row-collision rowhash rownum event-time end-time)
+ (loop (+ rownum 1))
+ (let* ((title (if iterated (if compact-layout #f item-path) test-name))
+ (lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
+ (uly (+ lly row-height))
+ (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on
+ (obj (vg:make-rect-obj event-time lly use-end uly
+ fill-color: (vg:iup-color->number (car name-color))
+ text: title
+ font: "Helvetica -10"))
+ (bar-end (max use-end
+ (+ event-time
+ (if compact-layout
+ 1
+ (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter
+ ;; (if iterated
+ ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
+ ;; (if (not first-rownum)
+ ;; (begin
+ ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
+ ;; (set! first-rownum rownum)))
+ (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
+ (dboard:tabdat-max-row tabdat))) ;; track the max row used
+ ;; bar-end has some margin for text - accounting for text in extents not yet working.
+ (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5))
+ (vg:add-obj-to-comp runcomp obj)
+ ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
+ (dboard:tabdat-view-changed-set! tabdat #t)
+ (cons obj test-objs))))))
+ ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time)
+ ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
+ (if (> item-num 50)
+ (if (eq? 0 (modulo item-num 50))
+ (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
+ ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? tidstal)
+ (if iterated
+ (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
+ (llx (- (car xtents) 10))
+ (lly (- (cadr xtents) 10))
+ (ulx (+ 5 (caddr xtents)))
+ (uly (+ 10 (cadddr xtents))))
+ ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items)
+ ;; This is the box around the tests of an iterated test
+ (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
+ text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
+ line-color: (vg:rgb->number 0 0 255 a: 128)
+ font: "Helvetica -10"))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ )))))
+ ;; If it is an iterated test put box around it now.
+ (if (not (null? tests-tal))
+ (if #f ;; (> (- (current-seconds) update-start-time) 5)
+ (print "drawing runs taking too long")
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ )))))
+ ;; placeholder box
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
+ ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
+ ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
+ ;; instantiate the component
+ (let* ((extents (vg:components-get-extents drawing runcomp))
+ (new-xtnts (apply vg:grow-rect 5 5 extents))
+ (llx (list-ref new-xtnts 0))
+ (lly (list-ref new-xtnts 1))
+ (ulx (list-ref new-xtnts 2))
+ (uly (list-ref new-xtnts 3))
+ (outln (vg:make-rect-obj -5 lly ulx uly
+ text: run-full-name
+ line-color: (vg:rgb->number 255 0 255 a: 128))))
+ ; (vg:components-get-extents d1 c1)))
+ ;; this is the box around the run
+ (mutex-lock! mtx)
+ (vg:add-obj-to-comp runcomp outln)
+ (mutex-unlock! mtx)
+ ;; this is where we have enough info to place the graph
+ (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
+ (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
+ ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
+ ))
+ ;; end of the run handling loop
+ (if (not (dboard:tabdat-layout-update-ok tabdat))
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ (let ((newdoneruns (cons rundat doneruns)))
+ (if (null? runtal)
+ (begin
+ (dboard:rundat-data-changed-set! rundat #f)
+ (dboard:tabdat-not-done-runs-set! tabdat '())
+ (dboard:tabdat-done-runs-set! tabdat allruns))
+ (if #f ;; (> (- (current-seconds) update-start-time) 5)
+ (begin
+ (print "drawing runs taking too long.... have " (length runtal) " remaining")
+ ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
+ ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
+ (dboard:tabdat-not-done-runs-set! tabdat runtal))
+ (begin
+ (if (dboard:tabdat-layout-update-ok tabdat)
+ (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
+ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
+ ))))))))) ;; new-run-start-row
+ )))
+ (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
+
+(define (dashboard:calc-key-patterns tabdat)
+ ;; generate key patterns from the target stored in tabdat
+ (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
+ (let ((fres (if (dboard:tabdat-target tabdat)
+ (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
+ (map (lambda (k v)(list k v)) dbkeys ptparts))
+ (let ((res '()))
+ (for-each (lambda (key)
+ (if (not (equal? key "runname"))
+ (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
+ (if val (set! res (cons (list key val) res))))))
+ dbkeys)
+ res))))
+ fres)))
+
+
+;; handy trick for printing a record
+;;
+;; (pp (dboard:tabdat->alist tabdat))
+;;
+;; removing the tabdat-values proc
+;;
+;; (define (tabdat-values tabdat)
+
+;; runs update-rundat using the various filters from the gui
+;;
+(define (dashboard:do-update-rundat tabdat)
+ (let* ((runnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%"))
+ (numruns (dboard:tabdat-numruns tabdat))
+ (testnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%"))
+ (keypatts (dashboard:calc-key-patterns tabdat)))
+ (dboard:update-rundat
+ tabdat
+ runnamepatt
+ numruns
+ testnamepatt
+ keypatts)))
+
+(define (dashboard:runs-tab-updater commondat tab-num)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
+ (dbkeys (dboard:tabdat-dbkeys tabdat)))
+ (dashboard:do-update-rundat tabdat)
+ (let ((uidat (dboard:commondat-uidat commondat)))
+ (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
+ ))
+ "dashboard:runs-tab-updater"))
+
+;;======================================================================
+;; The heavy lifting starts here
+;;======================================================================
+
+(define (dashboard-main)
+ (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; not used for now, update for .db area and use for write access detection
+ #;(if (and (common:file-exists? mtdb-path)
+ (file-writable? mtdb-path))
+ (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") ","))))
+ (if (> (length d) 1)
+ d
+ (list #f #f))))
+ (run-id (car dat))
+ (test-id (cadr dat)))
+ (if (and (number? run-id)
+ (number? test-id)
+ (>= test-id 0))
+ (dashboard-tests:examine-test run-id test-id)
+ (begin
+ (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
+ (exit 1)))))
+ ;; ((args:get-arg "-guimonitor")
+ ;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
+ (else
+ (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
+ (dboard:commondat-curr-tab-num-set! commondat 0)
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:runs-tab-updater commondat 1))
+ tab-num: 1)
+ ;; may not want this alive (manually merged it from v1.66)
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:runs-tab-updater commondat 1))
+ tab-num: 2)
+ (iup:callback-set! *tim*
+ "ACTION_CB"
+ (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
+ ) "update buttons once"))
+ (th2 (make-thread iup:main-loop "Main loop")))
+ (thread-start! th2)
+ (thread-join! th2)))))
+
+(define (get-debugcontrolf)
+ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+ (if (common:file-exists? debugcontrolf)
+ debugcontrolf
+ #f)))
+
+(define (main)
+ (if (args:get-arg "-repl")
+ (repl)
+ (dashboard-main)))
+
+)
+
+(import dashboard)
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (get-debugcontrolf)))
+ (if debugcontrolf
+ (load debugcontrolf)))
+
+(import srfi-18)
+
+(thread-join!
+ (thread-start!
+ (make-thread main "main")))
+
+
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -16,51 +16,16 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(declare (uses ducttape-lib))
-
+(declare (uses commonmod))
(declare (uses debugprint))
-(declare (uses bigmod))
-;; (declare (uses gutils))
-;; (declare (uses bigmod.import))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses dashboard-context-menu))
-(declare (uses dashboard-tests))
-(declare (uses dbmod))
-(declare (uses dcommon))
-;; (declare (uses debugprint.import))
-(declare (uses itemsmod))
-(declare (uses launchmod))
(declare (uses mtargs))
-(declare (uses mtmod))
(declare (uses mtver))
-(declare (uses processmod))
-(declare (uses runsmod))
(declare (uses rmtmod))
-(declare (uses subrunmod))
(declare (uses tree))
-(declare (uses vgmod))
-(declare (uses testsmod))
-(declare (uses tasksmod))
-(declare (uses dbi))
-
-;; needed for configf scripts, scheme etc.
-;; (declare (uses apimod.import))
-;; (declare (uses debugprint.import))
-;; (declare (uses mtargs.import))
-;; (declare (uses commonmod.import))
-;; (declare (uses configfmod.import))
-;; (declare (uses bigmod.import))
-;; (declare (uses dbmod.import))
-;; (declare (uses rmtmod.import))
-;; ;; (declare (uses servermod.import))
-;; (declare (uses launchmod.import))
-;; (declare (uses dashboard-guimonitor))
-;; (declare (uses dashboard-main))
(module dashboard
*
(import scheme
@@ -90,11 +55,10 @@
(prefix iup iup:)
canvas-draw
canvas-draw-iup
(prefix sqlite3 sqlite3:)
- (prefix dbi dbi:)
srfi-1
regex regex-case srfi-69
typed-records
sparse-vectors
format
@@ -101,41 +65,17 @@
srfi-4
srfi-14
srfi-18
)
-;; (include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "run_records.scm")
-;; (include "task_records.scm")
-;; (include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
-;; (include "vg_records.scm")
-
(import (prefix mtargs args:)
;; gutils
- bigmod
commonmod
- configfmod
- dashboard-context-menu
- dashboard-tests
- dbmod
- dcommon
debugprint
- itemsmod
- launchmod
- mtmod
mtver
- processmod
rmtmod
- runsmod
- subrunmod
- tasksmod
- testsmod
tree
- vgmod
- ducttape-lib
)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
@@ -150,14 +90,10 @@
Misc
-rows R : set number of rows
-cols C : set number of columns
"))
-;; -server host:port : connect to host:port instead of db access
-;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
-;; -guimonitor : control panel for runs
-
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-cols"
@@ -182,11 +118,10 @@
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
-(make-and-init-bigdata)
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
(for-each (lambda (var)
@@ -209,3547 +144,29 @@
(exit)))
(if (args:get-arg "-start-dir")
(if (directory-exists? (args:get-arg "-start-dir"))
(let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
+ (set-environment-variable! "PWD" fullpath)
(change-directory fullpath))
(begin
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
-;; TODO: Move this inside (main)
-;;
-(if (not (launch:setup))
- (begin
- (print "Failed to find megatest.config, exiting")
- (exit 1)))
-
-;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
-;; first check for the switch
-;;
-(if (or (args:get-arg "-rh5.11")
- (configf:lookup *configdat* "dashboard" "no-detachbox")
- (not (file-exists? "/etc/os-release")))
- (set! iup:detachbox iup:vbox))
-
-#;(if (not (common:on-homehost?))
- (begin
- (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
-
-;; RA => Might require revert for filters
-;; create a watch dog to move changes from lt/.db/*.db to megatest.db
-;;
-;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
-;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")
-
-(thread-start! (make-thread common:watchdog "Watchdog thread"))
-
-;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
-;; (if (not (args:get-arg "-use-db-cache"))
-;; (begin
-;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
-;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
-;;)
-
-;; data common to all tabs goes here
-;;
-(defstruct dboard:commondat
- ((curr-tab-num 0) : number)
- please-update
- tabdats
- update-mutex
- updaters
- updating
- uidat ;; needs to move to tabdat at some time
- hide-not-hide-tabs
- )
-
-(define (dboard:commondat-make)
- (make-dboard:commondat
- curr-tab-num: 0
- tabdats: (make-hash-table)
- please-update: #t
- update-mutex: (make-mutex)
- updaters: (make-hash-table)
- updating: #f
- hide-not-hide-tabs: #f
- ))
-
-;;======================================================================
-;; buttons color using image
-;;======================================================================
-
-(define *images* (make-hash-table))
-
-(define (make-image images name color)
- (if (hash-table-exists? images name)
- name
- (let* ((img-bits1 (u8vector->blob (u8vector
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- )))
- ;; w h
- (img1 (iup:image/palette 16 24 img-bits1)))
- (iup:handle-name-set! img1 name)
- ;; (iup:attribute-set! img1 "0" "0 0 0")
- (iup:attribute-set! img1 "1" color) ;; "BGCOLOR")
- ;; (iup:attribute-set! img1 "2" "255 0 0")
- (hash-table-set! images name img1)
- name)))
-
-
-;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
-;;
-(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
- (let* ((tnum (or tab-num
- (dboard:commondat-curr-tab-num commondat)
- 0)) ;; tab-num value is curr-tab-num value in passed commondat
- (ht (dboard:commondat-tabdats commondat))
- (res (hash-table-ref/default ht tnum #f)))
- (or res
- (let ((new-tabdat (dboard:tabdat-make-data)))
- (hash-table-set! ht tnum new-tabdat)
- new-tabdat))))
-
-;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
-;;
-(define (dboard:common-set-tabdat! commondat tabnum tabdat)
- (hash-table-set!
- (dboard:commondat-tabdats commondat)
- tabnum
- tabdat))
-
-;; gets and calls updater list 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 ;; perform the function calls for the complete updaters list
- (lambda (updater)
- ;; (debug:print 3 *default-log-port* "Running " updater)
- (updater))
- updaters))))
-
-;; register tabdat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
-#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
- (cons dboard:tabdat?
- (lambda (tabdat-item)
- (filter
- (lambda (alist-entry)
- (member (car alist-entry)
- '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
- (dboard:tabdat->alist tabdat-item)))))
-
-
-
-(define (dboard:tabdat-target-string vec)
- (let ((targ (dboard:tabdat-target vec)))
- (if (list? targ)(string-intersperse targ "/") "no-target-specified")))
-
-(define (dboard:tabdat-make-data)
- (let ((dat (make-dboard:tabdat)))
- (dboard:setup-tabdat dat)
- (dboard:setup-num-rows dat)
- dat))
-
-(define (dboard:setup-tabdat tabdat)
- (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
- (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
- (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
-
- ;; HACK ALERT: this is a hack, please fix.
- (dboard:tabdat-ro-set! tabdat (not (file-readable? (dboard:tabdat-dbfpath tabdat))))
-
- (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
- (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
- (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
- )
-
-;; RADT => Matrix defstruct addition
-(defstruct dboard:graph-dat
- ((id #f) : string)
- ((color #f) : vector)
- ((flag #t) : boolean)
- ((cell #f) : number)
- )
-
-;; data for runs, tests etc. was used in run summary?
-;;
-(defstruct dboard:runsdat
- ;; new system
- runs-index ;; target/runname => colnum
- tests-index ;; testname/itempath => rownum
- matrix-dat ;; vector of vectors rows/cols
- )
-
-(define (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 (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
- key-vals
- ((last-update 0) : number) ;; last query to db got records from before last-update
- ((last-db-time 0) : number) ;; last timestamp on megatest.db
- ((data-changed #f) : boolean)
- ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
- (db-path #f))
-
-;; for the new runs view lets build up a few new record types and then consolidate later
-;;
-;; this is a two level deep pipeline for the incoming data:
-;; sql query data ==> filters ==> data for display
-;;
-(defstruct dboard:rdat
- ;; view related items
- (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
- (leftcol 0) ;; number of the leftmost visible column
- (toprow 0) ;; topmost visible row
- (numcols 24) ;; number of columns visible
- (numrows 20) ;; number of rows visible
-
- ;; data from sql db
- (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
- (runs (make-sparse-vector)) ;; id => runrec
- (runsbynum (make-vector 100 #f)) ;; vector num => runrec
- (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
- (tests (make-hash-table)) ;; test[/itempath] => list of test rec
- (path-run-ids (make-hash-table)) ;; path => run-id (this is a guess based on code reference)
-
- ;; run sql filters
- (targ-sql-filt "%")
- (runname-sql-filt "%")
- (run-state-sql-filt "%")
- (run-status-sql-filt "%")
-
- ;; test sql filter
- (testname-sql-filt "%")
- (itempath-sql-filt "%")
- (test-state-sql-filt "%")
- (test-status-sql-filt "%")
-
- ;; other sql related fields
- (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
-
- ;; filtered data
- (cols (make-sparse-vector)) ;; columnnum => run-id
- (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec)
-
- ;; various
- (prev-run-ids '()) ;; push previously looked at runs on this
- (view-changed #f)
-
- ;; widgets
- (runs-tree #f) ;;
- )
-
-(define (dboard:rdat-push-run-id rdat run-id)
- (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
-
-(defstruct dboard:runrec
- id
- target ;; a/b/c...
- tdef ;; for future use
- )
-
-(defstruct dboard:testrec
- id
- runid
- testname ;; test[/itempath]
- state
- status
- start-time
- duration
- )
-
-;; register dboard:rundat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
-#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
- (cons dboard:rundat?
- (lambda (tabdat-item)
- (filter
- (lambda (alist-entry)
- (member (car alist-entry)
- '(run run-data-offset ))) ;; FIELDS OF INTEREST
- (dboard:rundat->alist tabdat-item)))))
-
-
-
-
-(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
- (make-dboard:rundat
- run: run
- tests: (or tests (make-hash-table))
- key-vals: key-vals
- ))
-
-(defstruct dboard:testdat
- id ;; testid
- state ;; test state
- status ;; test status
- )
-
-;; default is to NOT set the cell if the column and row names are not pre-existing
-;;
-#;(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f))
- (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set))
- (row-num (dcommon: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:runsdat-matrix-dat dat) col-num row-num tdat)
- tdat)
- #f)))
-
-(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard")))
-
-
-;; sorting global data (would apply to many testsuites so leave it global for now)
-;;
-(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
- (vector "Sort -a" 'testname "DESC")
- (vector "Sort +t" 'event_time "ASC")
- (vector "Sort -t" 'event_time "DESC")
- (vector "Sort +s" 'statestatus "ASC")
- (vector "Sort -s" 'statestatus "DESC")
- (vector "Sort +a" 'testname "ASC")))
-
-(define *tests-sort-type-index* '(("+testname" 0)
- ("-testname" 1)
- ("+event_time" 2)
- ("-event_time" 3)
- ("+statestatus" 4)
- ("-statestatus" 5)))
-
-;; Don't forget to adjust the >= below if you add to the sort-options above
-(define (next-sort-option)
- (if (>= *tests-sort-reverse* 5)
- (set! *tests-sort-reverse* 0)
- (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1)))
- *tests-sort-reverse*)
-
-(define *tests-sort-reverse*
- (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*)))
- (if t-sort
- (cadr t-sort)
- 3)))
-
-(define (get-curr-sort)
- (vector-ref *tests-sort-options* *tests-sort-reverse*))
-
-;;======================================================================
-
-(debug:setup)
-
-;; (define uidat #f)
-
-(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
-(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
-(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2))
-(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))
-
-(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-(define (dboard:compare-tests test1 test2)
- (let* ((test-name1 (db:test-get-testname test1))
- (item-path1 (db:test-get-item-path test1))
- (eventtime1 (db:test-get-event_time test1))
- (test-name2 (db:test-get-testname test2))
- (item-path2 (db:test-get-item-path test2))
- (eventtime2 (db:test-get-event_time test2))
- (same-name (equal? test-name1 test-name2))
- (test1-top (equal? item-path1 ""))
- (test2-top (equal? item-path2 ""))
- (test1-older (> eventtime1 eventtime2))
- (same-time (equal? eventtime1 eventtime2)))
- (if same-name
- (if same-time
- (string>? item-path1 item-path2)
- test1-older)
- (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* ((start-time (current-seconds))
- (access-mode (dboard:tabdat-access-mode tabdat))
- (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
- "200")))
- (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
- (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
- (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
- (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
- (sort-info (get-curr-sort))
- (sort-by (vector-ref sort-info 1))
- (sort-order (vector-ref sort-info 2))
- (bubble-type (if (member sort-order '(testname))
- 'testname
- 'itempath))
- ;; note: the rundat is normally created in "update-rundat".
- (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
- (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
- (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
- rd)))
- ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
- (last-update (if ;;(or
- do-not-use-query-timestamps
- ;;(dboard:tabdat-filters-changed tabdat))
- 0
- (dboard:rundat-last-update run-dat)))
- (last-db-time (if do-not-use-db-file-timestamps
- 0
- (dboard:rundat-last-db-time run-dat)))
- (db-path (or (dboard:rundat-db-path run-dat)
- (let* ((db-dir (common:get-db-tmp-area))
- (db-pth (conc db-dir "/megatest.db")))
- (dboard:rundat-db-path-set! run-dat db-pth)
- db-pth)))
- (db-mod-time (common:lazy-sqlite-db-modification-time db-path))
- (db-modified (>= db-mod-time last-db-time))
- (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress
- (tmptests (if (or do-not-use-db-file-timestamps
- (dboard:tabdat-filters-changed tabdat)
- db-modified)
- (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
- (dboard:rundat-run-data-offset run-dat) ;; query offset
- num-to-get
- (dboard:tabdat-hide-not-hide tabdat) ;; no-in
- sort-by ;; sort-by
- sort-order ;; sort-order
- #f ;; 'shortlist ;; qrytype
- last-update ;; last-update
- *dashboard-mode*) ;; use dashboard mode
- '()))
- (use-new (dboard:tabdat-hide-not-hide tabdat))
- (tests-ht (if (dboard:tabdat-filters-changed tabdat)
- (let ((ht (make-hash-table)))
- (dboard:rundat-tests-set! run-dat ht)
- ht)
- (dboard:rundat-tests run-dat)))
- (got-all (< (length tmptests) num-to-get)) ;; got all for this round
- )
-
- ;; if we saw the db modified, reset it (the signal has already been used)
- (if (and got-all ;; (not multi-get)
- db-modified)
- (dboard:rundat-last-db-time-set! run-dat (- start-time 2)))
-
- ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset
- ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the
- ;; data has been read
- ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above
- ;;
- ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path)
- (if got-all
- (begin
- (dboard:rundat-last-update-set! run-dat (- start-time 2))
- (dboard:rundat-run-data-offset-set! run-dat 0))
- (begin
- (dboard:rundat-run-data-offset-set! run-dat
- (+ num-to-get (dboard:rundat-run-data-offset run-dat)))))
-
- (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)
-
- 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* ((access-mode (dboard:tabdat-access-mode tabdat))
- (keys (rmt:get-keys))
- (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
- (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
- ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
- (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname")
- (header (db:get-header allruns))
- (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
- (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
- (start-time (current-seconds))
- (runs-hash (let ((ht (make-hash-table)))
- (for-each (lambda (run)
- (hash-table-set! ht (db:get-value-by-header run header "id") run))
- runs-tree) ;; (vector-ref runs-dat 1))
- ht))
- (tb (dboard:tabdat-runs-tree tabdat)))
- ;;(BB> "In update-rundat")
- ;;(inspect allruns runs-hash)
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- (dboard:tabdat-header-set! tabdat header)
- ;;
- ;; trim runs to only those that are changing often here
- ;;
- (if (null? runs)
- (begin
- (dboard:tabdat-allruns-set! tabdat '())
- (dboard:tabdat-all-test-names-set! tabdat '())
- (dboard:tabdat-item-test-names-set! tabdat '())
- (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
- (let loop ((run (car runs))
- (tal (cdr runs))
- (res '())
- (maxtests 0))
- (let* ((run-id (db:get-value-by-header run header "id"))
- (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
- (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
- (key-vals (rmt:get-key-vals run-id))
- (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
- ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
- ;; dboard:get-tests-for-run-duplicate - returns a hash table
- ;; (dboard:get-tests-dat tabdat run-id last-update))
- (all-test-ids (hash-table-keys tests-ht))
- (num-tests (length all-test-ids)))
- ;; (print "run-struct: " run-struct)
- ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
- ;; (tests (bubble-up tmptests priority: bubble-type))
- ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
- ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
- ;; Not sure this is needed?
- (let* ((newmaxtests (max num-tests maxtests))
- (last-update (- (current-seconds) 10))
- (run-struct (or run-struct
- (dboard:rundat-make-init
- run: run
- tests: tests-ht
- key-vals: key-vals)))
- (new-res (if (null? all-test-ids) res (cons run-struct res)))
- (elapsed-time (- (current-seconds) start-time)))
- (if (null? all-test-ids)
- (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
- (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
- (if (or (null? tal)
- (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
- (begin
- (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s"))
- (dboard:tabdat-allruns-set! tabdat new-res)
- maxtests)
- (if (> (dboard:rundat-run-data-offset run-struct) 0)
- (loop run tal new-res newmaxtests) ;; not done getting data for this run
- (loop (car tal)(cdr tal) new-res newmaxtests)))))))
- (dboard:tabdat-filters-changed-set! tabdat #f)
- (dboard:update-tree tabdat runs-hash header tb)))
-
-;; 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 (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
- (let* ((access-mode (dboard:tabdat-access-mode tabdat))
- (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys)))
- (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
- (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
- ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
- (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
- (header (db:get-header allruns))
- (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
- (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
- (start-time (current-seconds))
- (runs-hash (let ((ht (make-hash-table)))
- (for-each (lambda (run)
- (hash-table-set! ht (db:get-value-by-header run header "id") run))
- runs-tree) ;; (vector-ref runs-dat 1))
- ht))
- (tb (dboard:tabdat-runs-tree tabdat)))
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- (dboard:tabdat-header-set! tabdat header)
- ;;
- ;; trim runs to only those that are changing often here
- ;;
- (if (null? runs)
- (begin
- (dboard:tabdat-allruns-set! tabdat '())
- (dboard:tabdat-all-test-names-set! tabdat '())
- (dboard:tabdat-item-test-names-set! tabdat '())
- (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
- (let loop ((run (car runs))
- (tal (cdr runs))
- (res '())
- (maxtests 0))
- (let* ((run-id (db:get-value-by-header run header "id"))
- (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
- ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
- (key-vals (rmt:get-key-vals run-id))
- (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
- ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
- ;; dboard:get-tests-for-run-duplicate - returns a hash table
- ;; (dboard:get-tests-dat tabdat run-id last-update))
- (all-test-ids (hash-table-keys tests-ht))
- (num-tests (length all-test-ids)))
- ;; (print "run-struct: " run-struct)
- ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
- ;; (tests (bubble-up tmptests priority: bubble-type))
- ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
- ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
- ;; Not sure this is needed?
- (let* ((newmaxtests (max num-tests maxtests))
- ;; (last-update (- (current-seconds) 10))
- (run-struct (or run-struct
- (dboard:rundat-make-init
- run: run
- tests: tests-ht
- key-vals: key-vals)))
- (new-res (if (null? all-test-ids)
- res
- (delete-duplicates
- (cons run-struct res)
- (lambda (a b)
- (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
- (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
- (elapsed-time (- (current-seconds) start-time)))
- (if (null? all-test-ids)
- (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
- (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
- (if (or (null? tal)
- (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
- (begin
- (when (> elapsed-time 2)
- (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
- (let* ((old-val (iup:attribute *tim* "TIME"))
- (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
- (if (< (string->number new-val) 5000)
- (begin
- (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
- (iup:attribute-set! *tim* "TIME" new-val)))))
- (dboard:tabdat-allruns-set! tabdat new-res)
- maxtests)
- (if (> (dboard:rundat-run-data-offset run-struct) 0)
- (loop run tal new-res newmaxtests) ;; not done getting data for this run
- (loop (car tal)(cdr tal) new-res newmaxtests)))))))
- (dboard:tabdat-filters-changed-set! tabdat #f)
- (dboard:update-tree tabdat runs-hash header tb)))
-
-(define *collapsed* (make-hash-table))
-
-(define (toggle-hide lnum uidat) ; fulltestname)
- (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
- (fulltestname (iup:attribute btn "TITLE"))
- (parts (string-split fulltestname "("))
- (basetestname (if (null? parts) "" (car parts))))
- ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
- (if (hash-table-ref/default *collapsed* basetestname #f)
- (begin
- ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s
- (hash-table-delete! *collapsed* basetestname))
- (begin
- ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
- (hash-table-set! *collapsed* basetestname #t)))))
-
-(define blank-line-rx (regexp "^\\s*$"))
-
-(define (run-item-name->vectors lst)
- (map (lambda (x)
- (let ((splst (string-split x "("))
- (res (vector "" "")))
- (vector-set! res 0 (car splst))
- (if (> (length splst) 1)
- (vector-set! res 1 (car (string-split (cadr splst) ")"))))
- res))
- lst))
-
-(define (collapse-rows tabdat inlst)
- (let* ((sort-info (get-curr-sort))
- (sort-by (vector-ref sort-info 1))
- (sort-order (vector-ref sort-info 2))
- (bubble-type (if (member sort-order '(testname))
- 'testname
- 'itempath))
- (newlst (filter (lambda (x)
- (let* ((tparts (string-split x "("))
- (basetname (if (null? tparts) x (car tparts))))
- ;(print "x " x " tparts: " tparts " basetname: " basetname)
- (cond
- ((string-match blank-line-rx x) #f)
- ((equal? x basetname) #t)
- ((hash-table-ref/default *collapsed* basetname #f)
- ;(print "Removing " basetname " from items")
- #f)
- (else #t))))
- inlst))
- (vlst (run-item-name->vectors newlst))
- (vlst2 (bubble-up tabdat vlst priority: bubble-type)))
- (map (lambda (x)
- (if (equal? (vector-ref x 1) "")
- (vector-ref x 0)
- (conc (vector-ref x 0) "(" (vector-ref x 1) ")")))
- vlst2)))
-
-(define (update-labels uidat alltestnames)
- (let* ((rown 0)
- (keycol (dboard:uidat-get-keycol uidat))
- (lftcol (dboard:uidat-get-lftcol uidat))
- (numcols (vector-length lftcol))
- (maxn (- numcols 1))
- (allvals (make-vector numcols "")))
- (for-each (lambda (name)
- (if (<= rown maxn)
- (vector-set! allvals rown name)) ;)
- (set! rown (+ 1 rown)))
- alltestnames)
- (let loop ((i 0))
- (let* ((lbl (vector-ref lftcol i))
- (keyval (vector-ref keycol i))
- (oldval (iup:attribute lbl "TITLE"))
- (newval (vector-ref allvals i)))
- (if (not (equal? oldval newval))
- (let ((munged-val (let ((parts (string-split newval "(")))
- (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval))))
- (vector-set! keycol i newval)
- (iup:attribute-set! lbl "TITLE" munged-val)))
- (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
- (if (< i maxn)
- (loop (+ i 1)))))))
-
-;;
-(define (get-itemized-tests test-dats)
- (let ((tnames '()))
- (for-each (lambda (tdat)
- (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat))
- (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat)))
- (if (not (equal? ipath ""))
- (if (and (list? tnames)
- (string? tname)
- (not (member tname tnames)))
- (set! tnames (append tnames (list tname)))))))
- test-dats)
- tnames))
-
-;; Bubble up the top tests to above the items, collect the items underneath
-;; all while preserving the sort order from the SQL query as best as possible.
-;;
-(define (bubble-up tabdat test-dats #!key (priority 'itempath))
- (if (null? test-dats)
- test-dats
- (begin
- (let* ((tnames '()) ;; list of names used to reserve order
- (tests (make-hash-table)) ;; hash of lists, used to build as we go
- (itemized (get-itemized-tests test-dats)))
- (for-each
- (lambda (testdat)
- (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat))
- (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat)))
- ;; (seen (hash-table-ref/default tests tname #f)))
- (if (not (member tname tnames))
- (if (or (and (eq? priority 'itempath)
- (not (equal? ipath "")))
- (and (eq? priority 'testname)
- (equal? ipath ""))
- (not (member tname itemized)))
- (set! tnames (append tnames (list tname)))))
- (if (equal? ipath "")
- ;; This a top level, prepend it
- (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '())))
- ;; This is item, append it
- (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat))))))
- test-dats)
- ;; Set all tests with items
- (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames)
- '()
- (filter (lambda (tname)
- (let ((tlst (hash-table-ref tests tname)))
- (and (list tlst)
- (> (length tlst) 1))))
- tnames))
- (dboard:tabdat-item-test-names tabdat)))
- (let loop ((hed (car tnames))
- (tal (cdr tnames))
- (res '()))
- (let ((newres (append res (hash-table-ref tests hed))))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres))))))))
-
-;; optimized to get runs constrained by what is visible on the screen
-;; - not appropriate for where all the runs are needed
-;;
-(define (update-buttons tabdat uidat numruns numtests)
- (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns)
- (take-right (dboard:tabdat-allruns tabdat) numruns)
- (pad-list (dboard:tabdat-allruns tabdat) numruns)))
- (lftcol (dboard:uidat-get-lftcol uidat))
- (tableheader (dboard:uidat-get-header uidat))
- (table (dboard:uidat-get-runsvec uidat))
- (coln 0)
- (all-test-names (make-hash-table))
- (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work
- )
- ;; create a concise list of test names
- ;;
- (for-each
- (lambda (rundat)
- (if rundat
- (let* ((testdats (dboard:rundat-tests rundat))
- (testnames (map test:test-get-fullname (hash-table-values testdats))))
- (dcommon: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)
- (hash-table-set! all-test-names testname #t))
- testnames)))))
- runs)
-
- ;; create the minimize list of testnames to be displayed. Sorting
- ;; happens here *before* trimming
- ;;
- (dboard:tabdat-all-test-names-set!
- tabdat
- (collapse-rows
- tabdat
- (sort (filter string? (hash-table-keys all-test-names)) string>?))) ;; FIXME: Sorting needs to happen here
-
- ;; Trim the names list to fit the matrix of buttons
- ;;
- (dboard:tabdat-all-test-names-set!
- tabdat
- (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat))
- (drop (dboard:tabdat-all-test-names tabdat)
- (dboard:tabdat-start-test-offset tabdat))
- '())))
- (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
- (update-labels uidat (dboard:tabdat-all-test-names tabdat))
- (for-each
- (lambda (rundat)
- ;; if rundat is junk clobber it with a decent placeholder
- (if (or (not rundat) ;; handle padded runs
- (not (dboard:rundat-run rundat)))
- (set! rundat (dboard:rundat-make-init
- key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat)))))
- (let* ((run (dboard:rundat-run rundat))
- (testsdat-by-name (dboard:rundat-tests-by-name rundat))
- (key-val-dat (dboard:rundat-key-vals rundat))
- (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
- (key-vals (append key-val-dat
- (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
- (if (string? x) x "")))))
- (run-key (string-intersperse key-vals "\n")))
-
- ;; fill in the run header key values
- ;;
- (let ((rown 0)
- (headercol (vector-ref tableheader coln)))
- (for-each (lambda (kval)
- (let* ((labl (vector-ref headercol rown)))
- (if (not (equal? kval (iup:attribute labl "TITLE")))
- (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
- (set! rown (+ rown 1))))
- key-vals))
-
- ;; For this run now fill in the buttons for each test
- ;;
- (let ((rown 0)
- (columndat (vector-ref table coln)))
- (for-each
- (lambda (testname)
- (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f)))
- (if (and buttondat
- (hash-table? testsdat-by-name))
- (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f)))
- ;; (filter
- ;; (lambda (x)(equal? (test:test-get-fullname x) testname))
- ;; testsdat)))
- (if (not matching)
- (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
- ;; (car matching))))
- matching)))
- (testname (db:test-get-testname testdat))
- (itempath (db:test-get-item-path testdat))
- (testfullname (test:test-get-fullname testdat))
- (teststatus (db:test-get-status testdat))
- (teststate (db:test-get-state testdat))
- ;;(teststart (db:test-get-event_time test))
- ;;(runtime (db:test-get-run_duration test))
- (buttontxt (cond
- ((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
- ((and (equal? teststate "NOT_STARTED")
- (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
- teststatus)
- (else
- teststate)))
- (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))
- (if use-bgcolor
- (iup:attribute-set! button "BGCOLOR" color)
- (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color))))
- (if (and (not use-bgcolor) ;; bgcolor does not work with text
- (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 testdat)
- (vector-set! buttondat 4 run-key)))
- (set! rown (+ rown 1))))
- (dboard:tabdat-all-test-names tabdat)))
- (set! coln (+ coln 1))))
- runs)))
-
-(define (mkstr . x)
- (string-intersperse (map conc x) ","))
-
-(define (set-bg-on-filter commondat tabdat)
- (let ((search-changed (not (null? (filter (lambda (key)
- (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%")))
- (hash-table-keys (dboard:tabdat-searchpatts tabdat))))))
- (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))))
- (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))))))
- (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR"
- (if (or search-changed
- state-changed
- status-changed)
- "190 180 190"
- "190 190 190"
- ))
- (dboard:tabdat-filters-changed-set! tabdat #t)))
-
-(define (update-search commondat tabdat x val)
- (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
- (dboard:tabdat-filters-changed-set! tabdat #t)
- (mark-for-update tabdat)
- (set-bg-on-filter commondat tabdat))
-
-;; force ALL updates to zero (effectively)
-;;
-(define (mark-for-update tabdat)
- (dboard:tabdat-last-db-update-set! tabdat (make-hash-table)))
-
-;;======================================================================
-;; R U N C O N T R O L
-;;======================================================================
-
-;; target populating logic
-;;
-;; lb =
-;; field = target field name for this dropdown
-;; referent-vals = selected value in the left dropdown
-;; targets = list of targets to use to build the dropdown
-;;
-;; each node is chained: key1 -> key2 -> key3
-;;
-;; must select values from only apropriate targets
-;; a b c
-;; a d e
-;; a b f
-;; a/b => c f
-;;
-(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs)
- ;; is the current value in the new list? choose new default if not
- (let* ((remvalues (map (lambda (row)
- (common:list-is-sublist referent-vals (vector->list row)))
- targets))
- (values (delete-duplicates (map car (filter list? remvalues))))
- (sel-valnum (iup:attribute lb "VALUE"))
- (sel-val (iup:attribute lb sel-valnum))
- (val-num 1))
- ;; first check if the current value is in the new list, otherwise replace with
- ;; first value from values
- (iup:attribute-set! lb "REMOVEITEM" "ALL")
- (for-each (lambda (val)
- ;; (iup:attribute-set! lb "APPENDITEM" val)
- (iup:attribute-set! lb (conc val-num) val)
- (if (equal? sel-val val)
- (iup:attribute-set! lb "VALUE" val-num))
- (set! val-num (+ val-num 1)))
- values)
- (let ((val (iup:attribute lb "VALUE")))
- (if val
- val
- (if (not (null? values))
- (let ((newval (car values)))
- (iup:attribute-set! lb "VALUE" newval)
- newval))))))
-
-(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
- (let* ((runconf-targs (common:get-runconfig-targets *runconfigdat*))
- (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))
- (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 "x60"
- #:fontsize "10"
- #:expand "YES" ;; "VERTICAL"
- ;; #:dropdown "YES"
- #:editbox "YES"
- #:action (lambda (obj a b c)
- (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)))
- (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))))))))
-
-;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string
-;; interspersed with commas
-;;
-(define (dashboard:text-list-toggle-box items proc)
- (let ((alltgls (make-hash-table)))
- (apply iup:vbox
- (map (lambda (item)
- (iup:toggle
- item
- #:fontsize 8
- #:expand "YES"
- #:action (lambda (obj tstate)
- (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))))
-
-;;======================================================================
-;; R U N C O N T R O L S
-;;======================================================================
-;;
-;; A gui for launching tests
-;;
-
-(define (dboard:target-updater tabdat) ;; key-listboxes)
- (let ((targ (map (lambda (x)
- (iup:attribute x "VALUE"))
- (car (dashboard:update-target-selector tabdat))))
- (curr-runname (dboard:tabdat-run-name tabdat)))
- (dboard:tabdat-target-set! tabdat targ)
- ;; (if (dboard:tabdat-updater-for-runs tabdat)
- ;; ((dboard:tabdat-updater-for-runs tabdat)))
- (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
- (equal? (dboard:tabdat-run-name tabdat) ""))
- (dboard:tabdat-run-name-set! tabdat curr-runname))
- (dashboard:update-run-command tabdat)))
-
-;; used by run-controls
-;;
-(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
- (let* ((tb (dboard:tabdat-runs-tree tabdat))
- (runconf-targs (common:get-runconfig-targets *runconfigdat*))
- (db-target-dat (rmt:get-targets))
- (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
- (header (vector-ref db-target-dat 0))
- (db-targets (vector-ref db-target-dat 1))
- (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
- (take (append (string-split x "/")
- (make-list (length header) "na"))
- (length header))))
- (all-targets (append (list (munge-target (string-intersperse
- (map (lambda (x) "%") header)
- "/")))
- (map vector->list db-targets)
- (map munge-target
- runconf-targs)
- )))
- (for-each
- (lambda (target)
- (if (not (hash-table-ref/default runs-tree-ht target #f))
- ;; (let ((existing (tree:find-node tb target)))
- ;; (if (not existing)
- (begin
- (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name))
- (hash-table-set! runs-tree-ht target #t))))
- all-targets)))
-
-;; Run controls panel
-;;
-(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)
- (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
- (dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
- (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
- (test-patterns-textbox #f))
- (hash-table-set! tests-draw-state 'first-time #t)
- ;; (hash-table-set! tests-draw-state 'scalef 1)
- (tests:get-full-data test-names test-records '() all-tests-registry)
- (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
-
- ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
- (let* ((result
- (iup:vbox
- (dcommon:command-execution-control tabdat)
- (iup:split
- #:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 200
- ;;
- ;; (iup:split
- ;; #:value 300
-
- ;; Target, testpatt, state and status input boxes
- ;;
- (iup:split
- #:orientation "HORIZONTAL"
- (iup:vbox
- ;; Command to run, placed over the top of the canvas
- (dcommon:command-action-selector commondat tabdat tab-num: tab-num)
- (dboard:runs-tree-browser commondat tabdat))
- (iup:vbox
- (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
- (dcommon:command-testname-selector commondat tabdat update-keyvals)))
- ;; key-listboxes))
- (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
- (tb (dboard:tabdat-runs-tree tabdat)))
- (dboard:commondat-add-updater
- commondat
- (lambda ()
- (if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
- (dashboard:update-tree-selector tabdat)))
- tab-num: tab-num)
- result)))
-
- ;;(iup:frame
- ;; #:title "Logs" ;; To be replaced with tabs
- ;; (let ((logs-tb (iup:textbox #:expand "YES"
- ;; #:multiline "YES")))
- ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
- ;; logs-tb))
-
-;; browse runs as a tree. Used in both "Runs" tab and
-;; in the runs control panel.
-;;
-(define (dboard:runs-tree-browser commondat tabdat)
- (let* ((txtbox (iup:textbox
- #:action (lambda (val a b)
- (debug:catch-and-dump
- (lambda ()
- ;; for the Runs view we put the list
- ;; of keyvals into tabdat target for
- ;; the Run Controls we put then update
- ;; the run-command
- (if b (dboard:tabdat-target-set! tabdat
- (string-split b "/")))
- (dashboard:update-run-command tabdat))
- "command-testname-selector tb action"))
- #:value (dboard:test-patt->lines
- (dboard:tabdat-test-patts-use tabdat))
- #:expand "HORIZONTAL"
- ;; #:size "10x30"
- ))
- (tb
- (iup:treebox
- #:value 0
- #:title "Runs" ;; was #:name -- iup 3.19 changed
- ;; this... "Changed: [DEPRECATED
- ;; REMOVED] removed the old attribute
- ;; NAMEid from IupTree to avoid
- ;; conflict with the common attribute
- ;; NAME. Use the TITLEid attribute."
- #:expand "YES"
- #:addexpanded "YES"
- #:size "10x"
- #:selection-cb
- (lambda (obj id state)
- (debug:catch-and-dump
- (lambda ()
- (let* ((run-path (tree:node->path obj id))
- (run-id (tree-path->run-id tabdat (cdr run-path))))
- ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
- ;; done below when run-id is a number
- (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
- ;; "run-path:
- ;; "
- ;; run-path)
- (iup:attribute-set! txtbox "VALUE"
- (string-intersperse (cdr run-path) "/"))
- (dashboard:update-run-command tabdat)
- (dboard:tabdat-layout-update-ok-set! tabdat #f)
- (if (number? run-id)
- (begin
- ;; capture last two in tabdat.
- (dboard:tabdat-prev-run-id-set!
- tabdat
- (dboard:tabdat-curr-run-id tabdat))
- (dboard:tabdat-curr-run-id-set! tabdat run-id)
- (dboard:tabdat-view-changed-set! tabdat #t))
- (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
- "treebox"))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
- (dboard:tabdat-runs-tree-set! tabdat tb)
- (iup:detachbox
- (iup:vbox
- txtbox
- tb
- ))))
-
-;; browse runs as a tree. Used in both "Runs" tab and
-;; in the runs control panel.
-;;
-;; THIS IS THE NEW ONE
-;;
-(define (dboard:runs-tree-new-browser commondat rdat)
- (let* ((txtbox (iup:textbox
- #:action (lambda (val a b)
- (debug:catch-and-dump
- (lambda ()
- ;; for the Runs view we put the list
- ;; of keyvals into tabdat target for
- ;; the Run Controls we put then update
- ;; the run-command
- (if b (dboard:rdat-targ-sql-filt-set! rdat
- (string-split b "/")))
- #;(dashboard:update-run-command tabdat))
- "command-testname-selector tb action"))
- ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from?
- ;; (dboard:tabdat-test-patts-use tabdat))
- #:expand "HORIZONTAL"
- ;; #:size "10x30"
- ))
- (tb
- (iup:treebox
- #:value 0
- #:title "Runs" ;; was #:name -- iup 3.19 changed
- ;; this... "Changed: [DEPRECATED
- ;; REMOVED] removed the old attribute
- ;; NAMEid from IupTree to avoid
- ;; conflict with the common attribute
- ;; NAME. Use the TITLEid attribute."
- #:expand "YES"
- #:addexpanded "YES"
- #:size "10x"
- #:selection-cb
- (lambda (obj id state)
- (debug:catch-and-dump
- (lambda ()
- (let* ((run-path (tree:node->path obj id))
- (run-id (new-tree-path->run-id rdat (cdr run-path))))
- ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
- ;; done below when run-id is a number
- (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
- ;; "run-path:
- ;; "
- ;; run-path)
- (iup:attribute-set! txtbox "VALUE"
- (string-intersperse (cdr run-path) "/"))
- #;(dashboard:update-run-command tabdat)
- #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
- (if (number? run-id)
- (begin
- ;; capture last two in tabdat.
- (dboard:rdat-push-run-id rdat run-id)
- (dboard:rdat-view-changed-set! rdat #t))
- (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
- "treebox"))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
- (dboard:rdat-runs-tree-set! rdat tb)
- (iup:detachbox
- (iup:vbox
- txtbox
- tb
- ))))
-
-;;======================================================================
-;; R U N C O N T R O L S
-;;======================================================================
-;;
-;; A gui for launching tests
-;;
-(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
- (let* ((drawing (vg:drawing-new))
- (run-times-tab-updater (lambda ()
- (debug:catch-and-dump
- (lambda ()
- (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
- (if tabdat
- (let ((last-data-update (dboard:tabdat-last-data-update tabdat))
- (now-time (current-seconds)))
- (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
- (if (> (- now-time last-data-update) 5)
- (if (not (dboard:tabdat-running-layout tabdat))
- (begin
- (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
- (dboard:tabdat-last-data-update-set! tabdat now-time)
- ;; this is threadified to return control to the gui for a redraw.
- ;; it relies on the running-layout flag to prevent overlapping
- ;; calls.
- (thread-start! (make-thread
- (lambda ()
- (dboard:tabdat-running-layout-set! tabdat #t)
- (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
- (dboard:tabdat-running-layout-set! tabdat #f))
- "run-times-tab-layout-updater")))
- ))))))
- "dashboard:run-times-tab-updater")))
- (key-listboxes #f) ;;
- (update-keyvals (lambda ()
- (dboard:target-updater tabdat))))
- (dboard:tabdat-drawing-set! tabdat drawing)
- (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
- (iup:split
- #:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 150
- (iup:vbox
-
- (dboard:runs-tree-browser commondat tabdat)
-
- (iup:hbox
- (iup:toggle
- "Compact layout"
- #:fontsize 8
- #:expand "HORIZONTAL"
- #:value 1
- #:action (lambda (obj tstate)
- (debug:catch-and-dump
- (lambda ()
- (print "tstate: " tstate)
- (if (eq? tstate 0)
- (dboard:tabdat-compact-layout-set! tabdat #f)
- (dboard:tabdat-compact-layout-set! tabdat #t))
- (dboard:tabdat-last-filter-str-set! tabdat "")
- )
- "text-list-toggle-box"))))
- (dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
- (dcommon:command-testname-selector commondat tabdat update-keyvals))
- (iup:vbox
- (iup:split
- #:orientation "HORIZONTAL"
- #:value 800
- (let* ((cnv-obj (iup:canvas
- ;; #:size "250x250" ;; "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)
- (let* ((hb1 (iup:hbox))
- (graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
- (changed #f)
- (graph-matrix (iup:matrix
- #:alignment1 "ALEFT"
- ;; #:expand "YES" ;; "HORIZONTAL"
- #:scrollbar "YES"
- #:numcol 10
- #:numlin 20
- #:numcol-visible 5 ;; (min 8)
- #:numlin-visible 1
- #:click-cb
- (lambda (obj row col status)
- (let*
- ((graph-cell (conc row ":" col))
- (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f))
- (graph-flag (dboard:graph-dat-flag graph-dat)))
- (if graph-flag
- (dboard:graph-dat-flag-set! graph-dat #f)
- (dboard:graph-dat-flag-set! graph-dat #t))
- (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 (current-seconds))
- (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"))))
- ;;(dboard:tabdat-view-changed-set! tabdat #t)
- )))))
- (dboard:tabdat-graph-matrix-set! tabdat graph-matrix)
- (iup:attribute-set! graph-matrix "WIDTH0" 0)
- (iup:attribute-set! graph-matrix "HEIGHT0" 0)
- graph-matrix))
- (iup:hbox
- (iup:vbox
- (iup:button "Show All" #:action (lambda (obj)
- (for-each (lambda (graph-cell)
- (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
- (dboard:graph-dat-flag-set! graph-dat #t)))
- (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))
- (iup:hbox
- (iup:button "Hide All" #:action (lambda (obj)
- (for-each (lambda (graph-cell)
- (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
- (dboard:graph-dat-flag-set! graph-dat #f)))
- (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))))
- ))))
-
-;;======================================================================
-;; 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 (new-tree-path->run-id rdat path)
- (if (not (null? path))
- (hash-table-ref/default (dboard:rdat-path-run-ids rdat) path #f)
- #f))
-
-;; (define (dboard:get-tests-dat tabdat run-id last-update)
-;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
-;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
-;; run-id
-;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
-;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
-;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
-;; #f #f ;; offset limit
-;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in
-;; #f #f ;; sort-by sort-order
-;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
-;; (if (dboard:tabdat-filters-changed tabdat)
-;; 0
-;; last-update)
-;; *dashboard-mode*)
-;; '()))) ;; get 'em all
-;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
-;; (sort tdat (lambda (a b)
-;; (let* ((aval (vector-ref a 2))
-;; (bval (vector-ref b 2))
-;; (anum (string->number aval))
-;; (bnum (string->number bval)))
-;; (if (and anum bnum)
-;; (< anum bnum)
-;; (string<= aval bval)))))))
-
-
-(define (dashboard:safe-cadr-assoc name lst)
- (let ((res (assoc name lst)))
- (if (and res (> (length res) 1))
- (cadr res)
- #f)))
-
-(define (dboard:update-tree tabdat runs-hash runs-header tb)
- (let* ((access-mode (dboard:tabdat-access-mode tabdat))
- (run-ids (sort (filter number? (hash-table-keys runs-hash))
- (lambda (a b)
- (let* ((record-a (hash-table-ref runs-hash a))
- (record-b (hash-table-ref runs-hash b))
- (time-a (db:get-value-by-header record-a runs-header "event_time"))
- (time-b (db:get-value-by-header record-b runs-header "event_time")))
- (< time-a time-b)))))
- (changed #f)
- (last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- (for-each (lambda (run-id)
- (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
- (key-vals (map (lambda (key)
- (let ((val (db:get-value-by-header run-record runs-header key)))
- (if (string? val) val "")))
- (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))))
- (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
- ;; (let ((existing (tree:find-node tb run-path)))
- ;; (if (not existing)
- (begin
- (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
- ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
- ;; (conc rownum ":" colnum) col-name)
- ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
- ;; Here we update the tests treebox and tree keys
- (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
- ;; userdata: (conc "run-id: " run-id))))
- (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
- ;; (set! colnum (+ colnum 1))
- ))))
- run-ids)))
-
-(define (dashboard:tests-ht->tests-dat tests-ht)
- (reverse
- (sort
- (hash-table-values tests-ht)
- (lambda (a b)
- (let ((a-test-name (db:test-get-testname a))
- (a-item-path (db:test-get-item-path a))
- (b-test-name (db:test-get-testname b))
- (b-item-path (db:test-get-item-path b))
- (a-event-time (db:test-get-event_time a))
- (b-event-time (db:test-get-event_time b)))
- (if (not (equal? a-test-name b-test-name))
- (> a-event-time b-event-time)
- (cond
- ((< 0 (string-compare3 a-test-name b-test-name)) #t)
- ((> 0 (string-compare3 a-test-name b-test-name)) #f)
- ((< 0 (string-compare3 a-item-path b-item-path)) #t)
- (else #f))))))))
-
-
-(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
- (let* ((run (hash-table-ref/default runs-hash run-id #f))
- (key-vals (rmt:get-key-vals run-id))
- (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
- (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
- (tests-dat (dashboard:tests-ht->tests-dat tests-ht))
- (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
- (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
- (when (not run)
- (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
- (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
- )
- tests-mindat))
-
-(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
- (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
- (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
- (if (and src-run-id dest-run-id)
- (dcommon:xor-tests-mindat
- (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
- (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
- hide-clean: hide-clean)
- #f)))
-
-
-(define (dashboard:get-runs-hash tabdat)
- (let* ((access-mode (dboard:tabdat-access-mode tabdat))
- (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (runs (vector-ref runs-dat 1))
- (run-id (dboard:tabdat-curr-run-id tabdat))
- (runs-hash (let ((ht (make-hash-table)))
- (for-each (lambda (run)
- (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
- runs) ht)))
- runs-hash))
-
-
-(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
- ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
- (dashboard:do-update-rundat tabdat) ;; )
- (dboard:runs-summary-control-panel-updater tabdat)
- (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (runs (vector-ref runs-dat 1))
- (run-id (dboard:tabdat-curr-run-id tabdat))
- (runs-hash (dashboard:get-runs-hash tabdat))
- ;; (runs-hash (let ((ht (make-hash-table)))
- ;; (for-each (lambda (run)
- ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
- ;; runs)
- ;; ht))
- )
- (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree)
- (dboard:update-tree tabdat runs-hash runs-header tb))
- (if run-id
- (let* ((matrix-content
- (case (dboard:tabdat-runs-summary-mode tabdat)
- ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
- ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
- ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
- (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
- (when matrix-content
- (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell))
- (row-indices (cadr indices))
- (col-indices (car indices))
- (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
- (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
- (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
- (numrows 1)
- (numcols 1)
- (changed #f)
- )
-
- (dboard:tabdat-filters-changed-set! tabdat #f)
- (let loop ((pass-num 0)
- (changed #f))
- ;; Update the runs tree
- ;; (dboard:update-tree tabdat runs-hash runs-header tb)
-
- (if (eq? pass-num 1)
- (begin ;; big reset
- (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
- (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
- (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
-
- (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
- (iup:attribute-set! run-matrix "NUMCOL" max-col ))
-
- (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
- (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
- (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
-
- ;; Row labels
- (for-each (lambda (ind)
- (let* ((name (car ind))
- (num (cadr ind))
- (key (conc num ":0")))
- (if (not (equal? (iup:attribute run-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key name)))))
- row-indices)
- ;; (print "row-indices: " row-indices " col-indices: " col-indices)
- (if (and (eq? pass-num 0) changed)
- (loop 1 #t)) ;; force second pass
-
- ;; Cell contents
- (for-each (lambda (entry)
- ;; (print "entry: " entry)
- (let* ((row-name (cadr entry))
- (col-name (car entry))
- (valuedat (caddr entry))
- (test-id (list-ref valuedat 0))
- (test-name row-name) ;; (list-ref valuedat 1))
- (item-path col-name) ;; (list-ref valuedat 2))
- (state (list-ref valuedat 1))
- (status (list-ref valuedat 2))
- (value (gutils:get-color-for-state-status state status))
- (row-num (cadr (assoc row-name row-indices)))
- (col-num (cadr (assoc col-name col-indices)))
- (key (conc row-num ":" col-num)))
- (hash-table-set! cell-lookup key test-id)
- (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key (cadr value))
- (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
- matrix-content)
-
- ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
-
- (for-each (lambda (ind)
- (let* ((name (car ind))
- (num (cadr ind))
- (key (conc "0:" num)))
- (if (not (equal? (iup:attribute run-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key name)
- (if (<= num max-col)
- (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
- col-indices)
-
- (if (and (eq? pass-num 0) changed)
- (loop 1 #t)) ;; force second pass due to column labels changing
-
- ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)
- ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num)
- (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))))))
-
-;;======================================================================
-;; S U M M A R Y
-;;======================================================================
-;;
-;; General info about the run(s) and megatest area
-(define (dashboard:summary commondat tabdat #!key (tab-num #f))
- (let* ((rawconfig (configf: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 300
- (iup:frame
- #:title "General Info"
- (iup:vbox
- (iup:hbox
- (iup:label "Area Path")
- (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
- (iup:hbox
- (dcommon:keys-matrix rawconfig)
- (dcommon:general-info)
- )))
- (iup:frame
- #:title "Server"
- (dcommon:servers-table commondat tabdat)))
- (iup:frame
- #:title "Megatest config settings"
- (iup:hbox
- (dcommon:section-matrix rawconfig "setup" "Varname" "Value")
- (iup:vbox
- (dcommon:section-matrix rawconfig "server" "Varname" "Value")
- ;; (iup:frame
- ;; #:title "Disks Areas"
- (dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
- (iup:frame
- #:title "Run statistics"
- (dcommon:run-stats commondat tabdat tab-num: tab-num)))))
-
-;;======================================================================
-;; H A N D L E U S E R C O N T R I B U T E D V I E W S
-;;======================================================================
-
-(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num)
- (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load.
- (source (configf:lookup views-cfgdat view-name "source"))
- (viewgen (configf:lookup views-cfgdat view-name "viewgen"))
- (updater (configf:lookup views-cfgdat view-name "updater"))
- (result-child #f))
- (if (and (common:file-exists? source)
- (file-readable? source))
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl")
- (set! success #f))
- (load source))
- (begin
- (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name)))
- ;; now run the user supplied definition for the tab view
- (if success
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen
- ", with; tab-num=" tab-num ", view-name=" view-name
- ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
- (set! success #f))
- (print "Adding tab " view-name " with proc " viewgen)
- ;; (iup:child-add! tabs
- (set! result-child
- ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*))))
- ;; and finally set the updater
- (if success
- (dboard:commondat-add-updater commondat
- (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater
- "\", with; tabnum=" tab-num ", view-name=" view-name
- ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl")
- (set! success #f))
- (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num)
- ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*)))
- tab-num: tab-num))
- ;;(if success
- ;; (begin
- ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name)
- ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data))))
- result-child))
-
-
-
-(define (dboard:runs-summary-buttons-updater tabdat)
- (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat))
- (modes-left (dboard:tabdat-runs-summary-modes tabdat)))
- (if (or (null? buttons-left) (null? modes-left))
- #t
- (let* ((this-button (car buttons-left))
- (mode-item (car modes-left))
- (this-mode (car mode-item))
- (sel-color "180 100 100")
- (nonsel-color "170 170 170")
- (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
- (if (eq? this-mode current-mode)
- (iup:attribute-set! this-button "BGCOLOR" sel-color)
- (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
- (loop (cdr buttons-left) (cdr modes-left))))))
-
-(define (dboard:runs-summary-xor-labels-updater tabdat)
- (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
- (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
- (mode (dboard:tabdat-runs-summary-mode tabdat)))
- (when (and source-runname-label dest-runname-label)
- (case mode
- ((xor-two-runs xor-two-runs-hide-clean)
- (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
- (prev-run-id (dboard:tabdat-prev-run-id tabdat))
- (curr-runname (if curr-run-id
- (rmt:get-run-name-from-id curr-run-id)
- "None"))
- (prev-runname (if prev-run-id
- (rmt:get-run-name-from-id prev-run-id)
- "None")))
- (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
- (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
- (else
- (iup:attribute-set! source-runname-label "TITLE" "")
- (iup:attribute-set! dest-runname-label "TITLE" ""))))))
-
-(define (dboard:runs-summary-control-panel-updater tabdat)
- (dboard:runs-summary-xor-labels-updater tabdat)
- (dboard:runs-summary-buttons-updater tabdat))
-
-
-;; setup buttons and callbacks to switch between modes in runs summary tab
-;;
-(define (dashboard:runs-summary-control-panel tabdat)
- (let* ((summary-buttons ;; build buttons
- (map
- (lambda (mode-item)
- (let* ((this-mode (car mode-item))
- (this-mode-label (cdr mode-item)))
- (iup:button this-mode-label
- #:action
- (lambda (obj)
- (debug:catch-and-dump
- (lambda ()
- (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
- (dboard:runs-summary-control-panel-updater tabdat))
- "runs summary control panel updater")))))
- (dboard:tabdat-runs-summary-modes tabdat)))
- (summary-buttons-hbox (apply iup:hbox summary-buttons))
- (xor-runname-labels-hbox
- (iup:hbox
- (let ((temp-label
- (iup:label "" #:size "125x15" #:fontsize "10" )))
- (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
- temp-label
- )
- (let ((temp-label
- (iup:label "" #:size "125x15" #:fontsize "10")))
- (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
- temp-label))))
- (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
-
- ;; maybe wrap in a frame
- (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
- (dboard:runs-summary-control-panel-updater tabdat)
- res
- )))
-
-
-
-;;======================================================================
-;; R U N
-;;======================================================================
-;;
-;; display and manage a single run at a time
-
-;; This is the Run Summary tab
-;;
-(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
- (let* ((update-mutex (dboard:commondat-update-mutex commondat))
- (tb (iup:treebox
- #:value 0
- ;;#:name "Runs"
- #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
- #:expand "YES"
- #:addexpanded "YES"
- #:selection-cb
- (lambda (obj id state)
- (debug:catch-and-dump
- (lambda ()
- ;; (print "obj: " obj ", id: " id ", state: " state)
- (let* ((run-path (tree:node->path obj id))
- (run-id (tree-path->run-id tabdat (cdr run-path))))
- (if (number? run-id)
- (begin
- (dboard:tabdat-prev-run-id-set!
- tabdat
- (dboard:tabdat-curr-run-id tabdat))
-
- (dboard:tabdat-curr-run-id-set! tabdat run-id)
- (dboard:tabdat-layout-update-ok-set! tabdat #f)
- ;; (dashboard:update-run-summary-tab)
- )
- ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
- )))
- "selection-cb in runs-summary")
- ;; (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)
- (debug:catch-and-dump
- (lambda ()
-
- ;; Bummer - we dont have the global get/set api mapped in chicken
- ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
- ;; (BB> "modkeys="modkeys))
-
- (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
- ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
- (let* ((toolpath (car (argv)))
- (key (conc lin ":" col))
- (test-id (hash-table-ref/default cell-lookup key -1))
- (run-id (dboard:tabdat-curr-run-id tabdat))
- (run-info (rmt:get-run-info run-id))
- (target (rmt:get-target run-id))
- (runname (db:get-value-by-header (db:get-rows run-info)
- (db:get-header run-info) "runname"))
- (test-info (rmt:get-test-info-by-id run-id test-id))
- (test-name (db:test-get-testname test-info))
- (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
- (if tlast
- (let ((tpatt (tasks:task-get-testpatt tlast)))
- (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
- "%"
- tpatt))
- "%")))
- (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
- (item-test-path (conc test-name "/" (if (equal? item-path "")
- "%"
- item-path)))
- (status-chars (char-set->list (string->char-set status)))
- (run-id (dboard:tabdat-curr-run-id tabdat)))
- (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
- (cond
- ((member #\1 status-chars) ;; 1 is left mouse button
- (dboard:launch-testpanel run-id test-id))
-
- ((member #\2 status-chars) ;; 2 is middle mouse button
-
- (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
- (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
- #:x 'mouse
- #:y 'mouse
- #:modal? "NO")
- )
- (else
- (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
- (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
- #:x 'mouse
- #:y 'mouse
- #:modal? "NO")
- )
- )
-
- )) "runs-summary-click-callback"))))
- (runs-summary-updater
- (lambda ()
- (mutex-lock! update-mutex)
- (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater)
- (dboard:tabdat-view-changed tabdat))
- (debug:catch-and-dump
- (lambda () ;; check that run-matrix is initialized before calling the updater
- (if run-matrix
- (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
- "dashboard:runs-summary-updater")
- )
- (mutex-unlock! update-mutex)))
- (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
- )
- (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
- (dboard:tabdat-runs-tree-set! tabdat tb)
- (iup:vbox
- (iup:split
- #:value 200
- tb
- run-matrix)
- (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-(define (dboard:squarify toggles size)
- (let loop ((hed (car toggles))
- (tal (cdr toggles))
- (cur '())
- (res '()))
- (let* ((ovrflo (>= (length cur) size))
- (newcur (if ovrflo
- (list hed)
- (cons hed cur)))
- (newres (if ovrflo
- (cons cur res)
- res)))
- (if (null? tal)
- (if ovrflo
- newres
- (cons newcur res))
- (loop (car tal)(cdr tal) newcur newres)))))
-
-(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
- (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
- (iup:hbox
- (iup:vbox
- (iup:frame
- #:title "filter test and items"
- (iup:vbox
- (iup:hbox
- (iup:vbox
- (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
- #:expand "NO"
- #:action (lambda (obj unk val)
- (debug:catch-and-dump
- (lambda ()
- (mark-for-update tabdat)
- (update-search commondat tabdat "test-name" val))
- "make-controls")))
- (iup:hbox
- (iup:button "Quit" #:action (lambda (obj)
- (exit))
- #:expand "NO" #:size "40x15")
- (iup:button "Refresh" #:action (lambda (obj)
- (dboard:tabdat-last-data-update-set! tabdat 0)
- (dboard:tabdat-last-runs-update-set! tabdat 0)
- (dboard:tabdat-run-update-times-set! tabdat (make-hash-table))
- (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table))
- (dboard:tabdat-allruns-set! tabdat '())
- (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
- (dboard:tabdat-done-runs-set! tabdat '())
- (dboard:tabdat-not-done-runs-set! tabdat '())
- (dboard:tabdat-view-changed-set! tabdat #t)
- (dboard:commondat-please-update-set! commondat #t)
- (mark-for-update tabdat))
- #:expand "NO" #:size "40x15")
- (iup:button "Collapse" #:action (lambda (obj)
- (debug:catch-and-dump
- (lambda ()
- (let ((myname (iup:attribute obj "TITLE")))
- (if (equal? myname "Collapse")
- (begin
- (for-each (lambda (tname)
- (hash-table-set! *collapsed* tname #t))
- (dboard:tabdat-item-test-names tabdat))
- (iup:attribute-set! obj "TITLE" "Expand"))
- (begin
- (for-each (lambda (tname)
- (hash-table-delete! *collapsed* tname))
- (hash-table-keys *collapsed*))
- (iup:attribute-set! obj "TITLE" "Collapse"))))
- (mark-for-update tabdat))
- "make-controls collapse button"))
- #:expand "NO" #:size "40x15")))
- (iup:vbox
- ;; (iup:button "Sort -t" #:action (lambda (obj)
- ;; (next-sort-option)
- ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
- ;; (mark-for-update tabdat)))
-
- (let* ((hide #f)
- (show #f)
- (hide-empty #f)
- (sel-color "180 100 100")
- (nonsel-color "170 170 170")
- (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus"))
- (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL"
- #:size "80x15"
- #:dropdown "YES"
- #:action (lambda (obj val index lbstate)
- (set! *tests-sort-reverse* index)
- (mark-for-update tabdat))))
- (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
-
- (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
-
- ;; (set! hide-empty (iup:button "HideEmpty"
- ;; ;; #:expand HORIZONTAL"
- ;; #:expand "NO" #:size "80x15"
- ;; #:action (lambda (obj)
- ;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
- ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
- ;; (mark-for-update tabdat))))
- (set! hide (iup:button "Hide"
- #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
- #:action (lambda (obj)
- (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
- ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
- (iup:attribute-set! hide "BGCOLOR" sel-color)
- (iup:attribute-set! show "BGCOLOR" nonsel-color)
- (mark-for-update tabdat))))
- (set! show (iup:button "Show"
- #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
- #:action (lambda (obj)
- (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
- (iup:attribute-set! show "BGCOLOR" sel-color)
- (iup:attribute-set! hide "BGCOLOR" nonsel-color)
- (mark-for-update tabdat))))
- (iup:attribute-set! hide "BGCOLOR" sel-color)
- (iup:attribute-set! show "BGCOLOR" nonsel-color)
- ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
- (iup:vbox
- (iup:hbox hide show)
- sort-lb)))
- )
-
- ;; insert extra widget here
- (if extra-widget
- extra-widget
- (iup:hbox)) ;; empty widget
-
-
-
-
- )))
-
- (let* ((status-toggles (map (lambda (status)
- (iup:toggle (conc status)
- #:fontsize 8 ;; btn-fontsz ;; "10"
- ;; #:expand "HORIZONTAL"
- #:action (lambda (obj val)
- (mark-for-update tabdat)
- (if (eq? val 1)
- (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
- (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
- (set-bg-on-filter commondat tabdat))))
- (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
- (state-toggles (map (lambda (state)
- (iup:toggle (conc state)
- #:fontsize 8 ;; btn-fontsz
- ;; #:expand "HORIZONTAL"
- #:action (lambda (obj val)
- (mark-for-update tabdat)
- (if (eq? val 1)
- (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
- (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
- (set-bg-on-filter commondat tabdat))))
- (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
- (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
- (iup:vbox
- (iup:hbox
- (iup:frame
- #:title "states"
- (apply
- iup:hbox
- (map (lambda (colgrp)
- (apply iup:vbox colgrp))
- (dboard:squarify state-toggles 3))))
- (iup:frame
- #:title "statuses"
- (apply
- iup:hbox
- (map (lambda (colgrp)
- (apply iup:vbox colgrp))
- (dboard:squarify status-toggles 3)))))
- ;;
- ;; (iup:frame
- ;; #:title "state/status filter"
- ;; (iup:vbox
- ;; (apply
- ;; iup:hbox
- ;; (map
- ;; (lambda (status-toggle state-toggle)
- ;; (iup:vbox
- ;; status-toggle
- ;; state-toggle))
- ;; status-toggles state-toggles))
-
- ;; horizontal slider was here
-
- )))))
-
-(define (dashboard:runs-horizontal-slider tabdat )
- (iup:valuator #:valuechanged_cb (lambda (obj)
- (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
- (oldmax (string->number (iup:attribute obj "MAX")))
- (maxruns (dboard:tabdat-tot-runs tabdat)))
- (dboard:tabdat-start-run-offset-set! tabdat val)
- (mark-for-update tabdat)
- (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
- (iup:attribute-set! obj "MAX" (* maxruns 10))))
- #:expand "HORIZONTAL"
- #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
- #:min 0
- #:step 0.01))
-
-;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
-;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004)
-;; simple-run-event_time procedure (x3834)
-;; simple-run-event_time-set! procedure (x3830 val3831)
-;; simple-run-id procedure (x3794)
-;; simple-run-id-set! procedure (x3790 val3791)
-;; simple-run-owner procedure (x3826)
-;; simple-run-owner-set! procedure (x3822 val3823)
-;; simple-run-runname procedure (x3802)
-;; simple-run-runname-set! procedure (x3798 val3799)
-;; simple-run-state procedure (x3810)
-;; simple-run-state-set! procedure (x3806 val3807)
-;; simple-run-status procedure (x3818)
-;; simple-run-status-set! procedure (x3814 val3815)
-;; simple-run-target procedure (x3786)
-;; simple-run-target-set! procedure (x3782 val3783)
-;; simple-run? procedure (x3780)
-
-
-;;======================================================================
-;; Extracting the data to display for runs
-;;
-;; This needs to be re-entrant such that it does one column per call
-;; on the zeroeth call update runs data
-;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
-;; on last run reset to zeroeth
-;;
-;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
-;; - put this information into two data structures:
-;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
-;; status, starttime, duration, non-deleted testcount>
-;; ordernum reflects order as received from sql query
-;; b. sparsevec of id => runstruct
-;; 2. for each run in runshash ordered by ordernum do:
-;; retrieve data since last update for that run
-;; if there is a deleted test - retrieve full data
-;; if there are non-deleted tests register this run in the columns sparsevec
-;; if this is the zeroeth column regenerate the rows sparsevec
-;; if this column is in the visible zone update visible cells
-;;
-;; Other factors:
-;; 1. left index handling:
-;; - add test/itempaths to left index as discovered, re-order and
-;; update row -> test/itempath mapping on each read run
-;;======================================================================
-
-;; runs is
-;; get ALL runs info
-;; update rdat-targ-run-id
-;; update rdat-runs
-;;
-(define (dashboard:update-runs-data rdat)
- (let* ((tb (dboard:rdat-runs-tree rdat))
- (targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
- (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
- (state-sql-filt (dboard:rdat-run-state-sql-filt rdat))
- (status-sql-filt (dboard:rdat-run-status-sql-filt rdat))
- ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
- (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
- (numruns (length data)))
- ;; store in the runsbynum vector
- (dboard:rdat-runsbynum-set! rdat (list->vector data))
- ;; update runs id => runrec
- ;; update targ-runid target/runname => run-id
- (for-each
- (lambda (runrec)
- (let* ((run-id (simple-run-id runrec))
- (full-targ-runname (conc (simple-run-target runrec) "/"
- (simple-run-runname runrec))))
- (debug:print 0 *default-log-port* "Update run " run-id)
- (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
- (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
- ))
- data)
- numruns))
-
-;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
-;;
-(define (dashboard:update-run-data runnum rdat)
- (let* ((curr-time (current-seconds))
- (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum))
- (run-id (simple-run-id runrec))
- (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
- ;; filters
- (testname-sql-filt (dboard:rdat-testname-sql-filt rdat))
- ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat))
- (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet
- (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet
- (tests (rmt:get-tests-for-run-state-status run-id
- testname-sql-filt
- last-update ;; last-update
- )))
- (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
- (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
- run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update)
- (length tests)))
-
-(define (new-runs-updater commondat rdat)
- (let* ((runnum (dboard:rdat-runnum rdat))
- (start-time (current-milliseconds))
- (tot-runs #f))
- (if (eq? runnum 0)(dashboard:update-runs-data rdat))
- (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
- (let loop ((rn runnum))
- (if (and (< (- (current-milliseconds) start-time) 250)
- (< rn tot-runs))
- (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
- 0 ;; start over
- (+ rn 1)))) ;; (+ runnum 1)))
- (dashboard:update-run-data rn rdat)
- (dboard:rdat-runnum-set! rdat newrn)
- (if (> newrn 0)
- (loop newrn)))))
- (if (>= (dboard:rdat-runnum rdat) tot-runs)
- (dboard:rdat-runnum-set! rdat 0))
- ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
- ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
- ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
- '()))
-
-(define (dboard:runs-new-matrix commondat rdat)
- (iup:matrix
- #:alignment1 "ALEFT"
- ;; #:expand "YES" ;; "HORIZONTAL"
- #:scrollbar "YES"
- #:numcol 10
- #:numlin 20
- #:numcol-visible 5 ;; (min 8)
- #:numlin-visible 1
- #:click-cb
- (lambda (obj row col status)
- (let* ((cell (conc row ":" col)))
- #f))
- ))
-
-(define (make-runs-view commondat rdat tab-num)
- ;; register an updater
- (dboard:commondat-add-updater
- commondat
- (lambda ()
- (new-runs-updater commondat rdat))
- tab-num: tab-num)
-
- (iup:vbox
- (iup:split
- #:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 100
- (dboard:runs-tree-new-browser commondat rdat)
- (dboard:runs-new-matrix commondat rdat)
- )))
-
-(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
- (let* ((stats-dat (dboard:tabdat-make-data))
- (runs-dat (dboard:tabdat-make-data))
- (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
- (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
- (runcontrols-dat (dboard:tabdat-make-data))
- (runtimes-dat (dboard:tabdat-make-data))
- (nruns (dboard:tabdat-numruns runs-dat))
- (ntests (dboard:tabdat-num-tests runs-dat))
- (keynames (dboard:tabdat-dbkeys runs-dat))
- (nkeys (length keynames))
- (runsvec (make-vector nruns))
- (header (make-vector nruns))
- (lftcol (make-vector ntests))
- (keycol (make-vector ntests))
- (controls (dboard:make-controls commondat runs-dat)) ;; '())
- (lftlst '())
- (hdrlst '())
- (bdylst '())
- (result '())
- (i 0)
- (btn-height (dboard:tabdat-runs-btn-height runs-dat))
- (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat))
- (cell-width (dboard:tabdat-runs-cell-width runs-dat))
- (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")))
- ;; controls (along bottom)
- ;; (set! controls (dboard:make-controls commondat runs-dat))
-
- ;; create the left most column for the run key names and the test names
- (set! lftlst
- (list (iup:hbox
- (iup:label) ;; (iup:valuator)
- (apply iup:vbox
- (map (lambda (x)
- (let ((res (iup:hbox
- #:expand "HORIZONTAL"
- (iup:label x
- #:size (conc 40 btn-height)
- #:fontsize btn-fontsz
- #:expand "NO") ;; "HORIZONTAL")
- (iup:textbox
- #:size (conc 35 btn-height)
- #:fontsize btn-fontsz
- #:value "%"
- #:expand "NO" ;; "HORIZONTAL"
- #:action (lambda (obj unk val)
- ;; each field
- ;; (field name is "x" var) live updates
- ;; the search filter as it is typed
- (dboard:tabdat-target-set! runs-dat #f)
- ;; ensure fields text boxes are used
- ;; and not the info from the tree
- (mark-for-update runs-dat)
- (update-search commondat runs-dat x val))))))
- (set! i (+ i 1))
- res))
- keynames)))))
- (let loop ((testnum 0)
- (res '()))
- (cond
- ((>= testnum ntests)
- ;; now lftlst will be an hbox with the test keys and the test name labels
- (set! lftlst
- (append
- lftlst
- (list
- (iup:hbox
- #:expand "HORIZONTAL"
- (iup:valuator
- #:valuechanged_cb
- (lambda (obj)
- (let ((val (string->number (iup:attribute obj "VALUE")))
- (oldmax (string->number (iup:attribute obj "MAX")))
- (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:tabdat-start-test-offset-set! runs-dat
- (inexact->exact (round (/ val 10))))
- (debug:print 6 *default-log-port*
- "(dboard:tabdat-start-test-offset runs-dat) "
- (dboard:tabdat-start-test-offset runs-dat) " val: " val
- " newmax: " newmax " oldmax: " oldmax)
- (if (< val 10)
- (iup:attribute-set! obj "MAX" newmax))
- ))
- #:expand "VERTICAL"
- #:orientation "VERTICAL"
- #:min 0
- #:step 0.01)
- (apply iup:vbox (reverse res)))))))
- (else
- (let ((labl (iup:button
- "" ;; the testname labels
- #:flat "YES"
- #:alignment "ALEFT"
- ; #:image img1
- ; #:impress img2
- #:size (conc cell-width btn-height)
- #:expand "HORIZONTAL"
- #:fontsize btn-fontsz
- #:action (lambda (obj)
- (mark-for-update runs-dat)
- (toggle-hide testnum (dboard:commondat-uidat commondat))))))
- (vector-set! lftcol testnum labl)
- (loop (+ testnum 1)(cons labl res))))))
- ;; These are the headers for each row
- (let loop ((runnum 0)
- (keynum 0)
- (keyvec (make-vector nkeys))
- (res '()))
- (cond ;; nb// no else for this approach.
- ((>= runnum nruns) #f)
- ((>= keynum nkeys)
- (vector-set! header runnum keyvec)
- (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst))
- (loop (+ runnum 1) 0 (make-vector nkeys) '()))
- (else
- (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15"
- (vector-set! keyvec keynum labl)
- (loop runnum (+ keynum 1) keyvec (cons labl res))))))
- ;; By here the hdrlst contains a list of vboxes containing nkeys labels
- (let loop ((runnum 0)
- (testnum 0)
- (testvec (make-vector ntests))
- (res '()))
- (cond
- ((>= runnum nruns) #f) ;; (vector tableheader runsvec))
- ((>= testnum ntests)
- (vector-set! runsvec runnum testvec)
- (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
- (loop (+ runnum 1) 0 (make-vector ntests) '()))
- (else
- (let* ((button-key (mkstr runnum testnum))
- (butn (iup:button
- (if use-bgcolor #f " ") ;; button-key
- #:size (conc cell-width btn-height )
- #:expand "HORIZONTAL"
- #:fontsize btn-fontsz
- #:button-cb
- (lambda (obj a pressed x y btn . rem)
- ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
- (if (substring-index "3" btn)
- (if (eq? pressed 1)
- (let* ((toolpath (car (argv)))
- (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
- (test-id (db:test-get-id (vector-ref buttndat 3)))
- (run-id (db:test-get-run_id (vector-ref buttndat 3)))
- (run-info (rmt:get-run-info run-id))
- (target (rmt:get-target run-id))
- (runname (db:get-value-by-header (db:get-rows run-info)
- (db:get-header run-info) "runname"))
- (test-info (rmt:get-test-info-by-id run-id test-id))
- (test-name (db:test-get-testname test-info))
- (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
- (if tlast
- (let ((tpatt (tasks:task-get-testpatt tlast)))
- (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
- "%"
- tpatt))
- "%")))
- (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
- (item-test-path (conc test-name "/" (if (equal? item-path "")
- "%"
- item-path))))
- (iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
- #:x 'mouse
- #:y 'mouse
- #:modal? "NO")
- ;; (print "got here")
- ))
- (if (eq? pressed 0)
- (let* ((toolpath (car (argv)))
- (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
- (test-id (db:test-get-id (vector-ref buttndat 3)))
- (run-id (db:test-get-run_id (vector-ref buttndat 3))))
- (dboard:launch-testpanel run-id test-id))))))))
- (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR")
- (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f))
- (vector-set! testvec testnum butn)
- (loop runnum (+ testnum 1) testvec (cons butn res))))))
- ;; now assemble the hdrlst and bdylst and kick off the dialog
- (iup:show
- (iup:dialog
- #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
- #:menu (dcommon:main-menu)
- (let* ((runs-view (iup:vbox
- (iup:split
- #:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 100
- (dboard:runs-tree-browser commondat runs-dat)
- (iup:split
- #:value 100
- ;; left most block, including row names
- (apply iup:vbox lftlst)
- ;; right hand block, including cells
- (iup:vbox
- #:expand "YES"
- ;; the header
- (apply iup:hbox (reverse hdrlst))
- (apply iup:hbox (reverse bdylst))
- (dashboard:runs-horizontal-slider runs-dat))))
- controls
- ))
- (views-cfgdat (common:load-views-config))
- (additional-tabnames '())
- (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
- ;; (data (dboard:tabdat-init (make-d:data)))
- (additional-views ;; process views-dat
- (let ((tab-num tab-start-num)
- (result '()))
- (for-each
- (lambda (view-name)
- (debug:print 0 *default-log-port* "Adding view " view-name)
- (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view?
- (if (not (string? cfgtype))
- (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name
- "\" is missing needed sections. "
- "Please consult the documenation and update ~/.mtviews.config or "
- *toppath* "/.mtviews.config")
- (case (string->symbol cfgtype)
- ;; user supplied source for a tab
- ;;
- ((external) ;; was tabs
- (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num)))
- (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames))
- (set! tab-num (+ tab-num 1))
- (set! result (append result (list tab-content)))))))))
- (sort (configf:get-sections views-cfgdat) ;; (hash-table-keys views-cfgdat)
- (lambda (a b)
- (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999))
- (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999)))
- (> order-a order-b)))))
- result))
- (tabs (apply iup:tabs
- #:tabchangepos-cb (lambda (obj curr prev)
- (debug:catch-and-dump
- (lambda ()
- (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
- (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
- (dboard:tabdat-layout-update-ok-set! tabdat #f))
- (dboard:commondat-curr-tab-num-set! commondat curr)
- (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
- (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:tabdat-layout-update-ok-set! tabdat #t)))
- "tabchangepos"))
- (dashboard:summary commondat stats-dat tab-num: 0)
- runs-view
- ;; (make-runs-view commondat runs2-dat 2)
- (dashboard:runs-summary commondat onerun-dat tab-num: 2)
- (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
- (dashboard:run-times commondat runtimes-dat tab-num: 4)
- (iup:vbox (iup:button "Pushme")) ;; tab 5
- additional-views)))
- ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
- (iup:attribute-set! tabs "TABTITLE0" "Summary")
- (iup:attribute-set! tabs "TABTITLE1" "Runs")
- ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
- (iup:attribute-set! tabs "TABTITLE2" "Run Summary")
- (iup:attribute-set! tabs "TABTITLE3" "Run Control")
- (iup:attribute-set! tabs "TABTITLE4" "Run Times")
- (iup:attribute-set! tabs "TABTITLE5" "Sys Status")
-
- ;; (iup:attribute-set! tabs "TABTITLE3" "New View")
- ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
-
- ;; set the tab names for user added tabs
- (for-each
- (lambda (tab-info)
- (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
- additional-tabnames)
-
- (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
- ;; make the iup tabs object available (for changing color for example)
- (dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
- ;; now set up the tabdat lookup
- (dboard:common-set-tabdat! commondat 0 stats-dat)
- (dboard:common-set-tabdat! commondat 1 runs-dat)
- ;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
- (dboard:common-set-tabdat! commondat 2 onerun-dat)
- (dboard:common-set-tabdat! commondat 3 runcontrols-dat)
- (dboard:common-set-tabdat! commondat 4 runtimes-dat)
-
- (iup:vbox
- tabs
- ;; controls
- ))))
- (vector keycol lftcol header runsvec)))
-
-(define (dboard:setup-num-rows tabdat)
- (dboard:tabdat-num-tests-set! tabdat (string->number
- (or (args:get-arg "-rows")
- (get-environment-variable "DASHBOARDROWS")
- "15"))))
-
-(define *ord* #f)
-(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000"))
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define *last-recalc-ended-time* 0)
-
-(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
- (or please-update-buttons
- (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
- (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
- (> (current-seconds)(+ last-db-update-time 1)))))
-
-;; Force creation of the db in case it isn't already there.
-;; (tasks:open-db)
-
-(define (dashboard:get-youngest-run-db-mod-time dbdir)
- (handle-exceptions
- exn
- (begin
- (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
- ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn)
- (current-seconds)) ;; something went wrong - just print an error and return current-seconds
- (common:max (map (lambda (filen)
- (file-modification-time filen))
- (glob (conc dbdir "/*.db*"))))))
-
-(define (dashboard:monitor-changed? commondat tabdat)
- (let* ((run-update-time (current-seconds))
- (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
- (monitor-modtime (if (and monitor-db-path (common: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 (dboard:get-last-db-update tabdat context)
- (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))
-
-(define (dboard:set-last-db-update! tabdat context newtime)
- (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
-
-;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
-;; is closed (I think). If db dir starts with /tmp always return true
-;;
-(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
- (let* ((run-update-time (current-seconds))
- (dbdir (dboard:tabdat-dbdir tabdat))
- (modtime (dashboard:get-youngest-run-db-mod-time dbdir))
- (recalc (dashboard:recalc modtime
- (dboard:commondat-please-update commondat)
- (dboard:get-last-db-update tabdat context-key))))
- ;; (dboard:tabdat-last-db-update tabdat))))
- (if recalc
- (dboard:set-last-db-update! tabdat context-key run-update-time))
- (dboard:commondat-please-update-set! commondat #f)
- recalc))
-
-;; point inside line
-;;
-(define-inline (dashboard:px-between px lx1 lx2)
- (and (< lx1 px)(> lx2 px)))
-
-;;Not reference anywhere
-;;
-;; 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)))))
-
-;; 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* ((access-mode (dboard:tabdat-access-mode tabdat))
- (last-runs-update (dboard:tabdat-last-runs-update tabdat))
- (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
- (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (runs-hash (let ((ht (make-hash-table)))
- (for-each (lambda (run)
- (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
- (vector-ref runs-dat 1))
- ht))
- (run-ids (sort (filter number? (hash-table-keys runs-hash))
- (lambda (a b)
- (let* ((record-a (hash-table-ref runs-hash a))
- (record-b (hash-table-ref runs-hash b))
- (time-a (db:get-value-by-header record-a runs-header "event_time"))
- (time-b (db:get-value-by-header record-b runs-header "event_time")))
- (< time-a time-b)))))
- (tb (dboard:tabdat-runs-tree tabdat))
- (num-runs (length (hash-table-keys runs-hash)))
- (update-start-time (current-seconds))
- (inc-mode #f))
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- ;; fill in the tree
- (if (and tb
- (not inc-mode))
- (for-each
- (lambda (run-id)
- (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
- (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
- (dboard:tabdat-keys tabdat)))
- (run-name (db:get-value-by-header run-record runs-header "runname"))
- (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
- (run-path (append key-vals (list run-name))))
- ;; (existing (tree:find-node tb run-path)))
- (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
- (begin
- (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
- ;; Here we update the tests treebox and tree keys
- (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
- ;; userdata: (conc "run-id: " run-id))
- (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
- ;; (set! colnum (+ colnum 1))
- ))))
- run-ids))
- ;; (print "Updating rundat")
- (if (dboard:tabdat-keys tabdat) ;; have keys yet?
- (let* ((num-keys (length (dboard:tabdat-keys tabdat)))
- (targpatt (map (lambda (k v)
- (list k v))
- (dboard:tabdat-keys tabdat)
- (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
- '("%" "%"))
- (make-list num-keys "%"))
- num-keys)
- ))
- (runpatt (if (and (dboard:tabdat-target tabdat)
- (list? (dboard:tabdat-target tabdat))
- (not (null? (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" "%")
- (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-readable? dbpth))
- (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
- db)
- #f)))
-
-;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
-;;
-(define (dboard:graph-read-data cmdstring tstart tend)
- (let* ((parts (string-split cmdstring))) ;; spaces not allowed
- (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ...
- (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring)
- (let* ((dbdef (list-ref parts 0))
- (tablen (list-ref parts 1))
- (timef (list-ref parts 2))
- (varfn (list-ref parts 3))
- (valfn (list-ref parts 4))
- (fields (cdr (cddddr parts)))
- (db (dboard:graph-db-open dbdef))
- (res-ht (make-hash-table)))
- (if db
- (begin
- (for-each
- (lambda (fieldname) ;; fields
- (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC"))
- (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
- (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
- (reverse
- (sqlite3:fold-row
- (lambda (res t var val)
- (cons (vector t var val) res))
- '() db all-dat-qrystr)))
- (let ((zeropt (condition-case
- (sqlite3:first-row db all-dat-qrystr)
- (exn (busy)(db:generic-error-printout exn "ERROR: database " dbdef
- " is locked. Try copying to another location, remove original and copy back.")))))
- (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
- (hash-table-set! res-ht
- fieldname
- (cons
- (apply vector tstart (cdr zeropt))
- (hash-table-ref/default res-ht fieldname '())))))))
- fields)
- res-ht)
- #f)))))
-
-;; graph data
-;; tsc=timescale, tfn=function; time->x
-;;
-(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin)
- (let* ((dwg (dboard:tabdat-drawing tabdat))
- (lib (vg:get/create-lib dwg "runslib"))
- (cnv (dboard:tabdat-cnv tabdat))
- (dur (- tstart tend)) ;; time duration
- (cmp (vg:get-component dwg "runslib" compname))
- (cfg (configf:get-section *configdat* "graph"))
- (stdcolor (vg:rgb->number 120 130 140))
- (delta-y (- uly lly))
- (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat))
- (graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
- (graph-matrix (dboard:tabdat-graph-matrix tabdat))
- (changed #f))
- (vg:add-obj-to-comp
- cmp
- (vg:make-rect-obj llx lly ulx uly))
- (vg:add-obj-to-comp
- cmp
- (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart)))
- (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend)))
- (let loop ((mark first)
- (count 0))
- (let* ((smark (tfn mark)) ;; scale the mark
- (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark
- (label (conc (* count span) timesym))) ;; was mark-delta
- (if (> count 2)
- (begin
- (vg:add-obj-to-comp
- cmp
- (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly))
- (vg:add-obj-to-comp
- cmp
- (vg:make-text-obj (- smark 1)(- lly 10) label))))
- (if (< mark (- tend time-blk))
- (loop (+ mark time-blk)(+ count 1))))))
- (for-each
- (lambda (cf)
- (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend)))
- (if alldat
- (for-each
- (lambda (fieldn)
- (let*-values (((dat) (hash-table-ref alldat fieldn))
- ((vals minval maxval) (if (null? dat)
- (values '() #f #f)
- (let loop ((hed (car dat))
- (tal (cdr dat))
- (res '())
- (min (vector-ref (car dat) 2))
- (max (vector-ref (car dat) 2)))
- (let* ((val (vector-ref hed 2))
- (newmin (if (< val min) val min))
- (newmax (if (> val max) val max))
- (newres (cons val res)))
- (if (null? tal)
- (values (reverse res) (- newmin 2) (+ newmax 2))
- (loop (car tal)(cdr tal) newres newmin newmax)))))))
- (if (not (hash-table-exists? graph-matrix-table fieldn))
- (begin
- (let* ((graph-color-rgb (vg:generate-color-rgb))
- (graph-color (vg:iup-color->number graph-color-rgb))
- (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat))
- (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat))
- (graph-cell (conc graph-matrix-row ":" graph-matrix-col))
- (graph-dat (make-dboard:graph-dat
- id: fieldn
- color: graph-color
- flag: #t
- cell: graph-cell
- )))
- (hash-table-set! graph-matrix-table fieldn graph-dat)
- (hash-table-set! graph-cell-table graph-cell graph-dat)
- ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ")
- ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ")
- (set! changed #t)
- (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn)
- (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb)
- (if (> graph-matrix-col 10)
- (begin
- (dboard:tabdat-graph-matrix-col-set! tabdat 1)
- (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1)))
- (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1)))
- )))
- (if (not (null? vals))
- (let* (;; (maxval (apply max vals))
- ;; (minval (min 0 (apply min vals)))
- (yoff (- minval lly)) ;; minval))
- (deltaval (- maxval minval))
- (yscale (/ delta-y (if (zero? deltaval) 1 deltaval)))
- (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale))))
- (graph-dat (hash-table-ref graph-matrix-table fieldn))
- (graph-color (dboard:graph-dat-color graph-dat))
- (graph-flag (dboard:graph-dat-flag graph-dat)))
- (if graph-flag
- (begin
- (vg:add-obj-to-comp
- cmp
- (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval)))
- (vg:add-obj-to-comp
- cmp
- (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval)))
- (fold
- (lambda (next prev) ;; #(time ? val) #(time ? val)
- (if prev
- (let* ((yval (vector-ref prev 2))
- (yval-next (vector-ref next 2))
- (last-tval (tfn (vector-ref prev 0)))
- (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2))))
- (next-yval (yfunc yval-next))
- (curr-tval (tfn (vector-ref next 0))))
- (if (>= curr-tval last-tval)
- (begin
- (vg:add-obj-to-comp
- cmp
- ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
- (vg:make-line-obj last-tval last-yval curr-tval last-yval
- line-color: graph-color))
- (vg:add-obj-to-comp
- cmp
- ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale))
- (vg:make-line-obj curr-tval last-yval curr-tval next-yval
- line-color: graph-color)))
- (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval))))
- next)
- #f ;; (vector tstart minval minval)
- dat)
- )))))) ;; for each data point in the series
- (hash-table-keys alldat)))))
- cfg)
- (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL"))))
-
-;; run times tab
-;;
-(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
- ;; each test is an object in the run component
- ;; each run is a component
- ;; all runs stored in runslib library
- (let escapeloop ((escape #f))
- (if (and (not escape)
- tabdat)
- (let* ((canvas-margin 10)
- (not-done-runs (dboard:tabdat-not-done-runs tabdat))
- (mtx (dboard:tabdat-runs-mutex tabdat))
- (drawing (dboard:tabdat-drawing tabdat))
- (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
- (allruns (dboard:tabdat-allruns tabdat))
- (num-runs (length allruns))
- (cnv (dboard:tabdat-cnv tabdat))
- (compact-layout (dboard:tabdat-compact-layout tabdat))
- (row-height (if compact-layout 2 10))
- (graph-height 120)
- (run-to-run-margin 25))
- (dboard:tabdat-layout-update-ok-set! tabdat #t)
- (if (and (canvas? cnv)
- (not (null? allruns))) ;; allruns can go null when browsing the runs tree
- (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 (common:min-max < (map db:test-get-event_time testsdat)))
- (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))))
- (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero
- (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start))
- (run-duration (- run-end run-start))
- (timescale (/ (- sizex (* 2 canvas-margin))
- (if (> run-duration 0)
- run-duration
- (current-seconds)))) ;; a least lously guess
- (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
- (num-tests (length hierdat))
- (tot-tests (length testsdat))
- (width (* timescale run-duration))
- (graph-lly (calc-y (/ -50 row-height)))
- (graph-uly (- (calc-y 0) canvas-margin))
- (sec-per-50pt (/ 50 timescale))
- )
- ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt)
- ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
- (mutex-lock! mtx)
- (vg:add-comp-to-lib runslib run-full-name runcomp)
- ;; Have to keep moving the instantiated box as it is anchored at the lower left
- ;; this should have worked for x in next statement? (maptime run-start)
- ;; add 60 to make room for the graph
- (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
- (mutex-unlock! mtx)
- ;; (set! run-start-row (+ max-row 2))
- ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
- ;; get tests in list sorted by event time ascending
- (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
- (tests-tal (cdr hierdat))
- (test-num 1))
- (let ((iterated (> (length test-ids) 1))
- (first-rownum #f)
- (num-items (length test-ids)))
- (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items
- (tidstal (cdr test-ids))
- (item-num 1)
- (test-objs '()))
- (let* ((testdat (hash-table-ref tests-ht test-id))
- (event-time (maptime (db:test-get-event_time testdat)))
- (test-duration (* timescale (db:test-get-run_duration testdat)))
- (end-time (+ event-time test-duration))
- (test-name (db:test-get-testname testdat))
- (item-path (db:test-get-item-path testdat))
- (state (db:test-get-state testdat))
- (status (db:test-get-status testdat))
- (test-fullname (conc test-name "/" item-path))
- (name-color (gutils:get-color-for-state-status state status))
- (new-test-objs
- (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1)))
- (if (dashboard:row-collision rowhash rownum event-time end-time)
- (loop (+ rownum 1))
- (let* ((title (if iterated (if compact-layout #f item-path) test-name))
- (lly (calc-y rownum)) ;; (- sizey (* rownum row-height)))
- (uly (+ lly row-height))
- (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on
- (obj (vg:make-rect-obj event-time lly use-end uly
- fill-color: (vg:iup-color->number (car name-color))
- text: title
- font: "Helvetica -10"))
- (bar-end (max use-end
- (+ event-time
- (if compact-layout
- 1
- (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter
- ;; (if iterated
- ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
- ;; (if (not first-rownum)
- ;; (begin
- ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
- ;; (set! first-rownum rownum)))
- (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum)
- (dboard:tabdat-max-row tabdat))) ;; track the max row used
- ;; bar-end has some margin for text - accounting for text in extents not yet working.
- (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5))
- (vg:add-obj-to-comp runcomp obj)
- ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat)))
- (dboard:tabdat-view-changed-set! tabdat #t)
- (cons obj test-objs))))))
- ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time)
- ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
- (if (> item-num 50)
- (if (eq? 0 (modulo item-num 50))
- (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
- ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
- (let ((newdoneruns (cons rundat doneruns)))
- (if (null? tidstal)
- (if iterated
- (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs))
- (llx (- (car xtents) 10))
- (lly (- (cadr xtents) 10))
- (ulx (+ 5 (caddr xtents)))
- (uly (+ 10 (cadddr xtents))))
- ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items)
- ;; This is the box around the tests of an iterated test
- (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
- text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
- line-color: (vg:rgb->number 0 0 255 a: 128)
- font: "Helvetica -10"))
- ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
- (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
- (if (dboard:tabdat-layout-update-ok tabdat)
- (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)
- (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
- )))))
- ;; If it is an iterated test put box around it now.
- (if (not (null? tests-tal))
- (if #f ;; (> (- (current-seconds) update-start-time) 5)
- (print "drawing runs taking too long")
- (if (dboard:tabdat-layout-update-ok tabdat)
- (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))
- (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
- )))))
- ;; placeholder box
- (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
- ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
- ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
- ;; instantiate the component
- (let* ((extents (vg:components-get-extents drawing runcomp))
- (new-xtnts (apply vg:grow-rect 5 5 extents))
- (llx (list-ref new-xtnts 0))
- (lly (list-ref new-xtnts 1))
- (ulx (list-ref new-xtnts 2))
- (uly (list-ref new-xtnts 3))
- (outln (vg:make-rect-obj -5 lly ulx uly
- text: run-full-name
- line-color: (vg:rgb->number 255 0 255 a: 128))))
- ; (vg:components-get-extents d1 c1)))
- ;; this is the box around the run
- (mutex-lock! mtx)
- (vg:add-obj-to-comp runcomp outln)
- (mutex-unlock! mtx)
- ;; this is where we have enough info to place the graph
- (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
- (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
- ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
- ))
- ;; end of the run handling loop
- (if (not (dboard:tabdat-layout-update-ok tabdat))
- (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
- (let ((newdoneruns (cons rundat doneruns)))
- (if (null? runtal)
- (begin
- (dboard:rundat-data-changed-set! rundat #f)
- (dboard:tabdat-not-done-runs-set! tabdat '())
- (dboard:tabdat-done-runs-set! tabdat allruns))
- (if #f ;; (> (- (current-seconds) update-start-time) 5)
- (begin
- (print "drawing runs taking too long.... have " (length runtal) " remaining")
- ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
- ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
- (dboard:tabdat-not-done-runs-set! tabdat runtal))
- (begin
- (if (dboard:tabdat-layout-update-ok tabdat)
- (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
- (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
- ))))))))) ;; new-run-start-row
- )))
- (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
-
-(define (dashboard:calc-key-patterns tabdat)
- ;; generate key patterns from the target stored in tabdat
- (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
- (let ((fres (if (dboard:tabdat-target tabdat)
- (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
- (map (lambda (k v)(list k v)) dbkeys ptparts))
- (let ((res '()))
- (for-each (lambda (key)
- (if (not (equal? key "runname"))
- (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
- (if val (set! res (cons (list key val) res))))))
- dbkeys)
- res))))
- fres)))
-
-
-;; handy trick for printing a record
-;;
-;; (pp (dboard:tabdat->alist tabdat))
-;;
-;; removing the tabdat-values proc
-;;
-;; (define (tabdat-values tabdat)
-
-;; runs update-rundat using the various filters from the gui
-;;
-(define (dashboard:do-update-rundat tabdat)
- (let* ((runnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%"))
- (numruns (dboard:tabdat-numruns tabdat))
- (testnamepatt (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%"))
- (keypatts (dashboard:calc-key-patterns tabdat)))
- (dboard:update-rundat
- tabdat
- runnamepatt
- numruns
- testnamepatt
- keypatts)))
-
-(define (dashboard:runs-tab-updater commondat tab-num)
- (debug:catch-and-dump
- (lambda ()
- (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
- (dbkeys (dboard:tabdat-dbkeys tabdat)))
- (dashboard:do-update-rundat tabdat)
- (let ((uidat (dboard:commondat-uidat commondat)))
- (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
- ))
- "dashboard:runs-tab-updater"))
-
-;;======================================================================
-;; The heavy lifting starts here
-;;======================================================================
-
-(define (dashboard-main)
- (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; not used for now, update for .db area and use for write access detection
- #;(if (and (common:file-exists? mtdb-path)
- (file-writable? mtdb-path))
- (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") ","))))
- (if (> (length d) 1)
- d
- (list #f #f))))
- (run-id (car dat))
- (test-id (cadr dat)))
- (if (and (number? run-id)
- (number? test-id)
- (>= test-id 0))
- (dashboard-tests:examine-test run-id test-id)
- (begin
- (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
- (exit 1)))))
- ;; ((args:get-arg "-guimonitor")
- ;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
- (else
- (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
- (dboard:commondat-curr-tab-num-set! commondat 0)
- (dboard:commondat-add-updater
- commondat
- (lambda ()
- (dashboard:runs-tab-updater commondat 1))
- tab-num: 1)
- ;; may not want this alive (manually merged it from v1.66)
- (dboard:commondat-add-updater
- commondat
- (lambda ()
- (dashboard:runs-tab-updater commondat 1))
- tab-num: 2)
- (iup:callback-set! *tim*
- "ACTION_CB"
- (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
- ) "update buttons once"))
- (th2 (make-thread iup:main-loop "Main loop")))
- (thread-start! th2)
- (thread-join! th2)))))
(define (get-debugcontrolf)
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (common:file-exists? debugcontrolf)
debugcontrolf
#f)))
+
+(define (dashboard-main)
+ (iup:show
+ (iup:dialog
+ (iup:vbox
+ (iup:button "Pushme"))))
+ (iup:main-loop))
(define (main)
(if (args:get-arg "-repl")
(repl)
(dashboard-main)))