Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -204,11 +204,13 @@
((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
((done-runs '()) : list) ;; list of runs already drawn
((not-done-runs '()) : list) ;; list of runs not yet drawn
(header #f) ;; header for decoding the run records
(keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
+ ((numruns (string->number (or (args:get-arg "-cols")
+ (configf:lookup *configdat* "dashboard" "cols")
+ "8"))) : number) ;;
((tot-runs 0) : number)
((last-data-update 0) : number) ;; last time the data in allruns was updated
((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
(runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
@@ -222,11 +224,11 @@
(runs-matrix #f) ;; used in newdashboard
((start-run-offset 0) : number) ;; left-right slider value
((start-test-offset 0) : number) ;; up-down slider value
((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : 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
+ ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
((all-test-names '()) : list)
;; Canvas and drawing data
(cnv #f)
(cnv-obj #f)
@@ -1421,11 +1423,11 @@
(tb
(iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
- #:addexpanded "NO"
+ #:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
@@ -1516,11 +1518,11 @@
(iup:vbox
(iup:split
#:orientation "HORIZONTAL"
#:value 800
(let* ((cnv-obj (iup:canvas
- ;; #:size "500x400"
+ ;; #:size "250x250" ;; "500x400"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:action (make-canvas-action
@@ -1561,15 +1563,15 @@
(let* ((hb1 (iup:hbox))
(graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
(changed #f)
(graph-matrix (iup:matrix
#:alignment1 "ALEFT"
- #:expand "YES" ;; "HORIZONTAL"
+ ;; #:expand "YES" ;; "HORIZONTAL"
#:scrollbar "YES"
#:numcol 10
#:numlin 20
- #:numcol-visible (min 8)
+ #:numcol-visible 5 ;; (min 8)
#:numlin-visible 1
#:click-cb
(lambda (obj row col status)
(let*
((graph-cell (conc row ":" col))
@@ -1872,11 +1874,11 @@
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
(let* ((rawconfig (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 500
+ #:value 300
(iup:frame
#:title "General Info"
(iup:vbox
(iup:hbox
(iup:label "Area Path")
@@ -2055,11 +2057,11 @@
(let* ((update-mutex (dboard:commondat-update-mutex commondat))
(tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
- #:addexpanded "NO"
+ #:addexpanded "YES"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
;; (print "obj: " obj ", id: " id ", state: " state)
@@ -2166,10 +2168,28 @@
;;======================================================================
;; 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
@@ -2230,17 +2250,17 @@
(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-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"))
@@ -2270,54 +2290,80 @@
)))
- (iup:frame
- #:title "state/status filter"
- (iup:vbox
- (apply
- iup:hbox
- (map (lambda (status)
- (iup:toggle (conc status " ")
- #:fontsize 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")))
- (apply
- iup:hbox
- (map (lambda (state)
- (iup:toggle (conc state " ")
- #:fontsize 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")))
- (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)))
- ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
- ;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
- )))
+ (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))
+
(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info)
(iup:menu
(iup:menu-item
"Test Control Panel"
@@ -2640,20 +2686,23 @@
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
- #:value 150
+ #: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)))))
+ (apply iup:hbox (reverse bdylst))
+ (dashboard:runs-horizontal-slider runs-dat))))
controls
))
(views-cfgdat (common:load-views-config))
(additional-tabnames '())
(tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
@@ -2698,10 +2747,11 @@
runs-view
(dashboard:runs-summary commondat onerun-dat tab-num: 2)
;; (dashboard:new-view db data new-view-dat tab-num: 3)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
+ ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
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" "Run Summary")
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -491,11 +491,11 @@
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
(let* ((curr-row-num 1)
(key-vals (configf:section-vars rawconfig sectionname))
(section-matrix (iup:matrix
#:alignment1 "ALEFT"
- #:expand "YES" ;; "HORIZONTAL"
+ ;; #:expand "YES" ;; "HORIZONTAL"
#:numcol 1
#:numlin (length key-vals)
#:numcol-visible 1
#:numlin-visible (min 10 (length key-vals))
#:scrollbar "YES")))
@@ -1185,11 +1185,11 @@
(* scalef 0.01)
(* scalef -0.01))))
(if the-cnv
(dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
))
- ;; #:size "50x50"
+ ;; #:size "250x250"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -424,18 +424,21 @@
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
(define *didsomething* #t)
(exit 1))))
-
+;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
+;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
+;; where (launch:setup) returns #f?
+;;
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
(handle-exceptions
exn
(begin
(print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn))
)
- (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server
+ (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
(logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
(conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
(oup (open-logfile logf)))
(if (not (args:get-arg "-log"))
(hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log