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