Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -753,16 +753,16 @@ (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) - + (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 ;; @@ -903,11 +903,11 @@ (res '()) (maxtests 0) (cont-run #f)) (let* ((run-id (db:get-value-by-header run header "id")) (recently-done (< (- (current-seconds) - (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 3)) + (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (rmt:get-key-vals run-id)) (tests-ht (let* ((tht (if (and recently-done run-struct) (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) @@ -943,11 +943,11 @@ (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 @@ -1182,15 +1182,15 @@ (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 + (for-each ;;run (lambda (rundat) - ;; if rundat is junk clobber it with a decent placeholder (if (or (not rundat) ;; handle padded runs (not (dboard:rundat-run rundat))) + ;; Need to put an empty column in to erase previous contents. (set! rundat (dboard:rundat-make-init key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) (let* ((run (dboard:rundat-run rundat)) (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) @@ -1197,23 +1197,22 @@ (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) + (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 + ;; For this run now fill in the buttons for each test ;; (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) @@ -1226,17 +1225,12 @@ ;; 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) @@ -3168,11 +3162,11 @@ (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) ;; (define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) - (dbdir (conc *toppath* "/.mtdb"`)) + (dbdir (conc *toppath* "/.mtdb")) (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:get-last-db-update tabdat context-key)))) (if recalc Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -899,13 +899,13 @@ ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) (define (rmt:print-db-stats) - (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" + (let ((fmtstr "~40a~8-d~20-d~20,2-f")) ;; "~20,2-f" (debug:print 0 *default-log-port* "DB Stats\n========") - (debug:print 0 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (debug:print 0 *default-log-port* (format #f "~40a~8a~20a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let* ((dat (hash-table-ref *db-stats* cmd)) (count (dbstat-cnt dat)) (tottime (dbstat-tottime dat))) (debug:print 0 *default-log-port* Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -972,11 +972,11 @@ (tl (launch:setup)) (keys (keys:config-get-fields *configdat*))) (case (rmt:transport-mode) ((tcp) (let* ((timeout (server:expiration-timeout))) - (debug:print 0 *default-log-port* "INFO: Starting server for " dbfname " using tcp method with server timeout of "timeout) + (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout) (tt-server-timeout-param timeout) (thread-start! (make-thread api:print-db-stats "print-db-stats")) (if dbfname (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys) (begin