@@ -16,10 +16,21 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== +(use format) + +(require-library iup) +(import (prefix iup iup:)) + +(use canvas-draw) +(import canvas-draw-iup) +(use ducttape-lib) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct +(import (prefix sqlite3 sqlite3:)) + (declare (uses common)) (declare (uses mtargs)) (declare (uses mtargs.import)) (declare (uses keys)) (declare (uses items)) @@ -29,110 +40,150 @@ (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) +(declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) +;; (declare (uses dashboard-main)) (declare (uses mt)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses commonmod.import)) -(use format) - -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) -(import canvas-draw-iup - (prefix sqlite3 sqlite3:)) - -(use ducttape-lib) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct - -(import commonmod - (prefix mtargs args:) - dbmod - dbfile - rmtmod - debugprint) - (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 commonmod (prefix mtargs args:) debugprint) +(import dbmod dbfile rmtmod) ;; set some parameters here - these need to be put in something that can be loaded from other ;; executables such as dashboard and mtutil ;; (include "dashboard-transport-mode.scm") (dbfile:db-init-proc db:initialize-main-db) (set! rmtmod:send-receive rmt:send-receive) (define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version - " license GPL, Copyright (C) Matt Welland 2012-2017 + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help - -test run-id test-id : open a test control panel on this test + -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 - -start-dir dir : start dashboard in the given directory - -target target : filter runs tab to given target. - -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 - -repl : Start a chicken scheme interpreter - -mode MODE : tcp or nfs -" -)) - +")) + +;; -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) - ;; parameters (need arguments) (list "-rows" "-cols" - "-test" ;; given a run id and test id, open only a test control panel on that test.. - "-debug" - "-start-dir" - "-target" - "-mode" ;; tcp or nfs - ) - ;; switches (don't take arguments) - (list "-h" + "-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)) -(if (args:get-arg "-mode") - (let* ((mode (string->symbol (args:get-arg "-mode")))) - (rmt:transport-mode mode))) +;; 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 (args:get-arg "-test") ;; need to use tcp for test control panel - (rmt:transport-mode 'tcp)) +(if (not (null? remargs)) + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit))) +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + +;; 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") +;; Not needed any more ;; (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)));;;) @@ -147,11 +198,10 @@ update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs - target ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -159,11 +209,10 @@ please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f - target: "" )) ;;====================================================================== ;; buttons color using image ;;====================================================================== @@ -231,24 +280,19 @@ tabdat)) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) - ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies - - ;; maybe need sleep here? - - (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) + ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey @@ -405,13 +449,13 @@ (define (dboard:setup-tabdat tabdat) (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) - ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) @@ -436,29 +480,27 @@ (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) -;; duplicated in dcommon.scm +;; used to keep the rundata from rmt:get-tests-for-run +;; in sync. ;; -;; ;; used to keep the rundata from rmt:get-tests-for-run -;; ;; in sync. -;; ;; -;; (defstruct dboard:rundat -;; run -;; tests-drawn ;; list of id's already drawn on screen -;; tests-notdrawn ;; list of id's NOT already drawn -;; rowsused ;; hash of lists covering what areas used - replace with quadtree -;; hierdat ;; put hierarchial sorted list here -;; tests ;; hash of id => testdat -;; ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat -;; key-vals -;; ((last-update 0) : number) ;; last query to db got records from before last-update -;; ((last-db-time 0) : number) ;; last timestamp on main.db -;; ((data-changed #f) : boolean) -;; ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items -;; (db-path #f)) +(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 @@ -696,12 +738,12 @@ (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (get-environment-variable "MT_RUN_AREA_HOME")) ;; (common:get-db-tmp-area)) - (db-pth (conc db-dir "/.mtdb/main.db"))) + (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 @@ -712,11 +754,11 @@ (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order - 'shortlist ;; qrytype (was #f) + #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) @@ -724,15 +766,15 @@ (dboard:rundat-tests-set! run-dat ht) ht) (dboard:rundat-tests run-dat))) (got-all (< (length tmptests) num-to-get)) ;; got all for this round ) - ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) + ;; if we saw the db modified, reset it (the signal has already been used) (if (and got-all ;; (not multi-get) db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + (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 @@ -843,11 +885,11 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) + (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))))))) @@ -1023,86 +1065,65 @@ (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) - +;; (define (get-itemized-tests test-dats) (let ((tnames '())) (for-each (lambda (tdat) (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) (if (and (list? tnames) (string? tname) (not (member tname tnames))) - (set! tnames (cons tname tnames)))))) + (set! tnames (append tnames (list tname))))))) test-dats) - (reverse tnames))) + tnames)) ;; Bubble up the top tests to above the items, collect the items underneath ;; all while preserving the sort order from the SQL query as best as possible. ;; (define (bubble-up tabdat test-dats #!key (priority 'itempath)) (if (null? test-dats) test-dats (begin (let* ((tnames '()) ;; list of names used to reserve order - (tests-ht (make-hash-table)) ;; hash of lists, used to build as we go + (tests (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) - #;(for-each + (for-each (lambda (testdat) (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests-th tname #f))) + ;; (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-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) + (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) ;; This is item, append it - (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) - test-dats) - ;; 1. put all test/items into lists in tests-ht - (for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests-ht tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) - test-dats) - ;; now bubble up the non-item test in itemized tests - (hash-table-for-each - tests-ht - (lambda (k v) - (if (> (length v) 1) ;; must be itemized, push the no-item to the front - (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) + (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-ht 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-ht hed)))) + (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 @@ -1109,11 +1130,11 @@ ;; - 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))) + (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)) @@ -1670,11 +1691,11 @@ ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" - ;; #:size "10x" + #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) @@ -1756,11 +1777,11 @@ #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () - ;; (print "tstate: " tstate) + (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 "") ) @@ -1995,11 +2016,11 @@ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(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)) @@ -2193,11 +2214,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) - (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) + (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 @@ -2315,11 +2336,11 @@ (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" + #: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 @@ -2782,12 +2803,11 @@ (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)) + (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)) @@ -2809,13 +2829,11 @@ (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 @@ -2971,14 +2989,14 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 250 + #:value 100 (dboard:runs-tree-browser commondat runs-dat) (iup:split - #:value 200 + #:value 100 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox #:expand "YES" @@ -3029,22 +3047,20 @@ (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 - (dashboard:summary commondat stats-dat tab-num: 1) ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) - additional-views)) - (target-run (dboard:commondat-target commondat)) - ) + additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Runs") - (iup:attribute-set! tabs "TABTITLE1" "Summary") + (iup:attribute-set! tabs "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 "TABTITLE3" "New View") @@ -3058,18 +3074,12 @@ (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup - ;; (dboard:common-set-tabdat! commondat 0 stats-dat) - - (if target-run - (begin - (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) - ) - ) - (dboard:common-set-tabdat! commondat 0 runs-dat) + (dboard:common-set-tabdat! commondat 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) @@ -3133,18 +3143,21 @@ (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 *toppath*) + (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)) @@ -3305,10 +3318,11 @@ (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)) @@ -3366,11 +3380,11 @@ (begin (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) #f))))) (if (and dbpth (file-read-access? dbpth)) (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) + (sqlite3:set-busy-handler! db (make-busy-timeout 10000)) db) #f))) ;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... ;; @@ -3534,11 +3548,11 @@ (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) - (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + (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))))) @@ -3695,11 +3709,11 @@ (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) - (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + (print "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)) @@ -3720,11 +3734,11 @@ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) - (debug:print 0 *default-log-port* "drawing runs taking too long") + (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 @@ -3760,11 +3774,11 @@ (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-done-runs-set! tabdat allruns)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (begin - (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") + (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) @@ -3817,45 +3831,17 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== -(stop-the-train) - (define (main) - ;; (print "Starting dashboard main") - - (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) - (target (args:get-arg "-target")) - (commondat (dboard:commondat-make))) - (if target - (begin - (args:remove-arg-from-ht "-target") - (dboard:commondat-target-set! commondat target) - ) - ) - - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") - (exit 1) - ) - ) - - #;(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) - (debug:print 0 *default-log-port* "It will be slower.") - )) - - + (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) - - (let* () + (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) @@ -3868,24 +3854,26 @@ (>= 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 0)) - tab-num: 0) + (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) + (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)) @@ -3899,102 +3887,23 @@ (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) - ;; (debug:print 0 *default-log-port* "Starting updaters") + (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) - ;; (print "Starting main loop") (thread-start! th2) - (thread-join! th2) - ) - ) - ) -) - -(define last-copy-time 0) - - -;; Sync to tmp only if in read-only mode. - -(define (sync-db-to-tmp tabdat) - (let* ((db-file "./.mtdb/main.db")) - (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) - (begin - (db:multi-db-sync (db:setup #f) 'old2new) - (set! last-copy-time (current-seconds)) - ) - ) - ) -) - -;; ########################### top level code ######################## -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (for-each (lambda (var) - ;; (display " ")(display var) - (if (get-environment-variable var) - (begin - (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - ) -) - -(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) - -(if (not (null? remargs)) - (if remargs - (begin - (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit) - ) - (begin - (print help) - (exit) - ) - ) -) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - - - - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - - + (thread-join! th2))))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) - (if (args:get-arg "-repl") (repl) (main))