Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -67,11 +67,11 @@ -test run-id test-id : open a test control panel on this test -skip-version-check : skip the version check -rows R : set number of rows -cols C : set number of columns -start-dir dir : start dashboard in the given directory - -target-run target[/run-name] : filter runs tab to given target/run-name. + -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 " )) @@ -83,11 +83,11 @@ (list "-rows" "-cols" "-test" ;; given a run id and test id, open only a test control panel on that test.. "-debug" "-start-dir" - "-target-run" + "-target" ) ;; switches (don't take arguments) (list "-h" "-skip-version-check" "-repl" @@ -94,76 +94,10 @@ "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) -;; ################### 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 - (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")) - ) -) - -(if (not (null? remargs)) - (if remargs - (begin - (print "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)))) - -;; TODO: Move this inside (main) -;; -(print "launch:setup") -(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 - (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: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost)) - (debug:print 0 *default-log-port* "It will be slower.") - )) - -;; ########################### end top level code ############################## - ;; 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")) @@ -186,10 +120,11 @@ 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 @@ -197,10 +132,11 @@ please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f + target: "" )) ;;====================================================================== ;; buttons color using image ;;====================================================================== @@ -436,14 +372,14 @@ (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 "%")) ) @@ -481,11 +417,11 @@ 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 + ((last-db-time 0) : number) ;; last timestamp on main.db ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later @@ -727,11 +663,11 @@ (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"))) + (db-pth (conc db-dir "/.megatest/main.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 @@ -2791,11 +2727,12 @@ (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)) @@ -2817,11 +2754,13 @@ (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 @@ -3042,11 +2981,11 @@ ;; (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 (args:get-arg "-target-run")) + (target-run (dboard:commondat-target commondat)) ) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Runs") (iup:attribute-set! tabs "TABTITLE1" "Summary") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") @@ -3067,11 +3006,13 @@ (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 - (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) ) (dboard:common-set-tabdat! commondat 0 runs-dat) ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) @@ -3312,11 +3253,10 @@ (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 "resetting 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)) @@ -3827,16 +3767,41 @@ ;; The heavy lifting starts here ;;====================================================================== (define (main) (print "Starting dashboard main") - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + + (let* ((mtdb-path (conc *toppath* "/.megatest/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 + (print "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:" (common:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) - (let* ((commondat (dboard:commondat-make))) + + (let* () ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1) @@ -3888,18 +3853,78 @@ (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))))) + (thread-join! th2) + ) + ) + ) + ) ;; ########################### 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 + (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")) + ) +) + +(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) + +(if (not (null? remargs)) + (if remargs + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) + (if (args:get-arg "-repl") (repl) (main)) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -468,27 +468,22 @@ ) (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) ) ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically tmpdb)) -;;====================================================================== -;; no-sync.db - small bits of data to be shared between servers -;;====================================================================== - -;; if we are not a server create a db handle. this is not finalized -;; so watch for problems. I'm still not clear if it is needed to manually -;; finalize sqlite3 dbs with the sqlite3 egg. -;; (define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50)) + (let* ((busy-file (conc fname"-journal")) (delay-time (* (- 51 tries-left) 1.1)) - (retry (lambda () + (write-access (file-write-access? fname)) + (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) + (if (and (file-write-access? fname) (file-exists? busy-file)) (begin (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.") (thread-sleep! 1) @@ -495,19 +490,26 @@ (if (eq? tries-left 2) (begin (dbfile:print-err "INFO: forcing journal rollup "busy-file) (dbfile:brute-force-salvage-db fname))) (dbfile:cautious-open-database fname init-proc (- tries-left 1))) + (let* ((result (condition-case - (dbfile:with-simple-file-lock - (conc fname ".lock") - (lambda () - (let* ((db-exists (file-exists? fname)) - (db (sqlite3:open-database fname))) - (if (and init-proc (not db-exists)) - (init-proc db)) - db))) + (if write-access + (dbfile:with-simple-file-lock + (conc fname ".lock") + (lambda () + (let* ((db-exists (file-exists? fname)) + (db (sqlite3:open-database fname))) + (if (and init-proc (not db-exists)) + (init-proc db)) + db))) + (if (file-exists? fname ) + (sqlite3:open-database fname) + #f + ) + ) (exn (io-error) (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") (retry)) (exn (corrupt) (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -33,10 +33,15 @@ (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) + +(define (args:remove-arg-from-ht arg) + (hash-table-delete! args:arg-hash arg) +) + (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help)