Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -139,17 +139,20 @@ (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) +;; everything about a remote area including how to talk to its server +;; (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive (conndat #f) (transport *transport-type*) - (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds + (server-timeout (or (server:get-timeout) 100)) ;; default to 100 seconds + (area-path #f)) ;; launching and hosts (defstruct host (reachable #f) (last-update 0) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -122,18 +122,18 @@ (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 + ((curr-tab-num 0) : number) + (please-update #t) + (tabdats (make-hash-table)) + (update-mutex (make-mutex)) + (updaters (make-hash-table)) + (updating #f) uidat ;; needs to move to tabdat at some time - hide-not-hide-tabs + (hide-not-hide-tabs #f) ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -215,10 +215,13 @@ ((start-test-offset 0) : number) ;; up-down slider value ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x14")) : string) ;; was 12 ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 ((all-test-names '()) : list) + + ;; Runs summary information + ((area-name #f) : string) ;; Canvas and drawing data (cnv #f) (cnv-obj #f) (drawing #f) @@ -704,19 +707,20 @@ 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))) + (dboard:update-tree tabdat area-name 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)) + (area-name "curr") (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 (db:dispatch-query access-mode rmt:get-runs db: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)) @@ -789,11 +793,11 @@ 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))) + (dboard:update-tree tabdat area-name 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)) @@ -1325,11 +1329,11 @@ (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)) + (tree:add-node tb "Areas" target) ;; (append key-vals (list run-name)) (hash-table-set! runs-tree-ht target #t)))) all-targets))) ;; Run controls panel ;; @@ -1402,11 +1406,11 @@ ;; #:size "10x30" )) (tb (iup:treebox #:value 0 - #:name "Runs" + #:name "Areas" #:expand "YES" #:addexpanded "NO" #:size "10x" #:selection-cb (lambda (obj id state) @@ -1634,11 +1638,11 @@ (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) -(define (dboard:update-tree tabdat runs-hash runs-header tb) +(define (dboard:update-tree tabdat area-name 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)) @@ -1664,11 +1668,11 @@ (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)) + (tree:add-node tb "Areas" (cons area-name 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))) @@ -1727,32 +1731,33 @@ (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)) - + +;; Update the runs summary view with a single selected run using a tests<-->items matrix +;; (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 (db:dispatch-query (dboard:tabdat-access-mode tabdat) - rmt:get-runs-by-patt db: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)) + (let* ((area-name (dboard:tabdat-area-name 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 (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)) + (dboard:update-tree tabdat area-name 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)) @@ -2037,20 +2042,25 @@ ;; (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" + #:name "Areas" #:expand "YES" #:addexpanded "NO" #: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)))) + (path-len (length run-path)) + (area-name (if (> path-len 1)(cadr run-path) #f)) + (run-id (if (> path-len 2) + (tree-path->run-id tabdat (cddr run-path)) + #f))) + (dboard:tabdat-area-name-set! tabdat area-name) (if (number? run-id) (begin (dboard:tabdat-prev-run-id-set! tabdat (dboard:tabdat-curr-run-id tabdat)) @@ -2129,11 +2139,11 @@ (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 + (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)) @@ -2889,11 +2899,11 @@ ;; (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)) + (tree:add-node tb "Areas" 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)) @@ -3444,11 +3454,11 @@ (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; (if (and (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* ((commondat (make-dboard:commondat))) ;; 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) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -148,11 +148,11 @@ (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) ;; modify cell - but only if changed (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) + (tree:add-node (dboard:tabdat-tests-tree data) "Areas" (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (set! colnum (+ colnum 1)))) run-ids) ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table @@ -197,14 +197,14 @@ (test-path (append run-path (if (equal? itempath "") (list testname) (list testname itempath)))) (tb (dboard:tabdat-tests-tree data))) (print "INFONOTE: run-path: " run-path) - (tree:add-node (dboard:tabdat-tests-tree data) "Runs" + (tree:add-node (dboard:tabdat-tests-tree data) "Areas" test-path userdata: (conc "test-id: " test-id)) - (let ((node-num (tree:find-node tb (cons "Runs" test-path))) + (let ((node-num (tree:find-node tb (cons "Areas" test-path))) (color (car (gutils:get-color-for-state-status state status)))) (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) (set! changed (dcommon:modifiy-if-different tb Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -27,16 +27,21 @@ ;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== + +;; get the struct with all data on the remote area +;; +(define (rmt:get-remote area-dat) + (or area-dat *runremote*)) ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. - (let* ((runremote (or area-dat *runremote*)) + (let* ((runremote (rmt:get-remote area-dat)) (cinfo (remote-conndat runremote)) (run-id 0)) (if cinfo cinfo (if (server:check-if-running areapath)