@@ -18,30 +18,77 @@ ;; ;;====================================================================== (declare (unit dcommon)) -(declare (uses gutils)) (declare (uses dbmod)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses rmtmod)) (declare (uses testsmod)) - -(use format) -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) -(import canvas-draw-iup) -(use regex typed-records matchable) - -(import commonmod +(declare (uses mtargs)) +(declare (uses vgmod)) +(declare (uses ezstepsmod)) +(declare (uses rmtmod)) +(declare (uses subrunmod)) +(declare (uses megatestmod)) +(declare (uses runsmod)) +(declare (uses tasksmod)) +(declare (uses dbfile)) +(declare (uses servermod)) + +;; needed but dunno why +(use iup canvas-draw fmt) + +(module dcommon + * + +(import scheme + chicken + + ports + posix + extras + format + fmt + srfi-1 + srfi-4 + srfi-13 + srfi-14 + srfi-18 + srfi-69 + sparse-vectors + files + format + (prefix iup iup:) + canvas-draw + canvas-draw-iup + regex + data-structures + directory-utils + pathname-expand + typed-records + matchable + (prefix sqlite3 sqlite3:) + + (prefix mtargs args:) + commonmod configfmod rmtmod testsmod dbmod - debugprint) + debugprint + vgmod + ezstepsmod + rmtmod + subrunmod + megatestmod + runsmod + tasksmod + dbfile + servermod + ) (include "megatest-version.scm") (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") @@ -368,31 +415,31 @@ ;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) ;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) ;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) ;; (list run-changes all-test-changes))) -#;(define (dcommon:runsdat-get-col-num dat target runname force-set) +(define (dcommon:runsdat-get-col-num dat target runname force-set) (let* ((runs-index (dboard:runsdat-runs-index dat)) (col-name (conc target "/" runname)) (res (hash-table-ref/default runs-index col-name #f))) (if res res (if force-set - (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) + (let ((max-col-num (+ 1 (common:max (cons -1 (hash-table-values runs-index)))))) (hash-table-set! runs-index col-name max-col-num) max-col-num))))) -#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) - (let* ((tests-index (dboard:runsdat-runs-index dat)) - (row-name (conc testname "/" itempath)) - (res (hash-table-ref/default runs-index row-name #f))) - (if res - res - (if force-set - (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) - (hash-table-set! runs-index row-name max-row-num) - max-row-num))))) +;; (define (dcommon:runsdat-get-row-num dat testname itempath force-set) +;; (let* ((tests-index (dboard:runsdat-runs-index dat)) +;; (row-name (conc testname "/" itempath)) +;; (res (hash-table-ref/default runs-index row-name #f))) +;; (if res +;; res +;; (if force-set +;; (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) +;; (hash-table-set! runs-index row-name max-row-num) +;; max-row-num))))) (define (dcommon:rundat-copy-tests-to-by-name rundat) (let ((src-ht (dboard:rundat-tests rundat)) (trg-ht (dboard:rundat-tests-by-name rundat))) (if (and (hash-table? src-ht)(hash-table? trg-ht)) @@ -739,11 +786,11 @@ )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) (let ((servers (case (rmt:transport-mode) - ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) + ;; ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) (else '())))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) @@ -1484,5 +1531,5342 @@ (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))))) +;;====================================================================== +;; from dashboard +;;====================================================================== + +(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 : open a test control panel on this test + -skip-version-check : skip the version check + -rows R : set number of rows + -cols C : set number of columns + -start-dir dir : start dashboard in the given directory + -target target : filter runs tab to given target. + -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 + -repl : Start a chicken scheme interpreter + -mode MODE : tcp or nfs +" +)) + + +;; process args +(define remargs (args:get-args + (argv) + ;; parameters (need arguments) + (list "-rows" + "-cols" + "-test" ;; given a run id and test id, open only a test control panel on that test.. + "-debug" + "-start-dir" + "-target" + "-mode" ;; tcp or nfs + ) + ;; switches (don't take arguments) + (list "-h" + "-skip-version-check" + "-repl" + "-:p" ;; ignore the built in chicken profiling switch + ) + args:arg-hash + 0)) + +(if (args:get-arg "-mode") + (let* ((mode (string->symbol (args:get-arg "-mode")))) + (rmt:transport-mode mode))) +;; (rmt:transport-mode 'tcp)) + +;; (if (args:get-arg "-test") ;; need to use tcp for test control panel +;; (rmt:transport-mode 'tcp)) + +;; 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 +;; +;; Moved to dcommon.scm +;; +;; (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 +;; target +;; ) +;; +;; (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 +;; target: "" +;; )) + +;;====================================================================== +;; 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))) + + +;; gets and calls updater list based on curr-tab-num +;; +(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies + + ;; maybe need sleep here? + + (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)))) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) + +;; data for each specific tab goes here +;; +(defstruct dboard:tabdat + ;; runs + ((allruns '()) : list) ;; list of dboard:rundat records + ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records + ((done-runs '()) : list) ;; list of runs already drawn + ((not-done-runs '()) : list) ;; list of runs not yet drawn + (header #f) ;; header for decoding the run records + (keys #f) ;; keys for this run (i.e. target components) + ((numruns (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) : number) ;; + ((tot-runs 0) : number) + ((last-data-update 0) : number) ;; last time the data in allruns was updated + ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree + (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects + ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files + + ;; Runs view + ((buttondat (make-hash-table)) : hash-table) ;; + ((item-test-names '()) : list) ;; list of itemized tests + ((run-keys (make-hash-table)) : hash-table) + (runs-matrix #f) ;; used in newdashboard + ((start-run-offset 0) : number) ;; left-right slider value + ((start-test-offset 0) : number) ;; up-down slider value + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 + ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50 + ((all-test-names '()) : list) + + ;; Canvas and drawing data + (cnv #f) + (cnv-obj #f) + (drawing #f) + ((run-start-row 0) : number) + ((max-row 0) : number) + ((running-layout #f) : boolean) + (originx #f) + (originy #f) + ((layout-update-ok #t) : boolean) + ((compact-layout #t) : boolean) + + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + + ;; Controls used to launch runs etc. + ((command "") : string) ;; for run control this is the command being built up + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns + (key-listboxes #f) + (key-lbs #f) + run-name ;; from run name setting widget + states ;; states for -state s1,s2 ... + statuses ;; statuses for -status s1,s2 ... + + ;; Selector variables + curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab + ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters + ((hide-empty-runs #f) : boolean) + ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs + (hide-not-hide-button #f) + ((searchpatts (make-hash-table)) : hash-table) ;; + ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control + ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f + (target #f) + (test-patts #f) + + ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not + (dbdir #f) + (dbfpath #f) + (dbkeys #f) + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp + (monitor-db-path #f) ;; where to find monitor.db + ro ;; is the database read-only? + + ;; tests data + ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) + + ;; runs tree + ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id + (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) + + ;; tab data + ((view-changed #t) : boolean) + ((xadj 0) : number) ;; x slider number (if using canvas) + ((yadj 0) : number) ;; y slider number (if using canvas) + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + + tests-tree ;; used in newdashboard + ) + +;; 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-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +(define (dboard:tabdat-make-data) + (let ((dat (make-dboard:tabdat))) + (dboard:setup-tabdat dat) + (dboard:setup-num-rows dat) + dat)) + +(define (dboard:setup-tabdat tabdat) + (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* "")) + (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + + + ;; HACK ALERT: this is a hack, please fix. + (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) + (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) + (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) + ) + +;; 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))) + +;; duplicated in dcommon.scm +;; +;; ;; 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 main.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)) ;; referenced but not set anywhere in new run viewer, maybe get rid of this whole attempt? + + ;; 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 (make-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"))) + + +(define *exit-started* #f) + +;; sorting global data (would apply to many testsuites so leave it global for now) +;; +(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (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 (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(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") + "1000"))) + (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 #f) ;; (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 (get-environment-variable "MT_RUN_AREA_HOME")) ;; (common:get-db-tmp-area)) + (db-pth (conc db-dir "/.mtdb/*.db"))) + (dboard:rundat-db-path-set! run-dat db-pth) ;; this is just a cache of the path + 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 + 'shortlist ;; qrytype (was #f) + 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 + ) + ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) + ;; 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)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (loop run tal new-res newmaxtests) ;; not done getting data for this run + (loop (car tal)(cdr tal) new-res newmaxtests))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) + + +(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds + +(define (dboard:clear-run-id-update-hash) + (hash-table-clear! *dashboard-last-run-id-update*)) + +;; 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) + (cont-run #f)) + (let* ((run-id (db:get-value-by-header run header "id")) + (recently-done (< (- (current-seconds) + (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) + (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 (let* ((tht (if (and recently-done run-struct) + (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) + (or rht + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))) + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))) + (assert (hash-table? tht) "FATAL: But here tht should be a hash-table") + tht)) + ;; 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? + (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 2 *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 2 *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) + (begin + (thread-sleep! 0.2) ;; let the gui re-draw + (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run + (begin + (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds)) + (loop (car tal)(cdr tal) new-res newmaxtests #f))))))) + (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 (cons tname tnames)))))) + test-dats) + (reverse 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-ht (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-th 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-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) + ;; This is item, append it + (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) + test-dats) + ;; 1. put all test/items into lists in tests-ht + (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-ht 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))))) + (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) + test-dats) + ;; now bubble up the non-item test in itemized tests + (hash-table-for-each + tests-ht + (lambda (k v) + (if (> (length v) 1) ;; must be itemized, push the no-item to the front + (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) + ;; 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-ht 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-ht 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 (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 ;;run + (lambda (rundat) + (if (or (not rundat) ;; handle padded runs + (not (dboard:rundat-run rundat))) + ;; Need to put an empty column in to erase previous contents. + (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))) + (teststatus (db:test-get-status testdat)) + (teststate (db:test-get-state testdat)) + (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)) + (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)))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (let ((run-input (dboard:tabdat-run-name tabdat)) + ) + (if (equal? run-input "") + "no-runname-specified" + run-input))) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +;;====================================================================== +;; 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)) + (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 (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-read-access? 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)) + (debug:print 0 *default-log-port* "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" + #: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 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 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 ()57 + (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) + (dboard:clear-run-id-update-hash) + (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 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 250 + (dboard:runs-tree-browser commondat runs-dat) + (iup:split + #:value 200 + ;; 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 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW + ;; (data (dboard:tabdat-init (make-d:data))) + (additional-views ;; process views-dat + (let ((tab-num tab-start-num) + (result '())) + (for-each + (lambda (view-name) + (debug:print 0 *default-log-port* "Adding view " view-name) + (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? + (if (not (string? cfgtype)) + (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name + "\" is missing needed sections. " + "Please consult the documenation and update ~/.mtviews.config or " + *toppath* "/.mtviews.config") + (case (string->symbol cfgtype) + ;; user supplied source for a tab + ;; + ((external) ;; 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 (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")) + runs-view + (dashboard:summary commondat stats-dat tab-num: 1) + ;; (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) + additional-views)) + (target-run (dboard:commondat-target commondat)) + ) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Runs") + (iup:attribute-set! tabs "TABTITLE1" "Summary") + ;; (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 "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) + + (if target-run + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) + ) + (dboard:common-set-tabdat! commondat 0 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 *tim* (iup:timer)) +(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))))) + +;; (define *monitor-db-path* #f) +(define *last-monitor-update-time* 0) + +;; Force creation of the db in case it isn't already there. +;; (tasks:open-db) + +(define (dashboard:get-youngest-run-db-mod-time 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)) + (cons (conc dbdir "/main.db") (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)) + +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (conc *toppath* "/.mtdb")) + (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)))) + (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))) + (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-read-access? 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 (handle-exceptions + exn + #f + (sqlite3:first-row db all-dat-qrystr)))) + (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. + (hash-table-set! res-ht + fieldname + (cons + (apply vector tstart (cdr zeropt)) + (hash-table-ref/default res-ht fieldname '()))))))) + fields) + res-ht) + #f))))) + +;; graph data +;; tsc=timescale, tfn=function; time->x +;; +(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) + (let* ((dwg (dboard:tabdat-drawing tabdat)) + (lib (vg:get/create-lib dwg "runslib")) + (cnv (dboard:tabdat-cnv tabdat)) + (dur (- tstart tend)) ;; time duration + (cmp (vg:get-component dwg "runslib" compname)) + (cfg (configf:get-section *configdat* "graph")) + (stdcolor (vg:rgb->number 120 130 140)) + (delta-y (- uly lly)) + (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))) + (debug:print 0 *default-log-port* "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)) + (debug:print 0 *default-log-port* "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) + (debug:print 0 *default-log-port* "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 + (debug:print 0 *default-log-port* "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")))) + +;; 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) + (dboard:update-rundat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; 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)))) + +(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 +;;====================================================================== + +(stop-the-train) + +(define (dcommon-main) +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.mtdb/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (debug:print 0 *default-log-port* "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")) + ) +) + +;; This is NOT good +;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) +;; This should be OK but it really should not be necessary +(setenv "MT_RUN_AREA_HOME" (current-directory)) + +(if (not (null? remargs)) + (if remargs + (begin + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(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)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + + +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) + (if (common:file-exists? debugcontrolf) + (load debugcontrolf))) +) + +;;====================================================================== +;; C O M M O N +;;====================================================================== + +(define *dashboard-comment-share-slot* #f) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + + +(define (test-info-panel testdat store-label widgets) + (iup:frame + #:title "Test Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: " + "Test id: " + "Test date: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-label "testname" + (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-testname testdat))) + (store-label "item-path" + (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-item-path testdat))) + (store-label "teststate" + (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-state testdat))) + (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) + (hash-table-set! widgets "teststatus" + (lambda (testdat) + (let ((newstatus (db:test-get-status testdat)) + (oldstatus (iup:attribute lbl "TITLE"))) + (if (not (equal? oldstatus newstatus)) + (begin + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) + (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) + lbl) + (store-label "testcomment" + (iup:label "TestComment " + #:expand "HORIZONTAL") + (lambda (testdat) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-share-slot* + "VALUE" + newcomment))) + newcomment))) + (store-label "testid" + (iup:label "TestId " + #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) + ))))) + +;;====================================================================== +;; Test meta panel +;;====================================================================== + +(define (test-meta-panel-get-description testmeta) + (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) + +(define (test-meta-panel testmeta store-meta) + (iup:frame + #:title "Test Meta Data" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Author: " + "Owner: " + "Reviewed: " + "Tags: " + "Description: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-meta "author" + (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-author testmeta))) + (store-meta "owner" + (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-owner testmeta))) + (store-meta "reviewed" + (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) + (store-meta "tags" + (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-tags testmeta))) + (store-meta "description" + (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") + (lambda (testmeta) + (test-meta-panel-get-description testmeta))) + ))))) + + +;;====================================================================== +;; Run info panel +;;====================================================================== +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (rmt:get-run-info run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) + +;;====================================================================== +;; Host info panel +;;====================================================================== +(define (host-info-panel testdat store-label) + (iup:frame + #:title "Remote host and Test Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" ;; The heading labels + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Hostname: " + "Disk free: " + "CPU Load: " + "Run duration: " + "Logfile: " + "Top process id: " + "Uname -a: ")) + (iup:label "" #:expand "VERTICAL"))) + (apply iup:vbox ; #:expand "YES" + (list + ;; NOTE: Yes, the host can change! + (store-label "HostName" + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-host testdat))) + (store-label "DiskFree" + (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-diskfree testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-cpuload testdat)))) + (store-label "RunDuration" + (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") + (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) + (store-label "LogFile" + (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (store-label "ProcessId" + (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) + ))))) + +;; if there is a submegatest create a button to launch dashboard in that area +;; +(define (submegatest-panel dbstruct keydat testdat runname testconfig) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) + (if subarea + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir)))) + (iup:vbox)))) + +;; use a global for setting the buttons colors +;; state status teststeps +(define *state-status* (vector #f #f #f)) +(define (update-state-status-buttons testdat) + (let* ((state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (color (car (gutils:get-color-for-state-status state status)))) + ((vector-ref *state-status* 0) state color) + ((vector-ref *state-status* 1) status color))) + +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + +;;====================================================================== +;; Set fields +;;====================================================================== +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) + (let ((newcomment #f) + (newstatus #f) + (newstate #f) + (wtxtbox #f)) + (iup:frame + #:title "Set fields" + (iup:vbox + (iup:hbox (iup:label "Comment:") + (let ((txtbox (iup:textbox #:action (lambda (val a b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + + (apply iup:hbox + (iup:label "STATE:" #:size "30x") + (let* ((btns (map (lambda (state) + (let ((btn (iup:button state + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + (db:test-set-state! testdat state))))) + btn)) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) + (vector-set! *state-status* 0 + (lambda (state color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name state) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)) + (apply iup:hbox + (iup:label "STATUS:" #:size "30x") + (let* ((btns (map (lambda (status) + (let ((btn (iup:button status + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver run-id testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + (db:test-set-status! testdat status)))))))) + btn)) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (vector-set! *state-status* 1 + (lambda (status color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name status) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)))))) + +(define (dashboard-tests:run-a-step info) + #t) + +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) + +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) + + +;;====================================================================== +;; +;;====================================================================== +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT USED + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) + (db-mod-time 0) ;; (file-modification-time db-path)) + (last-update 0) ;; (current-seconds)) + (request-update #t)) + (if (not testdat) + (begin + (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (test-registry (tests:get-all)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "runname") #f)) + ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. + (logfile "/this/dir/better/not/exist") + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-get-testname testdat) "n/a")) + ;; (tests:get-testconfig testdat testname 'return-procs)) + (testmeta (if testdat + (let ((tm (rmt:testmeta-get-record testname))) + (if tm tm (make-db:testmeta))) + (make-db:testmeta))) + + (keystring (string-intersperse + (map (lambda (keyval) + ;; (conc ":" (car keyval) " " (cadr keyval))) + (cadr keyval)) + keydat) + "/")) + (item-path (db:test-get-item-path testdat)) + ;; this next block was added to fix a bug where variables were + ;; needed. Revisit this. + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) + #f) ;; do nothing, just keep on trucking .... + (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) + (make-hash-table)))) + (testconfig (begin + ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) + (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (handle-exceptions + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (begin + (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) + (viewlog (lambda (x) + (if (common:file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer logfile) + (message-window (conc "File " logfile " not found"))))) + (view-a-log (lambda (lfile) + (let ((lfilename (conc rundir "/" lfile))) + ;; (print "lfilename: " lfilename) + (if (common:file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer lfilename) + (message-window (conc "File " lfilename " not found")))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (common:without-vars + (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") + "MT_.*")) + (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) + (refreshdat (lambda () + (let* ((curr-mod-time (file-modification-time db-path)) + ;; (max ..... (if (common:file-exists? testdat-path) + ;; (file-modification-time testdat-path) + ;; (begin + ;; (set! testdat-path (conc rundir "/testdat.db")) + ;; 0)))) + (need-update (or (and (>= curr-mod-time db-mod-time) + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds + request-update)) + (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id + ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + #f) + (rmt:get-test-info-by-id run-id test-id))))) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) + (cond + ((and need-update newtestdat) + (set! testdat newtestdat) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) + (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! rundir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (set! testfullname (db:test-get-fullname testdat)) + ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... + ) + (need-update ;; if this was true and yet there is no data .... + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) + (meta-widgets (make-hash-table)) + (self #f) + (store-label (lambda (name lbl cmd) + (hash-table-set! widgets name + (lambda (testdat) + (let ((newval (cmd testdat)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-meta (lambda (name lbl cmd) + (hash-table-set! meta-widgets name + (lambda (testmeta) + (let ((newval (cmd testmeta)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-button store-label) + (command-proc (lambda (command-text-box) + (let* ((cmd (iup:attribute command-text-box "VALUE"))) + (common:run-a-command cmd with-orig-env: #t)))) + (command-text-box (iup:textbox + #:expand "HORIZONTAL" + #:font "Courier New, -10" + #:action (lambda (obj cnum val) + ;; (print "cnum=" cnum) + (if (eq? cnum 13) + (command-proc obj))) + )) + (command-launch-button (iup:button "Execute!" #:action (lambda (x) + (command-proc command-text-box)))) + ;; (lambda (x) + ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) + ;; (fullcmd (conc (dtests:get-pre-command) + ;; cmd + ;; (dtests:get-post-command)))) + ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + ;; (common:without-vars fullcmd "MT_.*"))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -run -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + )))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";megatest -target " keystring " -runname " runname + " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + ))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (archive-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ))))) + (cond + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + (else + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self ; + (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title testfullname + (iup:vbox ; #:expand "YES" + ;; The run and test info + (iup:hbox ; #:expand "YES" + (run-info-panel dbstruct keydat testdat runname) + (test-info-panel testdat store-label widgets) + (test-meta-panel testmeta store-meta)) + (iup:hbox + (host-info-panel testdat store-label) + (submegatest-panel dbstruct keydat testdat runname testconfig)) + ;; The controls + (iup:frame #:title "Actions" + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Archive Test" #:action archive-test #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (apply + iup:hbox + (list command-text-box command-launch-button)))) + (set-fields-panel dbstruct run-id test-id testdat) + (let ((tabs + (iup:tabs + ;; Replace here with matrix + (let ((steps-matrix (iup:matrix + #:font "Courier New, -8" + #:expand "YES" + #:scrollbar "YES" + #:numcol 9 + #:numlin 100 + #:numcol-visible 9 + #:numlin-visible 5 + #:click-cb (lambda (obj lin col status) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) + ;; (let loop ((count 0)) + ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) + ;; (if (< count 30) + ;; (loop (+ count 1)))) + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "50") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + (let ((proc + (lambda (testdat) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) + (hash-table-set! widgets "StepsMatrix" proc) + (proc testdat)) + steps-matrix) + ;; populate the Test Data panel + (iup:frame + #:title "Test Data" + (let ((test-data + (iup:textbox ;; #:action (lambda (obj char val) + ;; #f) + #:expand "YES" + #:multiline "YES" + #:font "Courier New, -10" + #:size "100x100"))) + (hash-table-set! widgets "Test Data" + (lambda (testdat) ;; + (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment + (newval (string-intersperse + (append + (list + (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") + (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) + (map (lambda (x) + (format #f fmtstr + (db:test-data-get-category x) + (db:test-data-get-variable x) + (db:test-data-get-value x) + (db:test-data-get-expected x) + (db:test-data-get-tol x) + (db:test-data-get-status x) + (db:test-data-get-units x) + (db:test-data-get-type x) + (db:test-data-get-comment x))) + (rmt:read-test-data run-id test-id "%"))) + "\n"))) + (if (not (equal? currval newval)) + (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) + test-data)) + ;;(dashboard:run-controls) + ))) + (iup:attribute-set! tabs "TABTITLE0" "Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs)))) + (iup:show self) + (iup:callback-set! *tim* "ACTION_CB" + (lambda (x) + ;; Now start keeping the gui updated from the db + (refreshdat) ;; update from the db here + ;(thread-suspend! other-thread) + (if *exit-started* + (set! *exit-started* 'ok)))))))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) + +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) + +(define (main) + ;; (print "Starting dashboard main") + + (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) + (target (args:get-arg "-target")) + (commondat (dboard:commondat-make))) + (if target + (begin + (args:remove-arg-from-ht "-target") + (dboard:commondat-target-set! commondat target) + ) + ) + + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") + (exit 1) + ) + ) + + #;(if (not (rmt:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + + (if (and (common:file-exists? mtdb-path) + (file-write-access? mtdb-path)) + (if (not (args:get-arg "-skip-version-check")) + (common:exit-on-version-changed))) + + (let* () + ;; 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))))) + (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 0)) + tab-num: 0) + ;; 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)))) + ;; (debug:print 0 *default-log-port* "Starting updaters") + (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"))) + ;; (print "Starting main loop") + (thread-start! th2) + (thread-join! th2) + ) + ) + ) +) + +;;====================================================================== +;; T R E E S T U F F +;;====================================================================== + +;; path is a list of nodes, each the child of the previous +;; this routine returns the id so another node can be added +;; either as a leaf or as a branch +;; +;; BUG: This needs a stop sensor for when a branch is exhausted +;; +(define (tree:find-node obj path) + ;; start at the base of the tree + (if (null? path) + #f ;; or 0 ???? + (let loop ((hed (car path)) + (tal (cdr path)) + (depth 0) + (nodenum 0)) + ;; nodes in iup tree are 100% sequential so iterate over nodenum + (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes + (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum)))) + (node-title (iup:attribute obj (conc "TITLE" nodenum)))) + (if (and (equal? depth node-depth) + (equal? hed node-title)) ;; yep, this is the one! + (if (null? tal) ;; end of the line + nodenum + (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum))) + ;; this is the case where we found part of the hierarchy but not + ;; all of it, i.e. the node-depth went from deep to less deep + (if (> depth node-depth) ;; (+ 1 node-depth)) + #f + (loop hed tal depth (+ nodenum 1))))) + #f)))) + +;; top is the top node name zeroeth node VALUE=0 +(define (tree:add-node obj top nodelst #!key (userdata #f)) + (let ((curr-top (iup:attribute obj "TITLE0"))) + (if (or (not (string? curr-top)) + (string-null? curr-top) + (string-match "^\\s*$" curr-top)) + (iup:attribute-set! obj "ADDBRANCH0" top)) + + + + (cond + ((not (equal? top (iup:attribute obj "TITLE0"))) + (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + ((null? nodelst)) + (else + (let loop ((hed (car nodelst)) + (tal (cdr nodelst)) + (depth 1) + (pathl (list top))) + ;; Because the tree dialog changes node numbers when + ;; nodes are added or removed we must look up nodes + ;; each and every time. 0 is the top node so default + ;; to that. + (let* ((newpath (append pathl (list hed))) + (parentnode (tree:find-node obj pathl)) + (nodenum (tree:find-node obj newpath))) + ;; Add the branch under lastnode if not found + (if (not nodenum) + (begin + (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) + ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? + (if userdata + (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) + (if (null? tal) + #t + ;; reset to top + (loop (car nodelst)(cdr nodelst) 1 (list top)))) + (if (null? tal) ;; if null here then this path has already been added + #t + (loop (car tal)(cdr tal)(+ depth 1) newpath))))))))) + +(define (tree:node->path obj nodenum) + (let loop ((currnode 0) + (path '())) + (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode)))) + (node-title (iup:attribute obj (conc "TITLE" currnode))) + (trimpath (if (and (not (null? path)) + (> (length path) node-depth)) + (take path node-depth) + path)) + (newpath (append trimpath (list node-title)))) + (if (>= currnode nodenum) + newpath + (loop (+ currnode 1) + newpath))))) + +(define (tree:delete-node obj top node-path) ;; node-path is a list of strings + (let ((id (tree:find-node obj (cons top node-path)))) + (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) + (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) + +#| + + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-curr-run-id-set! data run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) +|# + +;;====================================================================== +;; gutils +;; +;; NOTE: These functions will move to iuputils +;;====================================================================== + +(define (gutils:colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define gutils:colors + '((PASS . "70 249 73") + (FAIL . "253 33 49") + (SKIP . "230 230 0"))) + +(define (gutils:get-color-spec effective-state) + (or (alist-ref effective-state gutils:colors) + (alist-ref 'FAIL gutils:colors))) + +;; BBnote - state status dashboard button color / text defined here +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + ((ABORT) (list "198 36 166" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING STARTED) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (case (string->symbol status) + ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) + (else (list "240 240 240" state)))) + ;; for xor mode below + ;; + ((CLEAN) + (case (string->symbol status) + ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these + (else (list "60 235 63" status)))) + ((DIRTY-BETTER) (list "160 255 153" status)) + ((DIRTY-WORSE) (list "165 42 42" status)) + ((BOTH-BAD) (list "180 33 49" status)) + + (else (list + ;; "192 192 192" + "222 222 221" + state)))) + +;;====================================================================== +;; implementation of context menu that pops up on +;; right click on test cell in Runs & Runs Summary Tabs +;;====================================================================== + +(define (dboard:launch-testpanel run-id test-id) + (let* ((dboardexe (common:find-local-megatest "dashboard")) + (cmd (conc dboardexe + " -test " run-id "," test-id + " &"))) + (system cmd))) + + +(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + +(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))))) + +(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps))))) + +(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (dboard:launch-testpanel run-id test-id))) + + (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + )) +;; example section for megatest.config: +;; +;; +;; [custom-context-menu-items] +;; # : +;; item1 custom show run-id (%run-id%):echo "%run-id%" +;; item2 custom show test-id (%test-id%):echo "%test-id%" +;; item3 custom show target (%target%):echo "%target%" +;; item4 custom show test-name (%test-name%):echo "%test-name%" +;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" +;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" +;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" +;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" +;; item9 custom ls : ls -lrt +;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME + +(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) + (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) + (item-path (db:test-get-item-path test-info)) + (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) + (filter-map + (lambda (var) + (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) + (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) + (if m + (let* ((menu-item-text-raw (list-ref m 1)) + (command-line-raw (list-ref m 2)) + (subst-alist ;; template vars + `(( "%run-id%" . ,run-id ) + ( "%test-id%" . ,test-id ) + ( "%target%" . ,target ) + ( "%test-name%" . ,test-name) + ( "%test-patt%" . ,testpatt) + ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) + ( "%mt-root%" . ,mt-root) + ( "%run-name%" . ,run-name) + ( "%run-area-home%" . ,*toppath*) + ( "%item-path%" . ,item-path) + ( "%item-test-patt%" . ,item-test-path ))) + (command-line ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + command-line-raw + subst-alist)) + (menu-item-text ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + menu-item-text-raw + subst-alist))) + (iup:menu-item + (conc "*"menu-item-text) + #:action + (lambda (obj) + + (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) + ;;(BB> "cmdline is >"command-line"<") + (common:with-env-vars + ;; TODO: with-env-vars + ;; TODO: with-env-vars MT_* + (runs:get-mt-env-alist run-id run-name target test-name item-path) + + (lambda () + (if scheme-match + (begin + (handle-exceptions + exn + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) + (begin + ;;(BB> "gonna eval it!") + (eval (with-input-from-string (cadr scheme-match) read))))) + (common:run-a-command command-line with-vars: #t)))))))) + #f))) + vars))) + +(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((run-menu-items + (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (test-menu-items + (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (custom-menu-items + (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (toplevel-menu-items + (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + ) + (apply iup:menu + `(,@toplevel-menu-items + ,(iup:menu-item + "Run" + (apply iup:menu run-menu-items)) + ,(iup:menu-item + "Test" + (apply iup:menu test-menu-items)) + ,@custom-menu-items)))) + + +)