@@ -55,10 +55,11 @@ (declare (uses stml2.import)) (declare (uses ducttape-lib.import)) (declare (uses mtconfigf.import)) (declare (uses gutilsmod)) +(declare (uses servermod)) (declare (uses megamod)) (declare (uses commonmod)) (declare (uses rmtmod)) (declare (uses runsmod)) (declare (uses dbmod)) @@ -65,10 +66,11 @@ (declare (uses testsmod)) (declare (uses dcommonmod)) (import gutilsmod) +(import servermod) (import megamod) (import commonmod) (import rmtmod) (import runsmod) (import dbmod) @@ -1418,10 +1420,102 @@ (for-each (lambda (graph-cell) (let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell))) (dboard:graph-dat-flag-set! graph-dat #f))) (hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))) )))) + +;;====================================================================== +;; SYSTEM MONITOR - Track relevant Megatest processes +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:sysmon commondat tabdat #!key (tab-num #f)) + (let* ((drawing (vg:drawing-new)) + (sysmon-tab-updater (lambda () + (debug:catch-and-dump + (lambda () + (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (if tabdat + (let ((last-data-update (dboard:tabdat-last-data-update tabdat)) + (now-time (current-seconds))) + (dashboard:sysmon-canvas-updater commondat tabdat tab-num) ;; redraws canvas on user input (I think...) + )))) + "dashboard:sysmon-tab-updater"))) + (key-listboxes #f) ;; + (update-keyvals (lambda () + (dboard:target-updater tabdat)))) + (dboard:tabdat-drawing-set! tabdat drawing) + (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 150 + (iup:vbox + (iup:split + #:orientation "HORIZONTAL" + #:value 800 + (let* ((cnv-obj (iup:canvas + ;; #:size "250x250" ;; "500x400" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:action (make-canvas-action + (lambda (c xadj yadj) + (debug:catch-and-dump + (lambda () + (if (not (dboard:tabdat-cnv tabdat)) + (let ((cnv (dboard:tabdat-cnv tabdat))) + (dboard:tabdat-cnv-set! tabdat c) + (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat) + (dboard:tabdat-cnv tabdat)))) + (let ((drawing (dboard:tabdat-drawing tabdat)) + (old-xadj (dboard:tabdat-xadj tabdat)) + (old-yadj (dboard:tabdat-yadj tabdat))) + (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) + (begin + ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5))) + (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5))) + )))) + "iup:canvas action"))) + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (debug:catch-and-dump + (lambda () + (let* ((drawing (dboard:tabdat-drawing tabdat)) + (scalex (vg:drawing-scalex drawing))) + (dboard:tabdat-view-changed-set! tabdat #t) + ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) + (vg:drawing-scalex-set! drawing + (+ scalex + (if (> step 0) + (* scalex 0.02) + (* scalex -0.02)))))) + "wheel-cb")) + ))) + cnv-obj) + ))))) + +;; run times canvas updater +;; +(define (dashboard:sysmon-canvas-updater commondat tabdat tab-num) + (let ((cnv (dboard:tabdat-cnv tabdat)) + (dwg (dboard:tabdat-drawing tabdat)) + (mtx (dboard:tabdat-runs-mutex tabdat)) + (vch (dboard:tabdat-view-changed tabdat))) + (if (and cnv dwg vch) + (begin + (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) + (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) + (mutex-lock! mtx) + (canvas-clear! cnv) + (vg:draw dwg tabdat) + (mutex-unlock! mtx) + (dboard:tabdat-view-changed-set! tabdat #f))))) + + ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -2190,10 +2284,11 @@ (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (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)) + (sysmon-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) (runsvec (make-vector nruns)) @@ -2408,18 +2503,20 @@ (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) + (dashboard:sysmon commondat sysmon-dat tab-num: 5) 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") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") + (iup:attribute-set! tabs "TABTITLE5" "Sysmon") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each @@ -2434,10 +2531,11 @@ (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-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) + (dboard:common-set-tabdat! commondat 5 sysmon-dat) (iup:vbox tabs ;; controls ))))