Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -41,17 +41,18 @@ # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm -DMSRCFILES = dcommonmod.scm +DMSRCFILES = dcommonmod.scm vgmod.scm DMOFILES = $(addprefix mofiles/,$(DMSRCFILES:%.scm=%.o)) DMOIMPFILES = $(DMSRCFILES:%.scm=%.import.o) -GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ - dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ - vg.scm +GUISRCF = + +# vg.scm tree.scm dashboard-context-menu.scm dashboard-tests.scm \ +# dashboard-guimonitor.scm gutils.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) %.import.o : %.import.scm mofiles/%.o @@ -177,19 +178,22 @@ dcommon.o : run_records.scm mofiles/stml2.o : mofiles/cookie.o -# for the modularized stuff -# mofiles/rmtmod.o : mofiles/commonmod.o +# additionals (for the modularized stuff, not in build.inc) +dcommon.o : mofiles/dcommonmod.o megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm +# special cases +dcommon.o : dcommon.scm $(MOFILES) $(DMOFILES) + %.o : %.scm $(MOFILES) csc $(CSCOPTS) -c $< $(MOFILES) $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) Index: build.inc ================================================================== --- build.inc +++ build.inc @@ -1,10 +1,11 @@ # To regenerate this file do: # (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm # cp allunits.inc build.inc # +mofiles/dcommonmod.o : mofiles/vgmod.o mofiles/tdb.o : mofiles/dbmod.o mofiles/tasks.o : mofiles/dbmod.o mofiles/servermod.o : mofiles/dbmod.o mofiles/rmtmod.o : mofiles/dbmod.o mofiles/portlogger.o : mofiles/dbmod.o Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -54,308 +54,5 @@ (import dbmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") - -(define (dboard:launch-testpanel run-id test-id) - (let* ((dboardexe (common:find-local-megatest "dashboard")) - (cmd (conc dboardexe - " -test " run-id "," test-id - " &"))) - (system cmd))) - - -(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " testpatt) - #:action - (lambda (obj) - ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) - (common:run-a-command - (conc "megatest -run -target " target - " -runname " runname - " -testpatt " testpatt - " -preclean -clean-cache") - ))) - (iup:menu-item - "Rerun Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt % " - " -preclean -clean-cache")))) - (iup:menu-item - "Clean Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % ")))) - (iup:menu-item - "Kill Complete Run" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt % " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - (iup:menu-item - "Delete Run Data" - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt % " - " -keep-records")))))) - -(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (iup:menu-item - (conc "Delete data : " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path - " -keep-records")))) - (iup:menu-item - (conc "Clean "item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -remove-runs -target " target - " -runname " runname - " -testpatt " item-test-path)))) - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) - ;; (system cmd)))) - (iup:menu-item - "Edit testconfig" - #:action - (lambda (obj) - (let* ((all-tests (tests:get-all)) - (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") - "\\b(vim?|nano|pico)\\b")) - (editor (or (configf:lookup *configdat* "setup" "editor") - (get-environment-variable "VISUAL") - (get-environment-variable "EDITOR") "vi")) - (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) - (cmd (conc (if (string-search editor-rx editor) - (conc "xterm -e " editor) - editor) - " " tconfig " &"))) - (system cmd)))))) - -(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # - (rundir (db:test-get-rundir test-info))) - - (iup:menu-item - "Step logs" - (apply iup:menu - (map (lambda (step) - (let ((stepname (vector-ref step 0)) - (logfile (vector-ref step 5)) - (status (vector-ref step 3))) - (iup:menu-item - (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") - #:action (lambda (obj) - (let ((fullfile (conc rundir "/" logfile))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found")))))))) - steps))))) - -(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) - (list - - (iup:menu-item - "Test Control Panel" - #:action - (lambda (obj) - (dboard:launch-testpanel run-id test-id))) - - (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) - - (iup:menu-item - (conc "Rerun " item-test-path) - #:action - (lambda (obj) - (common:run-a-command - (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target - " -runname " runname - " -testpatt " item-test-path - " -preclean -clean-cache")))) - - (iup:menu-item - "Start xterm" - #:action - (lambda (obj) - (dcommon:examine-xterm run-id test-id))) - - (iup:menu-item - (conc "Kill " item-test-path) - #:action - (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) - (common:run-a-command - (conc "megatest -set-state-status KILLREQ,n/a -target " target - " -runname " runname - " -testpatt " item-test-path - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) - - (let* ((rundir (db:test-get-rundir test-info)) - (has-subrun (subrun:subrun-test-initialized? rundir))) - (if has-subrun - (iup:menu-item - "Launch subrun dashboard" - #:action - (lambda (obj) - (subrun:launch-dashboard rundir))) - (iup:vbox))) - - (iup:menu-item - (conc "View Log " item-test-path) - #:action - (lambda (obj) - (let* ((rundir (db:test-get-rundir test-info)) - (logf (db:test-get-final_logf test-info)) - (fullfile (conc rundir "/" logf))) - (if (common:file-exists? fullfile) - (dcommon:run-html-viewer fullfile) - (message-window (conc "file " fullfile " not found."))))) - ) - )) -;; example section for megatest.config: -;; -;; -;; [custom-context-menu-items] -;; # : -;; item1 custom show run-id (%run-id%):echo "%run-id%" -;; item2 custom show test-id (%test-id%):echo "%test-id%" -;; item3 custom show target (%target%):echo "%target%" -;; item4 custom show test-name (%test-name%):echo "%test-name%" -;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" -;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" -;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" -;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" -;; item9 custom ls : ls -lrt -;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME - -(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) - (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) - (item-path (db:test-get-item-path test-info)) - (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) - (filter-map - (lambda (var) - (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) - (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) - (if m - (let* ((menu-item-text-raw (list-ref m 1)) - (command-line-raw (list-ref m 2)) - (subst-alist ;; template vars - `(( "%run-id%" . ,run-id ) - ( "%test-id%" . ,test-id ) - ( "%target%" . ,target ) - ( "%test-name%" . ,test-name) - ( "%test-patt%" . ,testpatt) - ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) - ( "%mt-root%" . ,mt-root) - ( "%run-name%" . ,run-name) - ( "%run-area-home%" . ,*toppath*) - ( "%item-path%" . ,item-path) - ( "%item-test-patt%" . ,item-test-path ))) - (command-line ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - command-line-raw - subst-alist)) - (menu-item-text ;; replace template vars - (foldr - (lambda (x i) - (string-substitute - (car x) - (->string (cdr x)) - i - #t)) - menu-item-text-raw - subst-alist))) - (iup:menu-item - (conc "*"menu-item-text) - #:action - (lambda (obj) - - (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) - ;;(BB> "cmdline is >"command-line"<") - (common:with-env-vars - ;; TODO: with-env-vars - ;; TODO: with-env-vars MT_* - (runs:get-mt-env-alist run-id run-name target test-name item-path) - - (lambda () - (if scheme-match - (begin - (handle-exceptions - exn - (print "error with custom menu scheme, exn=" exn) - (begin - ;;(BB> "gonna eval it!") - (eval (with-input-from-string (cadr scheme-match) read))))) - (common:run-a-command command-line with-vars: #t)))))))) - #f))) - vars))) - -(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) - (let* ((run-menu-items - (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (test-menu-items - (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (custom-menu-items - (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - (toplevel-menu-items - (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) - ) - (apply iup:menu - `(,@toplevel-menu-items - ,(iup:menu-item - "Run" - (apply iup:menu run-menu-items)) - ,(iup:menu-item - "Test" - (apply iup:menu test-menu-items)) - ,@custom-menu-items)))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -48,162 +48,5 @@ (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") -(define (control-panel db tdb keys) - (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove? - (key-params (make-hash-table)) - (monitordat '()) ;; list of monitor records - (keyentries (iup:frame - #:title "Keys" - (apply - iup:vbox - (map (lambda (key) - (iup:hbox (iup:label (vector-ref key 0) #:size "60x15") ; #:expand "HORIZONTAL") - (iup:textbox #:expand "HORIZONTAL" - #:action (lambda (obj a val) - (hash-table-set! key-params (vector-ref key 0) val))))) - keys)))) - (othervars (iup:frame - #:title "Run Vars" - (apply - iup:vbox - (map (lambda (var) - (iup:hbox (iup:label var #:size "60x15") - (iup:textbox #:expand "HORIZONTAL" - #:action (lambda (obj a val) - (hash-table-set! var-params var val))))) - (list "runname" "testpatts" "params"))))) - (controls (iup:frame - #:title "Controls" - (iup:hbox - (iup:frame - #:title "Runs" - (iup:hbox - (iup:button "Start" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (tasks:add-from-params tdb "run" keys key-params var-params) - (print "Launch Run"))) - (iup:button "Remove" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (print "Remove Run") - (tasks:add-from-params tdb "remove" keys key-params var-params) - )) - (iup:button "Rollup" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (print "Rollup Run") - (tasks:add-from-params tdb "rollup" keys key-params var-params))))) - (iup:frame - #:title "Misc" - (iup:hbox - (iup:button "Quit" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (sqlite3:finalize! db) - (sqlite3:finalize! tdb) - (exit)))))))) - (monitors (iup:textbox - #:expand "YES" ; HORIZONTAL" - ; #:size "x40" - #:multiline "YES" - #:font "Courier New, -10" - #:value "None...............................................")) - (actions (iup:textbox - #:expand "YES" - #:multiline "YES" - #:font "Courier New, -10" - #:value "None...............................................")) - (lastmodtime 0) - (next-touch 0) ;; the last time the "last_update" field was updated - (refreshdat (lambda () - (let* ((monitordbpath (conc *toppath* "/monitor.db")) - (megatestdbpath (conc *toppath* "/megatest.db")) - (modtime (max (file-modification-time megatestdbpath) - (file-modification-time monitordbpath)))) - ;; do stuff here when the db is updated by some other process - (if (> modtime lastmodtime) - (let ((tlst (tasks:get-tasks tdb '() '())) - (mlst (tasks:get-monitors tdb))) - (set! tasksdat tlst) - (set! monitorsdat mlst) - (iup:attribute-set! monitors "VALUE" (tasks:monitors->text-table mlst)) - (iup:attribute-set! actions "VALUE" (tasks:tasks->text tlst)) - (tasks:process-queue db tdb) - (set! lastmodtime (max (file-modification-time megatestdbpath) - (file-modification-time monitordbpath))) - (tasks:reset-stuck-tasks tdb))) - ;; stuff to do every 10 seconds - (if (> (current-seconds) next-touch) - (begin - ;; (tasks:process-queue db tdb monitordbpath) - (tasks:monitors-update tdb) - (tasks:reset-stuck-tasks tdb) - (set! monitorsdat (tasks:get-monitors tdb)) - (set! next-touch (+ (current-seconds) 10)) - ))))) - (topdialog #f)) - (set! topdialog (iup:dialog - #:close_cb (lambda (a)(exit)) - #:title "Run Controls" - (iup:vbox - (iup:hbox keyentries othervars) - controls - (let ((tabtop (iup:tabs - (iup:vbox - (let* ((tb (iup:textbox #:expand "HORIZONTAL")) - (bt (iup:button "Remove tasks by id" - #:action (lambda (obj) - (let ((val (iup:attribute tb "VALUE"))) - (tasks:remove-queue-entries tdb val))))) - (lb (iup:label "(comma separated)"))) - (iup:hbox bt tb lb)) - actions) - monitors - ))) - (iup:attribute-set! tabtop "TABTITLE0" "Actions") - (iup:attribute-set! tabtop "TABTITLE1" "Monitors") - tabtop) - ))) - ; (iup:frame - ; #:title "Monitors" - ; monitors) - ; (iup:frame - ; #:title "Actions" - ; actions)))) - - (iup:show topdialog) - (iup:callback-set! *tim* "ACTION_CB" - (lambda (x) - (refreshdat) - (if *exit-started* - (set! *exit-started* 'ok)))))) - -(define (main-window setuptab fsltab collateraltab toolstab) - (iup:show - (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES" - (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab))) - (iup:attribute-set! tabtop "TABTITLE0" "Setup") - (iup:attribute-set! tabtop "TABTITLE1" "Collateral") - (iup:attribute-set! tabtop "TABTITLE2" "Fossil") - (iup:attribute-set! tabtop "TABTITLE3" "Tools") - tabtop)))) - -;; BUG: Remember to re-instate this!!!! -;; (on-exit (lambda () -;; (let ((tdb (tasks:open-db))) -;; ;; (print "On-exit called") -;; (tasks:remove-monitor-record tdb) -;; (sqlite3:finalize! tdb)))) - -(define (gui-monitor db) - (let ((keys (db:get-keys db)) - (tdb (tasks:open-db))) - (tasks:register-monitor db tdb) ;;; let the other monitors know we are here - (control-panel db tdb keys) - ;(tasks:remove-monitor-record db) - ;(sqlite3:finalize! db) - )) - Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -53,936 +53,6 @@ (import dbmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") - -;;====================================================================== -;; C O M M O N -;;====================================================================== - -(define *dashboard-comment-share-slot* #f) - -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(define (dtests:get-pre-command #!key (default-override #f)) - (let* ((orig-pre-command "export CMD='") - (viewscreen-pre-command "viewscreen ") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) - - -(define (dtests:get-post-command #!key (default-override #f)) - (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" - "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) - (viewscreen-post-command "") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - - -(define (test-info-panel testdat store-label widgets) - (iup:frame - #:title "Test Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Testname: " - "Item path: " - "Current state: " - "Current status: " - "Test comment: " - "Test id: " - "Test date: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-label "testname" - (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-testname testdat))) - (store-label "item-path" - (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-item-path testdat))) - (store-label "teststate" - (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-state testdat))) - (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) - (hash-table-set! widgets "teststatus" - (lambda (testdat) - (let ((newstatus (db:test-get-status testdat)) - (oldstatus (iup:attribute lbl "TITLE"))) - (if (not (equal? oldstatus newstatus)) - (begin - (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) - (db:test-get-status testdat)))) - (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) - lbl) - (store-label "testcomment" - (iup:label "TestComment " - #:expand "HORIZONTAL") - (lambda (testdat) - (let ((newcomment (db:test-get-comment testdat))) - (if *dashboard-comment-share-slot* - (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") - newcomment)) - (iup:attribute-set! *dashboard-comment-share-slot* - "VALUE" - newcomment))) - newcomment))) - (store-label "testid" - (iup:label "TestId " - #:expand "HORIZONTAL") - (lambda (testdat) - (db:test-get-id testdat))) - (store-label "testdate" - (iup:label "TestDate " - #:expand "HORIZONTAL") - (lambda (testdat) - (seconds->work-week/day-time (db:test-get-event_time testdat)))) - ))))) - -;;====================================================================== -;; Test meta panel -;;====================================================================== - -(define (test-meta-panel-get-description testmeta) - (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) - -(define (test-meta-panel testmeta store-meta) - (iup:frame - #:title "Test Meta Data" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Author: " - "Owner: " - "Reviewed: " - "Tags: " - "Description: ")) - (list (iup:label "" #:expand "VERTICAL")))) - (apply iup:vbox ; #:expand "YES" - (list - (store-meta "author" - (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-author testmeta))) - (store-meta "owner" - (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-owner testmeta))) - (store-meta "reviewed" - (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) - (store-meta "tags" - (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") - (lambda (testmeta)(db:testmeta-get-tags testmeta))) - (store-meta "description" - (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") - (lambda (testmeta) - (test-meta-panel-get-description testmeta))) - ))))) - - -;;====================================================================== -;; Run info panel -;;====================================================================== -(define (run-info-panel db keydat testdat runname) - (let* ((run-id (db:test-get-run_id testdat)) - (rundat (rmt:get-run-info run-id)) - (header (db:get-header rundat)) - (event_time (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "event_time"))) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" - (append (map (lambda (keyval) - (iup:label (conc (car keyval) " "))) - keydat) - (list (iup:label "runname ") - (iup:label "run-id") - (iup:label "run-date")))) - (apply iup:vbox - (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) - keydat) - (list (iup:label runname) - (iup:label (conc run-id)) - (iup:label (seconds->year-work-week/day-time event_time)) - (iup:label "" #:expand "VERTICAL")))))))) - -;;====================================================================== -;; Host info panel -;;====================================================================== -(define (host-info-panel testdat store-label) - (iup:frame - #:title "Remote host and Test Run Info" ; #:expand "YES" - (iup:hbox ; #:expand "YES" - (apply iup:vbox ; #:expand "YES" ;; The heading labels - (append (map (lambda (val) - (iup:label val ; #:expand "HORIZONTAL" - )) - (list "Hostname: " - "Disk free: " - "CPU Load: " - "Run duration: " - "Logfile: " - "Top process id: " - "Uname -a: ")) - (iup:label "" #:expand "VERTICAL"))) - (apply iup:vbox ; #:expand "YES" - (list - ;; NOTE: Yes, the host can change! - (store-label "HostName" - (iup:label ;; (sdb:qry 'getstr - (db:test-get-host testdat) ;; ) - #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-host testdat))) - (store-label "DiskFree" - (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-diskfree testdat)))) - (store-label "CPULoad" - (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-cpuload testdat)))) - (store-label "RunDuration" - (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") - (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) - (store-label "LogFile" - (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-final_logf testdat)))) - (store-label "ProcessId" - (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") - (lambda (testdat)(conc (db:test-get-process_id testdat)))) - (store-label "Uname" - (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") - (lambda (testdat) ;; (sdb:qry 'getstr - (db:test-get-uname testdat))) ;; ) - ))))) - -;; if there is a submegatest create a button to launch dashboard in that area -;; -(define (submegatest-panel dbstruct keydat testdat runname testconfig) - (let* ((test-run-dir (db:test-get-rundir testdat)) - (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t))) - (target #f) - (runname #f) - (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp"))) - (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard - (let* ((cmd-parts (if (file-exists? cmd-parts-file) - (with-input-from-file cmd-parts-file - read) - '())) - (target (alist-ref "-target" cmd-parts equal?)) - (runname (alist-ref "-runname" cmd-parts equal?)) - (run-area (alist-ref "-startdir" cmd-parts equal?))) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:vbox - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir))) - (iup:button - "Launch Dashboard+Filter" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir target: target runname: runname)))))) - (iup:vbox)))) - -;; use a global for setting the buttons colors -;; state status teststeps -(define *state-status* (vector #f #f #f)) -(define (update-state-status-buttons testdat) - (let* ((state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (color (car (gutils:get-color-for-state-status state status)))) - ((vector-ref *state-status* 0) state color) - ((vector-ref *state-status* 1) status color))) - -(define *dashboard-test-db* #t) -(define *dashboard-comment-share-slot* #f) - -;;====================================================================== -;; Set fields -;;====================================================================== -(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) - (let ((newcomment #f) - (newstatus #f) - (newstate #f) - (wtxtbox #f)) - (iup:frame - #:title "Set fields" - (iup:vbox - (iup:hbox (iup:label "Comment:") - (let ((txtbox (iup:textbox #:action (lambda (val a b) - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (rmt:test-set-state-status run-id test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL"))) - (set! wtxtbox txtbox) - txtbox)) - - (apply iup:hbox - (iup:label "STATE:" #:size "30x") - (let* ((btns (map (lambda (state) - (let ((btn (iup:button state - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected - (db:test-set-state! testdat state))))) - btn)) - (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) - (vector-set! *state-status* 0 - (lambda (state color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)) - (apply iup:hbox - (iup:label "STATUS:" #:size "30x") - (let* ((btns (map (lambda (status) - (let ((btn (iup:button status - #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" - #:action (lambda (x) - (let ((t (iup:attribute x "TITLE"))) - (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver run-id testdat - (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) - (lambda (c) - (set! newcomment c) - (if wtxtbox - (begin - (iup:attribute-set! wtxtbox "VALUE" c) - (if (not *dashboard-comment-share-slot*) - (set! *dashboard-comment-share-slot* wtxtbox))) - )))) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected - (db:test-set-status! testdat status)))))))) - btn)) - (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) - (vector-set! *state-status* 1 - (lambda (status color) - (for-each - (lambda (btn) - (let* ((name (iup:attribute btn "TITLE")) - (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) - (iup:attribute-set! btn "BGCOLOR" newcolor)))) - btns))) - btns)))))) - -(define (dashboard-tests:run-a-step info) - #t) - -;; (define (dashboard-tests:step-run-control testdat stepname testconfig) -;; (let* ((mutex (make-mutex))) -;; (letrec ((dlg -;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" -;; #:title stepname -;; (iup:vbox ; #:expand "YES" -;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) -;; (iup:button "Re-run" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump (lambda () -;; (thread-start! -;; (make-thread -;; (lambda () -;; (print "BB> started ezsteps:run-from") -;; (debug:catch-and-dump -;; (lambda () -;; (ezsteps:run-from testdat stepname #t)) -;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") -;; (print "BB> done ezsteps:run-from") -;; 'foo) -;; (conc "ezstep run single step " stepname))) -;; ) -;; "step-run-control action"))) -;; (iup:button "Re-run and continue" -;; #:expand "HORIZONTAL" -;; #:action (lambda (obj) -;; (debug:catch-and-dump -;; (lambda () -;; (thread-start! -;; (make-thread (lambda () -;; (ezsteps:run-from testdat stepname #f)) -;; (conc "ezstep run from step " stepname)))) -;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) -;; (iup:button "Close" -;; #:action (lambda (obj) -;; (iup:destroy! dlg))) -;; ;; (iup:button "Refresh test data" -;; ;; #:expand "HORIZONTAL" -;; ;; #:action (lambda (obj) -;; ;; (print "Refresh test data " stepname)) -;; )))) -;; dlg))) - -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) - (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) - (wregx (if (string? wpatt)(regexp wpatt) #f)) - (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) - (comnt (iup:textbox #:action (lambda (val a b) - (if wpatt - (if (string-match wregx b) - (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) - (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) - ))) - #:value (if ovrdval ovrdval (db:test-get-comment testdat)) - #:expand "HORIZONTAL")) - (dlog #f)) - (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title "SET WAIVER" - (iup:vbox ; #:expand "YES" - (iup:label (conc "Enter justification for waiving test " - (db:test-get-testname testdat) - (if (equal? (db:test-get-item-path testdat) "") - "" - (conc "/" (db:test-get-item-path testdat))))) - wmesg ;; the informational msg on whether it matches - comnt - (iup:hbox - (iup:button "Apply and Close " - #:expand "HORIZONTAL" - #:action (lambda (obj) - (let ((comment (iup:attribute comnt "VALUE")) - (test-id (db:test-get-id testdat))) - (if (or (not wpatt) - (string-match wregx comment)) - (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) - (db:test-set-status! testdat "WAIVED") - (cmtcmd comment) - (iup:destroy! dlog)))))) - (iup:button "Cancel" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (iup:destroy! dlog))))))) - dlog)) - - -;;====================================================================== -;; -;;====================================================================== -(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") - ;; local: #t)) - (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) - (db-mod-time 0) ;; (file-modification-time db-path)) - (last-update 0) ;; (current-seconds)) - (request-update #t)) - (if (not testdat) - (begin - (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) - (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) - (test-registry (tests:get-all)) - (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) - (rundat (if testdat (rmt:get-run-info run-id) #f)) - (runname (if testdat (db:get-value-by-header (db:get-rows rundat) - (db:get-header rundat) - "runname") #f)) - ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) - ;; These next two are intentional bad values to ensure errors if they should not - ;; get filled in properly. - (logfile "/this/dir/better/not/exist") - (rundir (if testdat - (db:test-get-rundir testdat) - logfile)) - ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (augment-teststeps (lambda (inlov) - (map - (lambda (invec) - (list->vector - `( - ,@(reverse (cdr (reverse (vector->list invec)))) - "rerun this step" "restart from here" ))) - inlov))) - (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) - (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) - (testname (if testdat (db:test-get-testname testdat) "n/a")) - ;; (tests:get-testconfig testdat testname 'return-procs)) - (testmeta (if testdat - (let ((tm (rmt:testmeta-get-record testname))) - (if tm tm (make-db:testmeta))) - (make-db:testmeta))) - - (keystring (string-intersperse - (map (lambda (keyval) - ;; (conc ":" (car keyval) " " (cadr keyval))) - (cadr keyval)) - keydat) - "/")) - (item-path (db:test-get-item-path testdat)) - ;; this next block was added to fix a bug where variables were - ;; needed. Revisit this. - (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (common:file-exists? runconfigf) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) - #f) ;; do nothing, just keep on trucking .... - (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) - (make-hash-table)))) - (testconfig (begin - ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) - (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process - (handle-exceptions - exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! - (begin - (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) - (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) - (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) - (viewlog (lambda (x) - (if (common:file-exists? logfile) - ;(system (conc "firefox " logfile "&")) - (dcommon:run-html-viewer logfile) - (message-window (conc "File " logfile " not found"))))) - (view-a-log (lambda (lfile) - (let ((lfilename (conc rundir "/" lfile))) - ;; (print "lfilename: " lfilename) - (if (common:file-exists? lfilename) - ;(system (conc "firefox " logfile "&")) - (dcommon:run-html-viewer lfilename) - (message-window (conc "File " lfilename " not found")))))) - (xterm (lambda (x) - (if (directory-exists? rundir) - (let ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - ""))) - (common:without-vars - (conc "cd " rundir - ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") - "MT_.*")) - (message-window (conc "Directory " rundir " not found"))))) - (widgets (make-hash-table)) - (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (common:file-exists? testdat-path) - ;; (file-modification-time testdat-path) - ;; (begin - ;; (set! testdat-path (conc rundir "/testdat.db")) - ;; 0)))) - (need-update (or (and (>= curr-mod-time db-mod-time) - (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched - (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds - request-update)) - (newtestdat (if need-update - ;; NOTE: BUG HIDER, try to eliminate this exception handler - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id - ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - #f) - (rmt:get-test-info-by-id run-id test-id))))) - ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) - (cond - ((and need-update newtestdat) - (set! testdat newtestdat) - (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) - (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir ;; (filedb:get-path *fdb* - (db:test-get-rundir testdat)) ;; ) - (set! testfullname (db:test-get-fullname testdat)) - ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) - - ;; I don't see why this was implemented this way. Please comment it ... - ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same - ;; (set! db-mod-time (+ curr-mod-time 1)) - ;; (set! db-mod-time curr-mod-time)) - - (if (not (eq? curr-mod-time db-mod-time)) - (set! db-mod-time curr-mod-time)) - (set! last-update (current-milliseconds)) - (set! request-update #f) ;; met the need ... - ) - (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) - (if need-update - (begin - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat))) - ;; (iup:refresh self) - ))) - (meta-widgets (make-hash-table)) - (self #f) - (store-label (lambda (name lbl cmd) - (hash-table-set! widgets name - (lambda (testdat) - (let ((newval (cmd testdat)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-meta (lambda (name lbl cmd) - (hash-table-set! meta-widgets name - (lambda (testmeta) - (let ((newval (cmd testmeta)) - (oldval (iup:attribute lbl "TITLE"))) - (if (not (equal? newval oldval)) - (begin - ;(mutex-lock! mx1) - (iup:attribute-set! lbl "TITLE" newval) - ;(mutex-unlock! mx1) - ))))) - lbl)) - (store-button store-label) - (command-proc (lambda (command-text-box) - (let* ((cmd (iup:attribute command-text-box "VALUE"))) - (common:run-a-command cmd with-orig-env: #t)))) - (command-text-box (iup:textbox - #:expand "HORIZONTAL" - #:font "Courier New, -10" - #:action (lambda (obj cnum val) - ;; (print "cnum=" cnum) - (if (eq? cnum 13) - (command-proc obj))) - )) - (command-launch-button (iup:button "Execute!" #:action (lambda (x) - (command-proc command-text-box)))) - ;; (lambda (x) - ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) - ;; (fullcmd (conc (dtests:get-pre-command) - ;; cmd - ;; (dtests:get-post-command)))) - ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - ;; (common:without-vars fullcmd "MT_.*"))))) - (kill-jobs (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -set-state-status KILLREQ,n/a -testpatt %/% " - " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) - (run-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -run -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - )))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (clean-run-execute (lambda (x) - (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname - "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ";megatest -target " keystring " -runname " runname - " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -clean-cache" - ))) - (thread-start! (make-thread (lambda () - (common:run-a-command cmd)) - "clean-run-execute"))))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -remove-runs -target " keystring " -runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v")))) - (archive-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "megatest -target " keystring " -runname " runname - " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ))))) - (cond - ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) - (else - ;; (test-set-status! db run-id test-name state status itemdat) - (set! self ; - (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title testfullname - (iup:vbox ; #:expand "YES" - ;; The run and test info - (iup:hbox ; #:expand "YES" - (run-info-panel dbstruct keydat testdat runname) - (test-info-panel testdat store-label widgets) - (test-meta-panel testmeta store-meta)) - (iup:hbox - (host-info-panel testdat store-label) - (submegatest-panel dbstruct keydat testdat runname testconfig)) - ;; The controls - (iup:frame #:title "Actions" - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") - (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") - (iup:button "Archive Test" #:action archive-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) - (apply - iup:hbox - (list command-text-box command-launch-button)))) - (set-fields-panel dbstruct run-id test-id testdat) - (let ((tabs - (iup:tabs - ;; Replace here with matrix - (let ((steps-matrix (iup:matrix - #:font "Courier New, -8" - #:expand "YES" - #:scrollbar "YES" - #:numcol 9 - #:numlin 100 - #:numcol-visible 9 - #:numlin-visible 5 - #:click-cb (lambda (obj lin col status) - ;; (if (equal? col 6) - (let* ((mtrx-rc (conc lin ":" 6)) - (fname (iup:attribute obj mtrx-rc)) - (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) - (case col - - ((7) (print "Comment from step "stepname": "comment)) - ((8) (ezsteps:spawn-run-from testdat stepname #t)) - ((9) (ezsteps:spawn-run-from testdat stepname #f)) - (else (view-a-log fname)))))))) - ;; (let loop ((count 0)) - ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) - ;; (if (< count 30) - ;; (loop (+ count 1)))) - (iup:attribute-set! steps-matrix "0:1" "Step Name") - (iup:attribute-set! steps-matrix "0:2" "Start") - (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "50") - (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "50") - (iup:attribute-set! steps-matrix "0:5" "Duration") - (iup:attribute-set! steps-matrix "0:6" "Log File") - (iup:attribute-set! steps-matrix "0:7" "Comment") - (iup:attribute-set! steps-matrix "0:8" "rerun only") - (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") - (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") - (iup:attribute-set! steps-matrix "0:9" "rerun & continue") - (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") - ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") - (let ((proc - (lambda (testdat) - (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) - (hash-table-set! widgets "StepsMatrix" proc) - (proc testdat)) - steps-matrix) - ;; populate the Test Data panel - (iup:frame - #:title "Test Data" - (let ((test-data - (iup:textbox ;; #:action (lambda (obj char val) - ;; #f) - #:expand "YES" - #:multiline "YES" - #:font "Courier New, -10" - #:size "100x100"))) - (hash-table-set! widgets "Test Data" - (lambda (testdat) ;; - (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) - (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment - (newval (string-intersperse - (append - (list - (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") - (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) - (map (lambda (x) - (format #f fmtstr - (db:test-data-get-category x) - (db:test-data-get-variable x) - (db:test-data-get-value x) - (db:test-data-get-expected x) - (db:test-data-get-tol x) - (db:test-data-get-status x) - (db:test-data-get-units x) - (db:test-data-get-type x) - (db:test-data-get-comment x))) - (rmt:read-test-data run-id test-id "%"))) - "\n"))) - (if (not (equal? currval newval)) - (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) - test-data)) - ;;(dashboard:run-controls) - ))) - (iup:attribute-set! tabs "TABTITLE0" "Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs)))) - (iup:show self) - (iup:callback-set! *tim* "ACTION_CB" - (lambda (x) - ;; Now start keeping the gui updated from the db - (refreshdat) ;; update from the db here - ;(thread-suspend! other-thread) - (if *exit-started* - (set! *exit-started* 'ok)))))))))) - -(define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -;; Display the tests as rows of boxes on the test/task pane -;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) - (canvas-clear! cnv) - (canvas-font-set! cnv "Helvetica, -10") - (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - )) - -(define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? - -;; additional setters for dboard:data -(define (dboard:tabdat-test-patts-set!-use vec val) - (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) - -;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command tabdat) - (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) - (cmd (dboard:tabdat-command tabdat)) - (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (or (not tp) - (equal? tp "")) - "%" - tp))) - (states (dboard:tabdat-states tabdat)) - (statuses (dboard:tabdat-statuses tabdat)) - (target (let ((targ-list (dboard:tabdat-target tabdat))) - (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:tabdat-run-name tabdat)) - (states-str (if (or (not states) - (null? states)) - "" - (conc " -state " (string-intersperse states ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " -status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((run) - (set! full-cmd (conc full-cmd - " -run" - " -testpatt " - test-patt - " -target " - target - " -runname " - run-name - " -clean-cache" - ))) - ((remove-runs) - (set! full-cmd (conc full-cmd - " -remove-runs -runname " - run-name - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) - (for-each (lambda (item) - (iup:attribute-set! lb (number->string i) item) - (if selected-item - (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) - (set! i (+ i 1))) - items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) - i)) - -;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num -;; adds the updater passed in the updaters list at that hashkey -;; -(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat))) - (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) - (hash-table-set! (dboard:commondat-updaters commondat) - tnum - (cons updater curr-updaters)))) - - - -(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) - (let* ((pre-cmd (dtests:get-pre-command)) - (post-cmd (dtests:get-post-command)) - (fullcmd (if (or pre-cmd post-cmd) - (conc pre-cmd cmd post-cmd) - (conc "viewscreen " cmd)))) - (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (cond - (with-vars (common:without-vars fullcmd)) - (with-orig-env (common:with-orig-env fullcmd)) - (else (common:without-vars fullcmd "MT_.*"))))) - Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -83,15 +83,15 @@ (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) -(declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) -(declare (uses tree)) -(declare (uses dcommon)) -(declare (uses dashboard-context-menu)) +;; (declare (uses dashboard-tests)) +;; (declare (uses dashboard-guimonitor)) +;; (declare (uses tree)) +;; (declare (uses dcommon)) +;; (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) ;; (declare (uses dashboard-main)) (declare (uses mt)) @@ -239,3199 +239,10 @@ ;; data from sql db ;; (keys (rmt:get-keys)) ;; to be removed when targets handling is r ;; (print "Got here #1.7") -;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) -;; -(define (dboard:common-get-tabdat commondat #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat) - 0)) ;; tab-num value is curr-tab-num value in passed commondat - (ht (dboard:commondat-tabdats commondat)) - (res (hash-table-ref/default ht tnum #f))) - (or res - (let ((new-tabdat (dboard:tabdat-make-data))) - (hash-table-set! ht tnum new-tabdat) - new-tabdat)))) - -;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table -;; -(define (dboard:common-set-tabdat! commondat tabnum tabdat) - (hash-table-set! - (dboard:commondat-tabdats commondat) - tabnum - tabdat)) - -;; gets and calls updater list based on curr-tab-num -;; -(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) - (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat - (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) - (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) - tnum - '()))) - (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) - (for-each ;; perform the function calls for the complete updaters list - (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) - (updater)) - updaters)))) - -;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num -;; adds the updater passed in the updaters list at that hashkey -;; -(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat))) - (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) - (hash-table-set! (dboard:commondat-updaters commondat) - tnum - (cons updater curr-updaters)))) - - -(define (dboard:tabdat-target-string vec) - (let ((targ (dboard:tabdat-target vec))) - (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) - -(define (dboard:tabdat-test-patts-use vec) - (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? - -;; additional setters for dboard:data -(define (dboard:tabdat-test-patts-set!-use vec val) - (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) - -(define (dboard:tabdat-make-data) - (let ((dat (make-dboard:tabdat))) - (dboard:tabdat-runs-btn-height-set! dat (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) ;; was 12 - (dboard:tabdat-runs-btn-fontsz-set! dat (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) ;; was 8 - (dboard:tabdat-runs-cell-width-set! dat (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) ;; was 50 - (dboard:tabdat-numruns-set! dat (string->number (or (args:get-arg "-cols") - (configf:lookup *configdat* "dashboard" "cols") - "8"))) - (dboard:tabdat-access-mode-set! dat (db:get-access-mode)) ;; use cached db or not - (dboard:setup-tabdat dat) - (dboard:setup-num-rows dat) - dat)) - -(define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area)) - (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 "%")) - ) - -(define (dboard:runsdat-make-init) - (make-dboard:runsdat - runs-index: (make-hash-table) - tests-index: (make-hash-table) - matrix-dat: (make-sparse-array))) - -;; default is to NOT set the cell if the column and row names are not pre-existing -;; -(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) - (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) - (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) - (if (and row-num col-num) - (let ((tdat (dboard:testdat - id: test-id - state: state - status: status))) - (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat) - tdat) - #f))) - -(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) - - -(define *exit-started* #f) - -;; sorting global data (would apply to many testsuites so leave it global for now) -;; -(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") - (vector "Sort -a" 'testname "DESC") - (vector "Sort +t" 'event_time "ASC") - (vector "Sort -t" 'event_time "DESC") - (vector "Sort +s" 'statestatus "ASC") - (vector "Sort -s" 'statestatus "DESC") - (vector "Sort +a" 'testname "ASC"))) - -(define *tests-sort-type-index* '(("+testname" 0) - ("-testname" 1) - ("+event_time" 2) - ("-event_time" 3) - ("+statestatus" 4) - ("-statestatus" 5))) - -;; Don't forget to adjust the >= below if you add to the sort-options above -(define (next-sort-option) - (if (>= *tests-sort-reverse* 5) - (set! *tests-sort-reverse* 0) - (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) - *tests-sort-reverse*) - -(define *tests-sort-reverse* - (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) - (if t-sort - (cadr t-sort) - 3))) - -(define (get-curr-sort) - (vector-ref *tests-sort-options* *tests-sort-reverse*)) - -;; (print "Got here #2") - -;;====================================================================== - -;;====================================================================== -(common:debug-setup) - -;; (define uidat #f) - -(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) -(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) -(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) -(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) - -(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) - -(define (message-window msg) - (iup:show - (iup:dialog - (iup:vbox - (iup:label msg #:margin "40x40"))))) - -(define (iuplistbox-fill-list lb items #!key (selected-item #f)) - (let ((i 1)) - (for-each (lambda (item) - (iup:attribute-set! lb (number->string i) item) - (if selected-item - (if (equal? selected-item item) - (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) - (set! i (+ i 1))) - items) - ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) - i)) - -(define (pad-list l n)(append l (make-list (- n (length l))))) - -(define (colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -(define (dboard:compare-tests test1 test2) - (let* ((test-name1 (db:test-get-testname test1)) - (item-path1 (db:test-get-item-path test1)) - (eventtime1 (db:test-get-event_time test1)) - (test-name2 (db:test-get-testname test2)) - (item-path2 (db:test-get-item-path test2)) - (eventtime2 (db:test-get-event_time test2)) - (same-name (equal? test-name1 test-name2)) - (test1-top (equal? item-path1 "")) - (test2-top (equal? item-path2 "")) - (test1-older (> eventtime1 eventtime2)) - (same-time (equal? eventtime1 eventtime2))) - (if same-name - (if same-time - (string>? item-path1 item-path2) - test1-older) - (if same-time - (string>? test-name1 test-name2) - test1-older)))) - -;; This is roughly the same as dboard:get-tests-dat, should merge them if possible -;; -;; gets all the tests for run-id that match testnamepatt and key-vals, merges them -;; -;; NOTE: Yes, this is used -;; -(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((start-time (current-seconds)) - (access-mode (dboard:tabdat-access-mode tabdat)) - (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") - "200"))) - (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) - (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab - (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab - (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) - ;; note: the rundat is normally created in "update-rundat". - (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) - (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) - (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) - rd))) - ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) - (last-update (if ;;(or - do-not-use-query-timestamps - ;;(dboard:tabdat-filters-changed tabdat)) - 0 - (dboard:rundat-last-update run-dat))) - (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"))) - (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 - (tmptests (if (or do-not-use-db-file-timestamps - (dboard:tabdat-filters-changed tabdat) - db-modified) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) ;; query offset - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - last-update ;; last-update - *dashboard-mode*) ;; use dashboard mode - '())) - (use-new (dboard:tabdat-hide-not-hide tabdat)) - (tests-ht (if (dboard:tabdat-filters-changed tabdat) - (let ((ht (make-hash-table))) - (dboard:rundat-tests-set! run-dat ht) - ht) - (dboard:rundat-tests run-dat))) - (got-all (< (length tmptests) num-to-get)) ;; got all for this round - ) - - ;; if we saw the db modified, reset it (the signal has already been used) - (if (and got-all ;; (not multi-get) - db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) - - ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset - ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the - ;; data has been read - ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above - ;; - ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) - (if got-all - (begin - (dboard:rundat-last-update-set! run-dat (- start-time 2)) - (dboard:rundat-run-data-offset-set! run-dat 0)) - (begin - (dboard:rundat-run-data-offset-set! run-dat - (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) - - (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) - - tests-ht)) - -;; tmptests - new tests data -;; prev-tests - old tests data -;; -;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests) -;; (let* ((newdat (filter -;; (lambda (x) -;; (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging -;; (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat) -;; tmptests -;; (append tmptests prev-tests)) -;; (lambda (a b) -;; (eq? (db:test-get-id a)(db:test-get-id b))))))) -;; (print "Time took: " (- (current-seconds) start-time)) -;; (if (eq? *tests-sort-reverse* 3) ;; +event_time -;; (sort newdat dboard:compare-tests) -;; newdat))) - -;; 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 (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (rmt:get-keys)) - (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt: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)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected - (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs - (start-time (current-seconds)) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run header "id") run)) - runs-tree) ;; (vector-ref runs-dat 1)) - ht)) - (tb (dboard:tabdat-runs-tree tabdat))) - ;;(BB> "In update-rundat") - ;;(inspect allruns runs-hash) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (dboard:tabdat-header-set! tabdat header) - ;; - ;; trim runs to only those that are changing often here - ;; - (if (null? runs) - (begin - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-all-test-names-set! tabdat '()) - (dboard:tabdat-item-test-names-set! tabdat '()) - (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) - (let loop ((run (car runs)) - (tal (cdr runs)) - (res '()) - (maxtests 0)) - (let* ((run-id (db:get-value-by-header run header "id")) - (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 (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) - ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate - ;; dboard:get-tests-for-run-duplicate - returns a hash table - ;; (dboard:get-tests-dat tabdat run-id last-update)) - (all-test-ids (hash-table-keys tests-ht)) - (num-tests (length all-test-ids))) - ;; (print "run-struct: " run-struct) - ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) - ;; (tests (bubble-up tmptests priority: bubble-type)) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (let* ((newmaxtests (max num-tests maxtests)) - (last-update (- (current-seconds) 10)) - (run-struct (or run-struct - (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals))) - (new-res (if (null? all-test-ids) res (cons run-struct res))) - (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 get-tests-for-run uses last update - (begin - (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) - (dboard:tabdat-allruns-set! tabdat new-res) - 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))) - -;; 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)) - (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 (rmt: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)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected - (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs - (start-time (current-seconds)) - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run header "id") run)) - runs-tree) ;; (vector-ref runs-dat 1)) - ht)) - (tb (dboard:tabdat-runs-tree tabdat))) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (dboard:tabdat-header-set! tabdat header) - ;; - ;; trim runs to only those that are changing often here - ;; - (if (null? runs) - (begin - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-all-test-names-set! tabdat '()) - (dboard:tabdat-item-test-names-set! tabdat '()) - (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) - (let loop ((run (car runs)) - (tal (cdr runs)) - (res '()) - (maxtests 0)) - (let* ((run-id (db:get-value-by-header run header "id")) - (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 (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) - ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate - ;; dboard:get-tests-for-run-duplicate - returns a hash table - ;; (dboard:get-tests-dat tabdat run-id last-update)) - (all-test-ids (hash-table-keys tests-ht)) - (num-tests (length all-test-ids))) - ;; (print "run-struct: " run-struct) - ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) - ;; (tests (bubble-up tmptests priority: bubble-type)) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (let* ((newmaxtests (max num-tests maxtests)) - ;; (last-update (- (current-seconds) 10)) - (run-struct (or run-struct - (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals))) - (new-res (if (null? all-test-ids) - res - (delete-duplicates - (cons run-struct res) - (lambda (a b) - (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") - (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 get-tests-for-run uses last update - (begin - (when (> elapsed-time 2) - (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") - (let* ((old-val (iup:attribute *tim* "TIME")) - (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) - (if (< (string->number new-val) 5000) - ((debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) - (iup:attribute-set! *tim* "TIME" new-val)))) - - - ) - (dboard:tabdat-allruns-set! tabdat new-res) - 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))) - -(define *collapsed* (make-hash-table)) - -(define (toggle-hide lnum uidat) ; fulltestname) - (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) - (fulltestname (iup:attribute btn "TITLE")) - (parts (string-split fulltestname "(")) - (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) - (if (hash-table-ref/default *collapsed* basetestname #f) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s - (hash-table-delete! *collapsed* basetestname)) - (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") - (hash-table-set! *collapsed* basetestname #t))))) - -(define blank-line-rx (regexp "^\\s*$")) - -(define (run-item-name->vectors lst) - (map (lambda (x) - (let ((splst (string-split x "(")) - (res (vector "" ""))) - (vector-set! res 0 (car splst)) - (if (> (length splst) 1) - (vector-set! res 1 (car (string-split (cadr splst) ")")))) - res)) - lst)) - -(define (collapse-rows tabdat inlst) - (let* ((sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) - (bubble-type (if (member sort-order '(testname)) - 'testname - 'itempath)) - (newlst (filter (lambda (x) - (let* ((tparts (string-split x "(")) - (basetname (if (null? tparts) x (car tparts)))) - ;(print "x " x " tparts: " tparts " basetname: " basetname) - (cond - ((string-match blank-line-rx x) #f) - ((equal? x basetname) #t) - ((hash-table-ref/default *collapsed* basetname #f) - ;(print "Removing " basetname " from items") - #f) - (else #t)))) - inlst)) - (vlst (run-item-name->vectors newlst)) - (vlst2 (bubble-up tabdat vlst priority: bubble-type))) - (map (lambda (x) - (if (equal? (vector-ref x 1) "") - (vector-ref x 0) - (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) - vlst2))) - -(define (update-labels uidat alltestnames) - (let* ((rown 0) - (keycol (dboard:uidat-get-keycol uidat)) - (lftcol (dboard:uidat-get-lftcol uidat)) - (numcols (vector-length lftcol)) - (maxn (- numcols 1)) - (allvals (make-vector numcols ""))) - (for-each (lambda (name) - (if (<= rown maxn) - (vector-set! allvals rown name)) ;) - (set! rown (+ 1 rown))) - alltestnames) - (let loop ((i 0)) - (let* ((lbl (vector-ref lftcol i)) - (keyval (vector-ref keycol i)) - (oldval (iup:attribute lbl "TITLE")) - (newval (vector-ref allvals i))) - (if (not (equal? oldval newval)) - (let ((munged-val (let ((parts (string-split newval "("))) - (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) - (vector-set! keycol i newval) - (iup:attribute-set! lbl "TITLE" munged-val))) - (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) - (if (< i maxn) - (loop (+ i 1))))))) - -;; -(define (get-itemized-tests test-dats) - (let ((tnames '())) - (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) - (if (not (equal? ipath "")) - (if (and (list? tnames) - (string? tname) - (not (member tname tnames))) - (set! tnames (append tnames (list tname))))))) - test-dats) - tnames)) - -;; Bubble up the top tests to above the items, collect the items underneath -;; all while preserving the sort order from the SQL query as best as possible. -;; -(define (bubble-up tabdat test-dats #!key (priority 'itempath)) - (if (null? test-dats) - test-dats - (begin - (let* ((tnames '()) ;; list of names used to reserve order - (tests (make-hash-table)) ;; hash of lists, used to build as we go - (itemized (get-itemized-tests test-dats))) - (for-each - (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests tname #f))) - (if (not (member tname tnames)) - (if (or (and (eq? priority 'itempath) - (not (equal? ipath ""))) - (and (eq? priority 'testname) - (equal? ipath "")) - (not (member tname itemized))) - (set! tnames (append tnames (list tname))))) - (if (equal? ipath "") - ;; This a top level, prepend it - (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) - ;; This is item, append it - (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) - test-dats) - ;; Set all tests with items - (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - (dboard:tabdat-item-test-names tabdat))) - (let loop ((hed (car tnames)) - (tal (cdr tnames)) - (res '())) - (let ((newres (append res (hash-table-ref tests hed)))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))))) - -;; optimized to get runs constrained by what is visible on the screen -;; - not appropriate for where all the runs are needed -;; -(define (update-buttons tabdat uidat numruns numtests) - (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) - (take-right (dboard:tabdat-allruns tabdat) numruns) - (pad-list (dboard:tabdat-allruns tabdat) numruns))) - (lftcol (dboard:uidat-get-lftcol uidat)) - (tableheader (dboard:uidat-get-header uidat)) - (table (dboard:uidat-get-runsvec uidat)) - (coln 0) - (all-test-names (make-hash-table))) - ;; create a concise list of test names - ;; - (for-each - (lambda (rundat) - (if rundat - (let* ((testdats (dboard:rundat-tests rundat)) - (testnames (map test:test-get-fullname (hash-table-values testdats)))) - (dcommon:rundat-copy-tests-to-by-name rundat) - ;; for the normalized list of testnames (union of all runs) - (if (not (and (dboard:tabdat-hide-empty-runs tabdat) - (null? testnames))) - (for-each (lambda (testname) - (hash-table-set! all-test-names testname #t)) - testnames))))) - runs) - - ;; create the minimize list of testnames to be displayed. Sorting - ;; happens here *before* trimming - ;; - (dboard:tabdat-all-test-names-set! - tabdat - (collapse-rows - tabdat - (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here - - ;; Trim the names list to fit the matrix of buttons - ;; - (dboard:tabdat-all-test-names-set! - tabdat - (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) - (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 - (lambda (rundat) - ;; if rundat is junk clobber it with a decent placeholder - (if (or (not rundat) ;; handle padded runs - (not (dboard:rundat-run rundat))) - (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)) - (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) - (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 - ;; - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) - (if (and buttondat - (hash-table? testsdat-by-name)) - (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) - ;; (filter - ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) - ;; 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) - (else - teststate))) - (button (vector-ref columndat rown)) - (color (car (gutils:get-color-for-state-status teststate teststatus))) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 testdat) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - (dboard:tabdat-all-test-names tabdat))) - (set! coln (+ coln 1)))) - runs))) - -(define (mkstr . x) - (string-intersperse (map conc x) ",")) - -(define (set-bg-on-filter commondat tabdat) - (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%"))) - (hash-table-keys (dboard:tabdat-searchpatts tabdat)))))) - (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))))) - (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))))) - (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR" - (if (or search-changed - state-changed - status-changed) - "190 180 190" - "190 190 190" - )) - (dboard:tabdat-filters-changed-set! tabdat #t))) - -(define (update-search commondat tabdat x val) - (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) - (dboard:tabdat-filters-changed-set! tabdat #t) - (mark-for-update tabdat) - (set-bg-on-filter commondat tabdat)) - -;; force ALL updates to zero (effectively) -;; -(define (mark-for-update tabdat) - (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) - -;;====================================================================== -;; R U N C O N T R O L -;;====================================================================== - -;; target populating logic -;; -;; lb = -;; field = target field name for this dropdown -;; referent-vals = selected value in the left dropdown -;; targets = list of targets to use to build the dropdown -;; -;; each node is chained: key1 -> key2 -> key3 -;; -;; must select values from only apropriate targets -;; a b c -;; a d e -;; a b f -;; a/b => c f -;; -(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) - ;; is the current value in the new list? choose new default if not - (let* ((remvalues (map (lambda (row) - (common:list-is-sublist referent-vals (vector->list row))) - targets)) - (values (delete-duplicates (map car (filter list? remvalues)))) - (sel-valnum (iup:attribute lb "VALUE")) - (sel-val (iup:attribute lb sel-valnum)) - (val-num 1)) - ;; first check if the current value is in the new list, otherwise replace with - ;; first value from values - (iup:attribute-set! lb "REMOVEITEM" "ALL") - (for-each (lambda (val) - ;; (iup:attribute-set! lb "APPENDITEM" val) - (iup:attribute-set! lb (conc val-num) val) - (if (equal? sel-val val) - (iup:attribute-set! lb "VALUE" val-num)) - (set! val-num (+ val-num 1))) - values) - (let ((val (iup:attribute lb "VALUE"))) - (if val - val - (if (not (null? values)) - (let ((newval (car values))) - (iup:attribute-set! lb "VALUE" newval) - newval)))))) - -(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) - (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (rmt:get-targets)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. - (list->vector - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header))))) - (all-targets (append (list (munge-target (string-intersperse - (map (lambda (x) "%") header) - "/"))) - db-targets - (map munge-target - runconf-targs) - )) - (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) - (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes)) - (let loop ((key (car header)) - (remkeys (cdr header)) - (refvals '()) - (indx 0) - (lbs '())) - (let* ((lb (let ((lb (list-ref key-listboxes indx))) - (if lb - lb - (iup:listbox - #:size "x60" - #:fontsize "10" - #:expand "YES" ;; "VERTICAL" - ;; #:dropdown "YES" - #:editbox "YES" - #:action (lambda (obj a b c) - (debug:catch-and-dump action-proc "update-target-selector")) - #:caret_cb (lambda (obj a b c) - (debug:catch-and-dump action-proc "update-target-selector")) - )))) - ;; loop though all the targets and build the list for this dropdown - (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) - (if (null? remkeys) - ;; return a list of the listbox items and an iup:hbox with the labels and listboxes - (let* ((listboxes (append lbs (list lb))) - (res (list listboxes - (map (lambda (htxt lb) - (iup:vbox - (iup:label htxt) - lb)) - header - listboxes)))) - (dboard:tabdat-key-listboxes-set! tabdat res) - res) - (loop (car remkeys) - (cdr remkeys) - (append refvals (list selected-value)) - (+ indx 1) - (append lbs (list lb)))))))) - -;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string -;; interspersed with commas -;; -(define (dashboard:text-list-toggle-box items proc) - (let ((alltgls (make-hash-table))) - (apply iup:vbox - (map (lambda (item) - (iup:toggle - item - #:fontsize 8 - #:expand "YES" - #:action (lambda (obj tstate) - (debug:catch-and-dump - (lambda () - (if (eq? tstate 0) - (hash-table-delete! alltgls item) - (hash-table-set! alltgls item #t)) - (let ((all (hash-table-keys alltgls))) - (proc all))) - "text-list-toggle-box")))) - items)))) - -;; (print "Got here #3") - -;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed -;; -(define (dashboard:update-run-command tabdat) - (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) - (cmd (dboard:tabdat-command tabdat)) - (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) - (if (or (not tp) - (equal? tp "")) - "%" - tp))) - (states (dboard:tabdat-states tabdat)) - (statuses (dboard:tabdat-statuses tabdat)) - (target (let ((targ-list (dboard:tabdat-target tabdat))) - (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:tabdat-run-name tabdat)) - (states-str (if (or (not states) - (null? states)) - "" - (conc " -state " (string-intersperse states ",")))) - (statuses-str (if (or (not statuses) - (null? statuses)) - "" - (conc " -status " (string-intersperse statuses ",")))) - (full-cmd "megatest")) - (case (string->symbol cmd) - ((run) - (set! full-cmd (conc full-cmd - " -run" - " -testpatt " - test-patt - " -target " - target - " -runname " - run-name - " -clean-cache" - ))) - ((remove-runs) - (set! full-cmd (conc full-cmd - " -remove-runs -runname " - run-name - " -target " - target - " -testpatt " - test-patt - states-str - statuses-str - ))) - (else (set! full-cmd " no valid command "))) - (iup:attribute-set! cmd-tb "VALUE" full-cmd))) - -;; Display the tests as rows of boxes on the test/task pane -;; -(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) - (canvas-clear! cnv) - (canvas-font-set! cnv "Helvetica, -10") - (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - )) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; - -(define (dboard:target-updater tabdat) ;; key-listboxes) - (let ((targ (map (lambda (x) - (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector tabdat)))) - (curr-runname (dboard:tabdat-run-name tabdat))) - (dboard:tabdat-target-set! tabdat targ) - ;; (if (dboard:tabdat-updater-for-runs tabdat) - ;; ((dboard:tabdat-updater-for-runs tabdat))) - (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) - (equal? (dboard:tabdat-run-name tabdat) "")) - (dboard:tabdat-run-name-set! tabdat curr-runname)) - (dashboard:update-run-command tabdat))) - -;; used by run-controls -;; -(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) - (let* ((tb (dboard:tabdat-runs-tree tabdat)) - (runconf-targs (common:get-runconfig-targets)) - (db-target-dat (rmt:get-targets)) - (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) - (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. - (take (append (string-split x "/") - (make-list (length header) "na")) - (length header)))) - (all-targets (append (list (munge-target (string-intersperse - (map (lambda (x) "%") header) - "/"))) - (map vector->list db-targets) - (map munge-target - runconf-targs) - ))) - (for-each - (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)) - (hash-table-set! runs-tree-ht target #t)))) - all-targets))) - -;; Run controls panel -;; -(define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) - (let* ((targets (make-hash-table)) - (test-records (make-hash-table)) - (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) - (test-names (hash-table-keys all-tests-registry)) - (sorted-testnames #f) - (action "-run") - (cmdln "") - (runlogs (make-hash-table)) - ;;; (key-listboxes #f) - (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" - (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) - (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas - (test-patterns-textbox #f)) - (hash-table-set! tests-draw-state 'first-time #t) - ;; (hash-table-set! tests-draw-state 'scalef 1) - (tests:get-full-data test-names test-records '() all-tests-registry) - (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - - ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys - (let* ((result - (iup:vbox - (dcommon:command-execution-control tabdat) - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 200 - ;; - ;; (iup:split - ;; #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:split - #:orientation "HORIZONTAL" - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat)) - (iup:vbox - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals))) - ;; key-listboxes)) - (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) - (tb (dboard:tabdat-runs-tree tabdat))) - (dboard:commondat-add-updater - commondat - (lambda () - (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) - (dashboard:update-tree-selector tabdat))) - tab-num: tab-num) - result))) - - ;;(iup:frame - ;; #:title "Logs" ;; To be replaced with tabs - ;; (let ((logs-tb (iup:textbox #:expand "YES" - ;; #:multiline "YES"))) - ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) - ;; logs-tb)) - -;; browse runs as a tree. Used in both "Runs" tab and -;; in the runs control panel. -;; -(define (dboard:runs-tree-browser commondat tabdat) - (let* ((txtbox (iup:textbox - #:action (lambda (val a b) - (debug:catch-and-dump - (lambda () - ;; for the Runs view we put the list - ;; of keyvals into tabdat target for - ;; the Run Controls we put then update - ;; the run-command - (if b (dboard:tabdat-target-set! tabdat - (string-split b "/"))) - (dashboard:update-run-command tabdat)) - "command-testname-selector tb action")) - #:value (dboard:test-patt->lines - (dboard:tabdat-test-patts-use tabdat)) - #:expand "HORIZONTAL" - ;; #:size "10x30" - )) - (tb - (iup:treebox - #:value 0 - #:title "Runs" ;; was #:name -- iup 3.19 changed - ;; this... "Changed: [DEPRECATED - ;; REMOVED] removed the old attribute - ;; NAMEid from IupTree to avoid - ;; conflict with the common attribute - ;; NAME. Use the TITLEid attribute." - #:expand "YES" - #:addexpanded "YES" - #:size "10x" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? - ;; done below when run-id is a number - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print - ;; "run-path: - ;; " - ;; run-path) - (iup:attribute-set! txtbox "VALUE" - (string-intersperse (cdr run-path) "/")) - (dashboard:update-run-command tabdat) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - ;; capture last two in tabdat. - (dboard:tabdat-prev-run-id-set! - tabdat - (dboard:tabdat-curr-run-id tabdat)) - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-view-changed-set! tabdat #t)) - (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:detachbox - (iup:vbox - txtbox - tb - )))) - -;; browse runs as a tree. Used in both "Runs" tab and -;; in the runs control panel. -;; -;; THIS IS THE NEW ONE -;; -(define (dboard:runs-tree-new-browser commondat rdat) - (let* ((txtbox (iup:textbox - #:action (lambda (val a b) - (debug:catch-and-dump - (lambda () - ;; for the Runs view we put the list - ;; of keyvals into tabdat target for - ;; the Run Controls we put then update - ;; the run-command - (if b (dboard:rdat-targ-sql-filt-set! rdat - (string-split b "/"))) - #;(dashboard:update-run-command tabdat)) - "command-testname-selector tb action")) - ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? - ;; (dboard:tabdat-test-patts-use tabdat)) - #:expand "HORIZONTAL" - ;; #:size "10x30" - )) - (tb - (iup:treebox - #:value 0 - #:title "Runs" ;; was #:name -- iup 3.19 changed - ;; this... "Changed: [DEPRECATED - ;; REMOVED] removed the old attribute - ;; NAMEid from IupTree to avoid - ;; conflict with the common attribute - ;; NAME. Use the TITLEid attribute." - #:expand "YES" - #:addexpanded "YES" - #:size "10x" - #:selection-cb - (lambda (obj id state) - (debug:catch-and-dump - (lambda () - (let* ((run-path (tree:node->path obj id)) - (run-id (new-tree-path->run-id rdat (cdr run-path)))) - ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? - ;; done below when run-id is a number - (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print - ;; "run-path: - ;; " - ;; run-path) - (iup:attribute-set! txtbox "VALUE" - (string-intersperse (cdr run-path) "/")) - #;(dashboard:update-run-command tabdat) - #;(dboard:tabdat-layout-update-ok-set! tabdat #f) - (if (number? run-id) - (begin - ;; capture last two in tabdat. - (dboard:rdat-push-run-id rdat run-id) - (dboard:rdat-view-changed-set! rdat #t)) - (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) - "treebox")) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (dboard:rdat-runs-tree-set! rdat tb) - (iup:detachbox - (iup:vbox - txtbox - tb - )))) - -;;====================================================================== -;; R U N C O N T R O L S -;;====================================================================== -;; -;; A gui for launching tests -;; -(define (dashboard:run-times commondat tabdat #!key (tab-num #f)) - (let* ((drawing (vg:drawing-new)) - (run-times-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:run-times-tab-canvas-updater commondat tabdat tab-num) - (if (> (- now-time last-data-update) 5) - (if (not (dboard:tabdat-running-layout tabdat)) - (begin - (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (dboard:tabdat-last-data-update-set! tabdat now-time) - ;; this is threadified to return control to the gui for a redraw. - ;; it relies on the running-layout flag to prevent overlapping - ;; calls. - (thread-start! (make-thread - (lambda () - (dboard:tabdat-running-layout-set! tabdat #t) - (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - (dboard:tabdat-running-layout-set! tabdat #f)) - "run-times-tab-layout-updater"))) - )))))) - "dashboard:run-times-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 - - (dboard:runs-tree-browser commondat tabdat) - - (iup:hbox - (iup:toggle - "Compact layout" - #:fontsize 8 - #:expand "HORIZONTAL" - #:value 1 - #:action (lambda (obj tstate) - (debug:catch-and-dump - (lambda () - (print "tstate: " tstate) - (if (eq? tstate 0) - (dboard:tabdat-compact-layout-set! tabdat #f) - (dboard:tabdat-compact-layout-set! tabdat #t)) - (dboard:tabdat-last-filter-str-set! tabdat "") - ) - "text-list-toggle-box")))) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) - (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) - (let* ((hb1 (iup:hbox)) - (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) - (changed #f) - (graph-matrix (iup:matrix - #:alignment1 "ALEFT" - ;; #:expand "YES" ;; "HORIZONTAL" - #:scrollbar "YES" - #:numcol 10 - #:numlin 20 - #:numcol-visible 5 ;; (min 8) - #:numlin-visible 1 - #:click-cb - (lambda (obj row col status) - (let* - ((graph-cell (conc row ":" col)) - (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) - (graph-flag (dboard:graph-dat-flag graph-dat))) - (if graph-flag - (dboard:graph-dat-flag-set! graph-dat #f) - (dboard:graph-dat-flag-set! graph-dat #t)) - (if (not (dboard:tabdat-running-layout tabdat)) - (begin - (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) - (thread-start! (make-thread - (lambda () - (dboard:tabdat-running-layout-set! tabdat #t) - (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - (dboard:tabdat-running-layout-set! tabdat #f)) - "run-times-tab-layout-updater")))) - ;;(dboard:tabdat-view-changed-set! tabdat #t) - ))))) - (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) - (iup:attribute-set! graph-matrix "WIDTH0" 0) - (iup:attribute-set! graph-matrix "HEIGHT0" 0) - graph-matrix)) - (iup:hbox - (iup:vbox - (iup:button "Show All" #:action (lambda (obj) - (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 #t))) - (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) - (iup:hbox - (iup:button "Hide All" #:action (lambda (obj) - (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))))))) - )))) - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -;; (define (dboard:get-tests-dat tabdat run-id last-update) -;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) -;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run -;; run-id -;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") -;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() -;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() -;; #f #f ;; offset limit -;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in -;; #f #f ;; sort-by sort-order -;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval -;; (if (dboard:tabdat-filters-changed tabdat) -;; 0 -;; last-update) -;; *dashboard-mode*) -;; '()))) ;; get 'em all -;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) -;; (sort tdat (lambda (a b) -;; (let* ((aval (vector-ref a 2)) -;; (bval (vector-ref b 2)) -;; (anum (string->number aval)) -;; (bnum (string->number bval))) -;; (if (and anum bnum) -;; (< anum bnum) -;; (string<= aval bval))))))) - - -(define (dashboard:safe-cadr-assoc name lst) - (let ((res (assoc name lst))) - (if (and res (> (length res) 1)) - (cadr res) - #f))) - -(define (dboard:update-tree tabdat 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)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (changed #f) - (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))) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (for-each (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key) - (let ((val (db:get-value-by-header run-record runs-header key))) - (if (string? val) val ""))) - (dboard:tabdat-keys tabdat))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - ;; (let ((existing (tree:find-node tb run-path))) - ;; (if (not existing) - (begin - (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)) - ;; 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))) - -(define (dashboard:tests-ht->tests-dat tests-ht) - (reverse - (sort - (hash-table-values tests-ht) - (lambda (a b) - (let ((a-test-name (db:test-get-testname a)) - (a-item-path (db:test-get-item-path a)) - (b-test-name (db:test-get-testname b)) - (b-item-path (db:test-get-item-path b)) - (a-event-time (db:test-get-event_time a)) - (b-event-time (db:test-get-event_time b))) - (if (not (equal? a-test-name b-test-name)) - (> a-event-time b-event-time) - (cond - ((< 0 (string-compare3 a-test-name b-test-name)) #t) - ((> 0 (string-compare3 a-test-name b-test-name)) #f) - ((< 0 (string-compare3 a-item-path b-item-path)) #t) - (else #f)))))))) - - -(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) - (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (rmt:get-key-vals run-id)) - (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) - (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) - (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) - (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) - (when (not run) - (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) - (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) - ) - tests-mindat)) - -(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) - (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) - (dest-run-id (dboard:tabdat-curr-run-id tabdat))) - (if (and src-run-id dest-run-id) - (dcommon:xor-tests-mindat - (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) - hide-clean: hide-clean) - #f))) - - -(define (dashboard:get-runs-hash tabdat) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (last-runs-update 0);;(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 (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)) - - -(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 (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)) - (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)) - ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) - (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) - (when matrix-content - (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) - (row-indices (cadr indices)) - (col-indices (car indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window - (numrows 1) - (numcols 1) - (changed #f) - ) - - (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; Update the runs tree - ;; (dboard:update-tree tabdat runs-hash runs-header tb) - - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) - - (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) - (iup:attribute-set! run-matrix "NUMCOL" max-col )) - - (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) - (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) - (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - ;; (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - matrix-content) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (if (<= num max-col) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) - ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) - -;;====================================================================== -;; S U M M A R Y -;;====================================================================== -;; -;; General info about the run(s) and megatest area -(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 300 - (iup:frame - #:title "General Info" - (iup:vbox - (iup:hbox - (iup:label "Area Path") - (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - ))) - (iup:frame - #:title "Server" - (dcommon:servers-table commondat tabdat))) - (iup:frame - #:title "Megatest config settings" - (iup:hbox - (dcommon:section-matrix rawconfig "setup" "Varname" "Value") - (iup:vbox - (dcommon:section-matrix rawconfig "server" "Varname" "Value") - ;; (iup:frame - ;; #:title "Disks Areas" - (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) - (iup:frame - #:title "Run statistics" - (dcommon:run-stats commondat tabdat tab-num: tab-num))))) - -;;====================================================================== -;; H A N D L E U S E R C O N T R I B U T E D V I E W S -;;====================================================================== - -(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num) - (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. - (source (configf:lookup views-cfgdat view-name "source")) - (viewgen (configf:lookup views-cfgdat view-name "viewgen")) - (updater (configf:lookup views-cfgdat view-name "updater")) - (result-child #f)) - (if (and (common:file-exists? source) - (file-read-access? source)) - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") - (set! success #f)) - (load source)) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) - ;; now run the user supplied definition for the tab view - (if success - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen - ", with; tab-num=" tab-num ", view-name=" view-name - ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") - (set! success #f)) - (print "Adding tab " view-name " with proc " viewgen) - ;; (iup:child-add! tabs - (set! result-child - ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) - ;; and finally set the updater - (if success - (dboard:commondat-add-updater commondat - (lambda () - (handle-exceptions - exn - (begin - (print-call-chain) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater - "\", with; tabnum=" tab-num ", view-name=" view-name - ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") - (set! success #f)) - (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) - ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) - tab-num: tab-num)) - ;;(if success - ;; (begin - ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) - ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) - result-child)) - - - -(define (dboard:runs-summary-buttons-updater tabdat) - (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) - (modes-left (dboard:tabdat-runs-summary-modes tabdat))) - (if (or (null? buttons-left) (null? modes-left)) - #t - (let* ((this-button (car buttons-left)) - (mode-item (car modes-left)) - (this-mode (car mode-item)) - (sel-color "180 100 100") - (nonsel-color "170 170 170") - (current-mode (dboard:tabdat-runs-summary-mode tabdat))) - (if (eq? this-mode current-mode) - (iup:attribute-set! this-button "BGCOLOR" sel-color) - (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) - (loop (cdr buttons-left) (cdr modes-left)))))) - -(define (dboard:runs-summary-xor-labels-updater tabdat) - (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) - (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) - (mode (dboard:tabdat-runs-summary-mode tabdat))) - (when (and source-runname-label dest-runname-label) - (case mode - ((xor-two-runs xor-two-runs-hide-clean) - (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) - (prev-run-id (dboard:tabdat-prev-run-id tabdat)) - (curr-runname (if curr-run-id - (rmt:get-run-name-from-id curr-run-id) - "None")) - (prev-runname (if prev-run-id - (rmt:get-run-name-from-id prev-run-id) - "None"))) - (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) - (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) - (else - (iup:attribute-set! source-runname-label "TITLE" "") - (iup:attribute-set! dest-runname-label "TITLE" "")))))) - -(define (dboard:runs-summary-control-panel-updater tabdat) - (dboard:runs-summary-xor-labels-updater tabdat) - (dboard:runs-summary-buttons-updater tabdat)) - - -;; setup buttons and callbacks to switch between modes in runs summary tab -;; -(define (dashboard:runs-summary-control-panel tabdat) - (let* ((summary-buttons ;; build buttons - (map - (lambda (mode-item) - (let* ((this-mode (car mode-item)) - (this-mode-label (cdr mode-item))) - (iup:button this-mode-label - #:action - (lambda (obj) - (debug:catch-and-dump - (lambda () - (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) - (dboard:runs-summary-control-panel-updater tabdat)) - "runs summary control panel updater"))))) - (dboard:tabdat-runs-summary-modes tabdat))) - (summary-buttons-hbox (apply iup:hbox summary-buttons)) - (xor-runname-labels-hbox - (iup:hbox - (let ((temp-label - (iup:label "" #:size "125x15" #:fontsize "10" ))) - (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) - temp-label - ) - (let ((temp-label - (iup:label "" #:size "125x15" #:fontsize "10"))) - (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) - temp-label)))) - (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) - - ;; maybe wrap in a frame - (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) - (dboard:runs-summary-control-panel-updater tabdat) - res - ))) - - - -;;====================================================================== -;; R U N -;;====================================================================== -;; -;; display and manage a single run at a time - -;; This is the Run Summary tab -;; -(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" - #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." - #:expand "YES" - #:addexpanded "YES" - #: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)))) - (if (number? run-id) - (begin - (dboard:tabdat-prev-run-id-set! - tabdat - (dboard:tabdat-curr-run-id tabdat)) - - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - ;; (dashboard:update-run-summary-tab) - ) - ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) - ))) - "selection-cb in runs-summary") - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) - (cell-lookup (make-hash-table)) - (run-matrix (iup:matrix - #:expand "YES" - #:click-cb - - (lambda (obj lin col status) - (debug:catch-and-dump - (lambda () - - ;; Bummer - we dont have the global get/set api mapped in chicken - ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) - ;; (BB> "modkeys="modkeys)) - - (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) - ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES - (let* ((toolpath (car (argv))) - (key (conc lin ":" col)) - (test-id (hash-table-ref/default cell-lookup key -1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) - (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) - (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 - "%" - tpatt)) - "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) - (item-test-path (conc test-name "/" (if (equal? item-path "") - "%" - item-path))) - (status-chars (char-set->list (string->char-set status))) - (run-id (dboard:tabdat-curr-run-id tabdat))) - (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") - (cond - ((member #\1 status-chars) ;; 1 is left mouse button - (dboard:launch-testpanel run-id test-id)) - - ((member #\2 status-chars) ;; 2 is middle mouse button - - (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ) - (else - (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ) - ) - - )) "runs-summary-click-callback")))) - (runs-summary-updater - (lambda () - (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 - (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)) - ) - (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) - (dboard:tabdat-runs-tree-set! tabdat tb) - (iup:vbox - (iup:split - #:value 200 - tb - run-matrix) - (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) - -;;====================================================================== -;; 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 - #:title "filter test and items" - (iup:vbox - (iup:hbox - (iup:vbox - (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" - #:expand "NO" - #:action (lambda (obj unk val) - (debug:catch-and-dump - (lambda () - (mark-for-update tabdat) - (update-search commondat tabdat "test-name" val)) - "make-controls"))) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj) - (exit)) - #:expand "NO" #:size "40x15") - (iup:button "Refresh" #:action (lambda (obj) - (dboard:tabdat-last-data-update-set! tabdat 0) - (dboard:tabdat-last-runs-update-set! tabdat 0) - (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) - (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) - (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) - (dboard:tabdat-done-runs-set! tabdat '()) - (dboard:tabdat-not-done-runs-set! tabdat '()) - (dboard:tabdat-view-changed-set! tabdat #t) - (dboard:commondat-please-update-set! commondat #t) - (mark-for-update tabdat)) - #:expand "NO" #:size "40x15") - (iup:button "Collapse" #:action (lambda (obj) - (debug:catch-and-dump - (lambda () - (let ((myname (iup:attribute obj "TITLE"))) - (if (equal? myname "Collapse") - (begin - (for-each (lambda (tname) - (hash-table-set! *collapsed* tname #t)) - (dboard:tabdat-item-test-names tabdat)) - (iup:attribute-set! obj "TITLE" "Expand")) - (begin - (for-each (lambda (tname) - (hash-table-delete! *collapsed* tname)) - (hash-table-keys *collapsed*)) - (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update tabdat)) - "make-controls collapse button")) - #:expand "NO" #:size "40x15"))) - (iup:vbox - ;; (iup:button "Sort -t" #:action (lambda (obj) - ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - ;; (mark-for-update tabdat))) - - (let* ((hide #f) - (show #f) - (hide-empty #f) - (sel-color "180 100 100") - (nonsel-color "170 170 170") - (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) - (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" - #:size "80x15" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (set! *tests-sort-reverse* index) - (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 (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")) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (set! show (iup:button "Show" - #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" - #:action (lambda (obj) - (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "BGCOLOR" sel-color) - (iup:attribute-set! hide "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) - (iup:attribute-set! hide "BGCOLOR" sel-color) - (iup:attribute-set! show "BGCOLOR" nonsel-color) - ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... - (iup:vbox - (iup:hbox hide show) - sort-lb))) - ) - - ;; insert extra widget here - (if extra-widget - extra-widget - (iup:hbox)) ;; empty widget - - - - - ))) - - (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)) - -;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) -;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) -;; simple-run-event_time procedure (x3834) -;; simple-run-event_time-set! procedure (x3830 val3831) -;; simple-run-id procedure (x3794) -;; simple-run-id-set! procedure (x3790 val3791) -;; simple-run-owner procedure (x3826) -;; simple-run-owner-set! procedure (x3822 val3823) -;; simple-run-runname procedure (x3802) -;; simple-run-runname-set! procedure (x3798 val3799) -;; simple-run-state procedure (x3810) -;; simple-run-state-set! procedure (x3806 val3807) -;; simple-run-status procedure (x3818) -;; simple-run-status-set! procedure (x3814 val3815) -;; simple-run-target procedure (x3786) -;; simple-run-target-set! procedure (x3782 val3783) -;; simple-run? procedure (x3780) - -(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (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)) - (runs-browse-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)) - (header (make-vector nruns)) - (lftcol (make-vector ntests)) - (keycol (make-vector ntests)) - (controls (dboard:make-controls commondat runs-dat)) ;; '()) - (lftlst '()) - (hdrlst '()) - (bdylst '()) - (result '()) - (i 0) - (btn-height (dboard:tabdat-runs-btn-height runs-dat)) - (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat))) - ;; 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 - (map (lambda (x) - (let ((res (iup:hbox - #:expand "HORIZONTAL" - (iup:label x - #:size (conc 40 btn-height) - #:fontsize btn-fontsz - #:expand "NO") ;; "HORIZONTAL") - (iup:textbox - #:size (conc 35 btn-height) - #:fontsize btn-fontsz - #:value "%" - #:expand "NO" ;; "HORIZONTAL" - #:action (lambda (obj unk val) - ;; each field - ;; (field name is "x" var) live updates - ;; the search filter as it is typed - (dboard:tabdat-target-set! runs-dat #f) - ;; ensure fields text boxes are used - ;; and not the info from the tree - (mark-for-update runs-dat) - (update-search commondat runs-dat x val)))))) - (set! i (+ i 1)) - res)) - keynames))))) - (let loop ((testnum 0) - (res '())) - (cond - ((>= testnum ntests) - ;; now lftlst will be an hbox with the test keys and the test name labels - (set! lftlst - (append - lftlst - (list - (iup:hbox - #:expand "HORIZONTAL" - (iup:valuator - #:valuechanged_cb - (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) - (oldmax (string->number (iup:attribute obj "MAX"))) - (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) - (dboard:commondat-please-update-set! commondat #t) - (dboard:tabdat-start-test-offset-set! runs-dat - (inexact->exact (round (/ val 10)))) - (debug:print 6 *default-log-port* - "(dboard:tabdat-start-test-offset runs-dat) " - (dboard:tabdat-start-test-offset runs-dat) " val: " val - " newmax: " newmax " oldmax: " oldmax) - (if (< val 10) - (iup:attribute-set! obj "MAX" newmax)) - )) - #:expand "VERTICAL" - #:orientation "VERTICAL" - #:min 0 - #:step 0.01) - (apply iup:vbox (reverse res))))))) - (else - (let ((labl (iup:button - "" ;; the testname labels - #:flat "YES" - #:alignment "ALEFT" - ; #:image img1 - ; #:impress img2 - #:size (conc cell-width btn-height) - #:expand "HORIZONTAL" - #:fontsize btn-fontsz - #:action (lambda (obj) - (mark-for-update runs-dat) - (toggle-hide testnum (dboard:commondat-uidat commondat)))))) - (vector-set! lftcol testnum labl) - (loop (+ testnum 1)(cons labl res)))))) - ;; These are the headers for each row - (let loop ((runnum 0) - (keynum 0) - (keyvec (make-vector nkeys)) - (res '())) - (cond ;; nb// no else for this approach. - ((>= runnum nruns) #f) - ((>= keynum nkeys) - (vector-set! header runnum keyvec) - (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) - (loop (+ runnum 1) 0 (make-vector nkeys) '())) - (else - (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" - (vector-set! keyvec keynum labl) - (loop runnum (+ keynum 1) keyvec (cons labl res)))))) - ;; By here the hdrlst contains a list of vboxes containing nkeys labels - (let loop ((runnum 0) - (testnum 0) - (testvec (make-vector ntests)) - (res '())) - (cond - ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) - ((>= testnum ntests) - (vector-set! runsvec runnum testvec) - (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) - (loop (+ runnum 1) 0 (make-vector ntests) '())) - (else - (let* ((button-key (mkstr runnum testnum)) - (butn (iup:button - "" ;; button-key - #:size (conc cell-width btn-height ) - #:expand "HORIZONTAL" - #:fontsize btn-fontsz - #:button-cb - (lambda (obj a pressed x y btn . rem) - ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) - (if (substring-index "3" btn) - (if (eq? pressed 1) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header (db:get-rows run-info) - (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) - (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) - (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) - (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 - "%" - tpatt)) - "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) - (item-test-path (conc test-name "/" (if (equal? item-path "") - "%" - item-path)))) - (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu - #:x 'mouse - #:y 'mouse - #:modal? "NO") - ;; (print "got here") - )) - (if (eq? pressed 0) - (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3)))) - (dboard:launch-testpanel run-id test-id)))))))) - (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) - (vector-set! testvec testnum butn) - (loop runnum (+ testnum 1) testvec (cons butn res)))))) - ;; now assemble the hdrlst and bdylst and kick off the dialog - (iup:show - (iup:dialog - #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) - #:menu (dcommon:main-menu) - #:shrink "YES" - (let* ((runs-view (iup:vbox - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #: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)) - (dashboard:runs-horizontal-slider runs-dat)))) - controls - )) - (views-cfgdat (common:load-views-config)) - (additional-tabnames '()) - (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW - ;; (data (dboard:tabdat-init (make-d:data))) - (additional-views ;; process views-dat - (let ((tab-num tab-start-num) - (result '())) - (for-each - (lambda (view-name) - (debug:print 0 *default-log-port* "Adding view " view-name) - (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? - (if (not (string? cfgtype)) - (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name - "\" is missing needed sections. " - "Please consult the documenation and update ~/.mtviews.config or " - *toppath* "/.mtviews.config") - (case (string->symbol cfgtype) - ;; user supplied source for a tab - ;; - ((external) ;; was tabs - (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) - (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) - (set! tab-num (+ tab-num 1)) - (set! result (append result (list tab-content))))))))) - (sort (hash-table-keys views-cfgdat) - (lambda (a b) - (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) - (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) - (> order-a order-b))))) - result)) - (tabs (apply iup:tabs - #:shrink "YES" - #:tabchangepos-cb (lambda (obj curr prev) - (debug:catch-and-dump - (lambda () - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:tabdat-layout-update-ok-set! tabdat #f)) - (dboard:commondat-curr-tab-num-set! commondat curr) - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:commondat-please-update-set! commondat #t) - (dboard:tabdat-layout-update-ok-set! tabdat #t))) - "tabchangepos")) - (dashboard:summary commondat stats-dat tab-num: 0) - runs-view - ;; (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) - (dashboard:runs-browse commondat runs-browse-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" "Runs2") - (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 "TABTITLE3" "New View") - ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") - (iup:attribute-set! tabs "TABTITLE5" "Runs Browse") - - ;; set the tab names for user added tabs - (for-each - (lambda (tab-info) - (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) - additional-tabnames) - - (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - ;; make the iup tabs object available (for changing color for example) - (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) - ;; now set up the tabdat lookup - (dboard:common-set-tabdat! commondat 0 stats-dat) - (dboard:common-set-tabdat! commondat 1 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) - (dboard:common-set-tabdat! commondat 4 runtimes-dat) - (dboard:common-set-tabdat! commondat 5 runs-browse-dat) - - (iup:vbox - tabs - ;; controls - )))) - (vector keycol lftcol header runsvec))) - -(define (dboard:setup-num-rows tabdat) - (dboard:tabdat-num-tests-set! tabdat (string->number - (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS") - "15")))) - -(define *tim* (iup:timer)) -(define *ord* #f) -(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) -(iup:attribute-set! *tim* "RUN" "YES") - -(define *last-recalc-ended-time* 0) - -(define (dashboard:recalc modtime please-update-buttons last-db-update-time) - (or please-update-buttons - (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific - (> modtime (- last-db-update-time 3)) ;; add three seconds of margin - (> (current-seconds)(+ last-db-update-time 1))))) - -;; (define *monitor-db-path* #f) -(define *last-monitor-update-time* 0) - -;; Force creation of the db in case it isn't already there. -;; (tasks:open-db) - -(define (dashboard:get-youngest-run-db-mod-time dbdir) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " - ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc dbdir "/*.db*")))))) - -(define (dashboard:monitor-changed? commondat tabdat) - (let* ((run-update-time (current-seconds)) - (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) - (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) - (file-modification-time monitor-db-path) - -1))) - (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) - (or (> monitor-modtime *last-monitor-update-time*) - (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case - (begin - (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) - #t) - #f))) - -(define (dboard:get-last-db-update tabdat context) - (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) - -(define (dboard:set-last-db-update! tabdat context newtime) - (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) - -;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db -;; is closed (I think). If db dir starts with /tmp always return true -;; -(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) - (let* ((run-update-time (current-seconds)) - (dbdir (dboard:tabdat-dbdir tabdat)) - (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)))) - ;; (dboard:tabdat-last-db-update tabdat)))) - (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) - (dboard:commondat-please-update-set! commondat #f) - recalc)) - -;; point inside line -;; -(define-inline (dashboard:px-between px lx1 lx2) - (and (< lx1 px)(> lx2 px))) - -;;Not reference anywhere -;; -;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing -;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) -;; -(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) - (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) - (let loop ((i 0) - (rowdat (hash-table-ref/default rowhash rownum '()))) - (if (null? rowdat) - #f - (let rowloop ((bar (car rowdat)) - (tal (cdr rowdat))) - (let ((bx1 (car bar)) - (bx2 (cdr bar))) - (cond - ;; newbar x1 inside bar - ((dashboard:px-between x1 bx1 bx2) #t) - ((dashboard:px-between x2 bx1 bx2) #t) - ((and (<= x1 bx1)(>= x2 bx2)) #t) - (else (if (null? tal) - (if (< i lastrow) - (loop (+ i 1) - (hash-table-ref/default rowhash (+ rownum i) '())) - #f) - (rowloop (car tal)(cdr tal))))))))))) - -(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0)) - (let loop ((i 0)) - (hash-table-set! rowhash - (+ i rownum) - (cons (cons x1 x2) - (hash-table-ref/default rowhash (+ i rownum) '()))) - (if (< i num-rows) - (loop (+ i 1))))) - -;; sort a list of test-ids by the event _time using a hash table of id => testdat -;; -(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) - (sort test-ids - (lambda (a b) - (< (db:test-get-event_time (hash-table-ref tests-ht a)) - (db:test-get-event_time (hash-table-ref tests-ht b)))))) - -;; first group items into lists, then sort by time -;; finally sort by first item time -;; -;; NOTE: we are returning lists of lists of ids! -;; -(define (dboard:tests-sort-by-time-group-by-item testsdat) - (let ((test-ids (hash-table-keys testsdat))) - (if (null? test-ids) - test-ids - ;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ... - (let* ((test-ids-by-name - (let ((ht (make-hash-table))) - (for-each - (lambda (tdat) - (let ((testname (db:test-get-testname tdat)) - (test-id (db:test-get-id tdat))) - (hash-table-set! - ht - testname - (cons test-id (hash-table-ref/default ht testname '()))))) - (hash-table-values testsdat)) - ht))) - ;; remove toplevel tests from iterated tests, sort tests in the list by event time - (for-each - (lambda (testname) - (let ((tests-id-lst (hash-table-ref test-ids-by-name testname))) - (if (> (length tests-id-lst) 1) ;; must be iterated - (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests - (let ((tdat (hash-table-ref testsdat tid))) - (not (equal? (db:test-get-item-path tdat) "")))) - tests-id-lst))) - (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition - (hash-table-set! test-ids-by-name - testname - (dboard:sort-testsdat-by-event-time item-tests testsdat))))))) - (hash-table-keys test-ids-by-name)) - ;; finally sort by the event time of the first test - (sort (hash-table-values test-ids-by-name) - (lambda (a b) - (< (db:test-get-event_time (hash-table-ref testsdat (car a))) - (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) - -;; run times tab data updater -;; -(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((access-mode (dboard:tabdat-access-mode 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-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (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)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (tb (dboard:tabdat-runs-tree tabdat)) - (num-runs (length (hash-table-keys runs-hash))) - (update-start-time (current-seconds)) - (inc-mode #f)) - (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) - ;; fill in the tree - (if (and tb - (not inc-mode)) - (for-each - (lambda (run-id) - (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) - (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (dboard:tabdat-keys tabdat))) - (run-name (db:get-value-by-header run-record runs-header "runname")) - (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name)))) - ;; (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)) - ;; 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)) - ;; (print "Updating rundat") - (if (dboard:tabdat-keys tabdat) ;; have keys yet? - (let* ((num-keys (length (dboard:tabdat-keys tabdat))) - (targpatt (map (lambda (k v) - (list k v)) - (dboard:tabdat-keys tabdat) - (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") - '("%" "%")) - (make-list num-keys "%")) - num-keys) - )) - (runpatt (if (and (dboard:tabdat-target tabdat) - (list? (dboard:tabdat-target tabdat)) - (not (null? (dboard:tabdat-target tabdat)))) - (last (dboard:tabdat-target tabdat)) - "%")) - (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) - (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 "reseting 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)) - ;; (dboard:tabdat-allruns-set! tabdat '()) - (dboard:tabdat-max-row-set! tabdat 0) - (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) - (update-rundat tabdat - runpatt - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") - - targpatt - - ;; old method - ;; (let ((res '())) - ;; (for-each (lambda (key) - ;; (if (not (equal? key "runname")) - ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - ;; (if val (set! res (cons (list key val) res)))))) - ;; (dboard:tabdat-dbkeys tabdat)) - ;; res) - ))))) - -;; run times canvas updater -;; -(define (dashboard:run-times-tab-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))))) - -;; doesn't work. -;; -;;(define (gotoescape tabdat escape) -;; (or (dboard:tabdat-layout-update-ok tabdat) -;; (escape #t))) - -(define (dboard:graph-db-open dbstr) - (let* ((parts (string-split dbstr ":")) - (dbpth (if (< (length parts) 2) ;; assume then a filename was provided - dbstr - (if (equal? (car parts) "sqlite3") - (cadr parts) - (begin - (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) - #f))))) - (if (and dbpth (file-read-access? dbpth)) - (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) - (sqlite3:set-busy-handler! db (make-busy-timeout 10000)) - db) - #f))) - -;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... -;; -(define (dboard:graph-read-data cmdstring tstart tend) - (let* ((parts (string-split cmdstring))) ;; spaces not allowed - (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ... - (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring) - (let* ((dbdef (list-ref parts 0)) - (tablen (list-ref parts 1)) - (timef (list-ref parts 2)) - (varfn (list-ref parts 3)) - (valfn (list-ref parts 4)) - (fields (cdr (cddddr parts))) - (db (dboard:graph-db-open dbdef)) - (res-ht (make-hash-table))) - (if db - (begin - (for-each - (lambda (fieldname) ;; fields - (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) - (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) - (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) - (reverse - (sqlite3:fold-row - (lambda (res t var val) - (cons (vector t var val) res)) - '() db all-dat-qrystr))) - (let ((zeropt (handle-exceptions - exn - #f - (sqlite3:first-row db all-dat-qrystr)))) - (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. - (hash-table-set! res-ht - fieldname - (cons - (apply vector tstart (cdr zeropt)) - (hash-table-ref/default res-ht fieldname '()))))))) - fields) - res-ht) - #f))))) - -;; graph data -;; tsc=timescale, tfn=function; time->x -;; -(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) - (let* ((dwg (dboard:tabdat-drawing tabdat)) - (lib (vg:get/create-lib dwg "runslib")) - (cnv (dboard:tabdat-cnv tabdat)) - (dur (- tstart tend)) ;; time duration - (cmp (vg:get-component dwg "runslib" compname)) - (cfg (configf:get-section *configdat* "graph")) - (stdcolor (vg:rgb->number 120 130 140)) - (delta-y (- uly lly)) - (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) - (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) - (graph-matrix (dboard:tabdat-graph-matrix tabdat)) - (changed #f)) - (vg:add-obj-to-comp - cmp - (vg:make-rect-obj llx lly ulx uly)) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart))) - (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend))) - (let loop ((mark first) - (count 0)) - (let* ((smark (tfn mark)) ;; scale the mark - (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark - (label (conc (* count span) timesym))) ;; was mark-delta - (if (> count 2) - (begin - (vg:add-obj-to-comp - cmp - (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly)) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- smark 1)(- lly 10) label)))) - (if (< mark (- tend time-blk)) - (loop (+ mark time-blk)(+ count 1)))))) - (for-each - (lambda (cf) - (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) - (if alldat - (for-each - (lambda (fieldn) - (let*-values (((dat) (hash-table-ref alldat fieldn)) - ((vals minval maxval) (if (null? dat) - (values '() #f #f) - (let loop ((hed (car dat)) - (tal (cdr dat)) - (res '()) - (min (vector-ref (car dat) 2)) - (max (vector-ref (car dat) 2))) - (let* ((val (vector-ref hed 2)) - (newmin (if (< val min) val min)) - (newmax (if (> val max) val max)) - (newres (cons val res))) - (if (null? tal) - (values (reverse res) (- newmin 2) (+ newmax 2)) - (loop (car tal)(cdr tal) newres newmin newmax))))))) - (if (not (hash-table-exists? graph-matrix-table fieldn)) - (begin - (let* ((graph-color-rgb (vg:generate-color-rgb)) - (graph-color (vg:iup-color->number graph-color-rgb)) - (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) - (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) - (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) - (graph-dat (make-dboard:graph-dat - id: fieldn - color: graph-color - flag: #t - cell: graph-cell - ))) - (hash-table-set! graph-matrix-table fieldn graph-dat) - (hash-table-set! graph-cell-table graph-cell graph-dat) - ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") - ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") - (set! changed #t) - (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) - (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) - (if (> graph-matrix-col 10) - (begin - (dboard:tabdat-graph-matrix-col-set! tabdat 1) - (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) - (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) - ))) - (if (not (null? vals)) - (let* (;; (maxval (apply max vals)) - ;; (minval (min 0 (apply min vals))) - (yoff (- minval lly)) ;; minval)) - (deltaval (- maxval minval)) - (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) - (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) - (graph-dat (hash-table-ref graph-matrix-table fieldn)) - (graph-color (dboard:graph-dat-color graph-dat)) - (graph-flag (dboard:graph-dat-flag graph-dat))) - (if graph-flag - (begin - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) - (vg:add-obj-to-comp - cmp - (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) - (fold - (lambda (next prev) ;; #(time ? val) #(time ? val) - (if prev - (let* ((yval (vector-ref prev 2)) - (yval-next (vector-ref next 2)) - (last-tval (tfn (vector-ref prev 0))) - (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) - (next-yval (yfunc yval-next)) - (curr-tval (tfn (vector-ref next 0)))) - (if (>= curr-tval last-tval) - (begin - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj last-tval last-yval curr-tval last-yval - line-color: graph-color)) - (vg:add-obj-to-comp - cmp - ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) - (vg:make-line-obj curr-tval last-yval curr-tval next-yval - line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) - next) - #f ;; (vector tstart minval minval) - dat) - )))))) ;; for each data point in the series - (hash-table-keys alldat))))) - cfg) - (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) - -;; run times tab -;; -(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) - ;; each test is an object in the run component - ;; each run is a component - ;; all runs stored in runslib library - (let escapeloop ((escape #f)) - (if (and (not escape) - tabdat) - (let* ((canvas-margin 10) - (not-done-runs (dboard:tabdat-not-done-runs tabdat)) - (mtx (dboard:tabdat-runs-mutex tabdat)) - (drawing (dboard:tabdat-drawing tabdat)) - (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib - (allruns (dboard:tabdat-allruns tabdat)) - (num-runs (length allruns)) - (cnv (dboard:tabdat-cnv tabdat)) - (compact-layout (dboard:tabdat-compact-layout tabdat)) - (row-height (if compact-layout 2 10)) - (graph-height 120) - (run-to-run-margin 25)) - (dboard:tabdat-layout-update-ok-set! tabdat #t) - (if (and (canvas? cnv) - (not (null? allruns))) ;; allruns can go null when browsing the runs tree - (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) - ((originx originy) (canvas-origin cnv)) - ((calc-y) (lambda (rownum) - (- (/ sizey 2) - (* rownum row-height)))) - ((fixed-originx) (if (dboard:tabdat-originx tabdat) - (dboard:tabdat-originx tabdat) - (begin - (dboard:tabdat-originx-set! tabdat originx) - originx))) - ((fixed-originy) (if (dboard:tabdat-originy tabdat) - (dboard:tabdat-originy tabdat) - (begin - (dboard:tabdat-originy-set! tabdat originy) - originy)))) - ;; (print "allruns: " allruns) - (let runloop ((rundat (car allruns)) - (runtal (cdr allruns)) - (run-num 1) - (doneruns '())) - (let* ((run (dboard:rundat-run rundat)) - (rowhash (make-hash-table)) ;; store me in tabdat - (key-val-dat (dboard:rundat-key-vals rundat)) - (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 x x ""))))) - (run-key (string-intersperse key-vals "\n")) - (run-full-name (string-intersperse key-vals "/")) - (curr-run-start-row (dboard:tabdat-max-row tabdat))) - ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row) - (if (not (vg:lib-get-component runslib run-full-name)) - (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible. - (not (dboard:rundat-hierdat rundat))) - (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids - (dboard:rundat-hierdat-set! rundat hd) - hd) - (dboard:rundat-hierdat rundat))) - (tests-ht (dboard:rundat-tests rundat)) - (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat - (testsdat (hash-table-values tests-ht)) - (runcomp (vg:comp-new));; new component for this run - (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) - ;; (row-height 4) - (run-start (common:min-max < (map db:test-get-event_time testsdat))) - (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) - (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero - (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) - (run-duration (- run-end run-start)) - (timescale (/ (- sizex (* 2 canvas-margin)) - (if (> run-duration 0) - run-duration - (current-seconds)))) ;; a least lously guess - (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))) - (num-tests (length hierdat)) - (tot-tests (length testsdat)) - (width (* timescale run-duration)) - (graph-lly (calc-y (/ -50 row-height))) - (graph-uly (- (calc-y 0) canvas-margin)) - (sec-per-50pt (/ 50 timescale)) - ) - ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) - ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) - (mutex-lock! mtx) - (vg:add-comp-to-lib runslib run-full-name runcomp) - ;; Have to keep moving the instantiated box as it is anchored at the lower left - ;; this should have worked for x in next statement? (maptime run-start) - ;; add 60 to make room for the graph - (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) - (mutex-unlock! mtx) - ;; (set! run-start-row (+ max-row 2)) - ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) - ;; get tests in list sorted by event time ascending - (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) - (tests-tal (cdr hierdat)) - (test-num 1)) - (let ((iterated (> (length test-ids) 1)) - (first-rownum #f) - (num-items (length test-ids))) - (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items - (tidstal (cdr test-ids)) - (item-num 1) - (test-objs '())) - (let* ((testdat (hash-table-ref tests-ht test-id)) - (event-time (maptime (db:test-get-event_time testdat))) - (test-duration (* timescale (db:test-get-run_duration testdat))) - (end-time (+ event-time test-duration)) - (test-name (db:test-get-testname testdat)) - (item-path (db:test-get-item-path testdat)) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (test-fullname (conc test-name "/" item-path)) - (name-color (gutils:get-color-for-state-status state status)) - (new-test-objs - (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1))) - (if (dashboard:row-collision rowhash rownum event-time end-time) - (loop (+ rownum 1)) - (let* ((title (if iterated (if compact-layout #f item-path) test-name)) - (lly (calc-y rownum)) ;; (- sizey (* rownum row-height))) - (uly (+ lly row-height)) - (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on - (obj (vg:make-rect-obj event-time lly use-end uly - fill-color: (vg:iup-color->number (car name-color)) - text: title - font: "Helvetica -10")) - (bar-end (max use-end - (+ event-time - (if compact-layout - 1 - (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter - ;; (if iterated - ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) - ;; (if (not first-rownum) - ;; (begin - ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) - ;; (set! first-rownum rownum))) - (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum) - (dboard:tabdat-max-row tabdat))) ;; track the max row used - ;; bar-end has some margin for text - accounting for text in extents not yet working. - (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5)) - (vg:add-obj-to-comp runcomp obj) - ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) - (dboard:tabdat-view-changed-set! tabdat #t) - (cons obj test-objs)))))) - ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) - ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) - (if (> item-num 50) - (if (eq? 0 (modulo item-num 50)) - (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) - ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) - (let ((newdoneruns (cons rundat doneruns))) - (if (null? tidstal) - (if iterated - (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) - (llx (- (car xtents) 10)) - (lly (- (cadr xtents) 10)) - (ulx (+ 5 (caddr xtents))) - (uly (+ 10 (cadddr xtents)))) - ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items) - ;; This is the box around the tests of an iterated test - (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly - text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids))) - line-color: (vg:rgb->number 0 0 255 a: 128) - font: "Helvetica -10")) - ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) - (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw - (if (dboard:tabdat-layout-update-ok tabdat) - (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))) - ;; If it is an iterated test put box around it now. - (if (not (null? tests-tal)) - (if #f ;; (> (- (current-seconds) update-start-time) 5) - (print "drawing runs taking too long") - (if (dboard:tabdat-layout-update-ok tabdat) - (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))) - ;; placeholder box - (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) - ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) - ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) - ;; instantiate the component - (let* ((extents (vg:components-get-extents drawing runcomp)) - (new-xtnts (apply vg:grow-rect 5 5 extents)) - (llx (list-ref new-xtnts 0)) - (lly (list-ref new-xtnts 1)) - (ulx (list-ref new-xtnts 2)) - (uly (list-ref new-xtnts 3)) - (outln (vg:make-rect-obj -5 lly ulx uly - text: run-full-name - line-color: (vg:rgb->number 255 0 255 a: 128)))) - ; (vg:components-get-extents d1 c1))) - ;; this is the box around the run - (mutex-lock! mtx) - (vg:add-obj-to-comp runcomp outln) - (mutex-unlock! mtx) - ;; this is where we have enough info to place the graph - (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) - (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) - ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) - )) - ;; end of the run handling loop - (if (not (dboard:tabdat-layout-update-ok tabdat)) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - (let ((newdoneruns (cons rundat doneruns))) - (if (null? runtal) - (begin - (dboard:rundat-data-changed-set! rundat #f) - (dboard:tabdat-not-done-runs-set! tabdat '()) - (dboard:tabdat-done-runs-set! tabdat allruns)) - (if #f ;; (> (- (current-seconds) update-start-time) 5) - (begin - (print "drawing runs taking too long.... have " (length runtal) " remaining") - ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! - ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) - (dboard:tabdat-not-done-runs-set! tabdat runtal)) - (begin - (if (dboard:tabdat-layout-update-ok tabdat) - (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) - (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) - ))))))))) ;; new-run-start-row - ))) - (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) - -;; handy trick for printing a record -;; -;; (pp (dboard:tabdat->alist tabdat)) -;; -;; removing the tabdat-values proc -;; -;; (define (tabdat-values tabdat) - -;; runs update-rundat using the various filters from the gui -;; -(define (dashboard:do-update-rundat tabdat) - (dboard:update-rundat - tabdat - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - (dboard:tabdat-numruns tabdat) - (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") - ;; generate key patterns from the target stored in tabdat - (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) - (let ((fres (if (dboard:tabdat-target tabdat) - (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) - (map (lambda (k v)(list k v)) dbkeys ptparts)) - (let ((res '())) - (for-each (lambda (key) - (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) - (if val (set! res (cons (list key val) res)))))) - dbkeys) - res)))) - fres)))) - -(define (dashboard:runs-tab-updater commondat tab-num) - (debug:catch-and-dump - (lambda () - (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) - (dbkeys (dboard:tabdat-dbkeys tabdat))) - (dashboard:do-update-rundat tabdat) - (let ((uidat (dboard:commondat-uidat commondat))) - (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) - )) - "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -61,1424 +61,5 @@ ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) -;;====================================================================== -;; C O M M O N D A T A S T R U C T U R E -;;====================================================================== -;; -;; data common to all tabs goes here -;; -(defstruct dboard:commondat - ((curr-tab-num 0) : number) - please-update - tabdats - update-mutex - updaters - updating - uidat ;; needs to move to tabdat at some time - hide-not-hide-tabs - ) - -(define (dboard:commondat-make) - (make-dboard:commondat - curr-tab-num: 0 - tabdats: (make-hash-table) - please-update: #t - update-mutex: (make-mutex) - updaters: (make-hash-table) - updating: #f - hide-not-hide-tabs: #f - )) - -;; RADT => Matrix defstruct addition -(defstruct dboard:graph-dat - ((id #f) : string) - ((color #f) : vector) - ((flag #t) : boolean) - ((cell #f) : number) - ) - -;; data for runs, tests etc. was used in run summary? -;; -(defstruct dboard:runsdat - ;; new system - runs-index ;; target/runname => colnum - tests-index ;; testname/itempath => rownum - matrix-dat ;; vector of vectors rows/cols - ) - -(define (dboard:runsdat-make-init) - (make-dboard:runsdat - runs-index: (make-hash-table) - tests-index: (make-hash-table) - matrix-dat: (make-sparse-array))) - -;; used to keep the rundata from rmt:get-tests-for-run -;; in sync. -;; -(defstruct dboard:rundat - run - tests-drawn ;; list of id's already drawn on screen - tests-notdrawn ;; list of id's NOT already drawn - rowsused ;; hash of lists covering what areas used - replace with quadtree - 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 - ((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)) - - -;;====================================================================== -;; D O T F I L E -;;====================================================================== - -(define (dcommon:write-dotfile fname dat) - (with-output-to-file fname - (lambda () - (pp dat)))) - -;;====================================================================== -;; TARGET AND PATTERN MANIPULATIONS -;;====================================================================== - -;; Convert to and from list of lines (for a text box) -;; "," => "\n" -(define (dboard:test-patt->lines test-patt) - (string-substitute (regexp ",") "\n" test-patt)) - -(define (dboard:lines->test-patt lines) - (string-substitute (regexp "\n") "," lines #t)) - - -;;====================================================================== -;; P R O C E S S R U N S -;;====================================================================== - -;; MOVE THIS INTO *data* -(define *cachedata* (make-hash-table)) -(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) -(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) - -;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise -;; -(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) - (let ((curr-val (iup:attribute mtrx cell-name))) - (if (not (equal? curr-val new-val)) - (begin - (iup:attribute-set! mtrx cell-name new-val) ;; was col-name - #t) ;; need a re-draw - prev-changed))) - - -;; TO-DO -;; 1. Make "data" hash-table hierarchial store of all displayed data -;; 2. Update synchash to understand "get-runs", "get-tests" etc. -;; 3. Add extraction of filters to synchash calls -;; -;; NOTE: Used in newdashboard -;; -;; Mode is 'full or 'incremental for full refresh or incremental refresh -;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) -;; (let* (;; count and offset => #f so not used -;; ;; the synchash calls modify the "data" hash -;; (changed #f) -;; (get-runs-sig (conc (client:get-signature) " get-runs")) -;; (get-tests-sig (conc (client:get-signature) " get-tests")) -;; (get-details-sig (conc (client:get-signature) " get-test-details")) -;; -;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash -;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) -;; ;; run-id is #f in next line to send the query to server 0 -;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) -;; (tests-detail-changes (if (not (null? test-ids)) -;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) -;; '())) -;; -;; ;; Now can calculate the run-ids -;; (run-hash (hash-table-ref/default data get-runs-sig #f)) -;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) -;; -;; (all-test-changes (let ((res (make-hash-table))) -;; (for-each (lambda (run-id) -;; (if (> run-id 0) -;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) -;; run-ids) -;; res)) -;; (runs-hash (hash-table-ref/default data get-runs-sig #f)) -;; (header (hash-table-ref/default runs-hash "header" #f)) -;; (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)) -;; (time-a (db:get-value-by-header record-a header "event_time")) -;; (time-b (db:get-value-by-header record-b header "event_time"))) -;; (> time-a time-b))) -;; )) -;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) -;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) -;; (colnum 1) -;; (rownum 0) -;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header -;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) -;; -;; ;; tests related stuff -;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) -;; -;; ;; Given a run-id and testname/item_path calculate a cell R:C -;; -;; ;; NOTE: Also build the test tree browser and look up table -;; ;; -;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum -;; (for-each (lambda (run-id) -;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) -;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) -;; keys)) -;; (run-name (db:get-value-by-header run-record header "runname")) -;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) -;; (run-path (append key-vals (list run-name)))) -;; (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)) -;; 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 -;; ;; Do this analysis in the order of the run-ids, the most recent run wins -;; (for-each (lambda (run-id) -;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) -;; (test-changes (hash-table-ref all-test-changes run-id)) -;; (new-test-dat (car test-changes)) -;; (removed-tests (cadr test-changes)) -;; (tests (sort (map cadr (filter (lambda (testrec) -;; (eq? run-id (db:mintest-get-run_id (cadr testrec)))) -;; new-test-dat)) -;; (lambda (a b) -;; (let ((time-a (db:mintest-get-event_time a)) -;; (time-b (db:mintest-get-event_time b))) -;; (> time-a time-b))))) -;; ;; test-changes is a list of (( id record ) ... ) -;; ;; Get list of test names sorted by time, remove tests -;; (test-names (delete-duplicates (map (lambda (t) -;; (let ((i (db:mintest-get-item_path t)) -;; (n (db:mintest-get-testname t))) -;; (if (string=? i "") -;; (conc " " i) -;; n))) -;; tests))) -;; (colnum (car (hash-table-ref runid-to-col run-id)))) -;; ;; for each test name get the slot if it exists and fill in the cell -;; ;; or take the next slot and fill in the cell, deal with items in the -;; ;; run view panel? The run view panel can have a tree selector for -;; ;; browsing the tests/items -;; -;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY -;; (for-each (lambda (test) -;; (let* ((test-id (db:mintest-get-id test)) -;; (state (db:mintest-get-state test)) -;; (status (db:mintest-get-status test)) -;; (testname (db:mintest-get-testname test)) -;; (itempath (db:mintest-get-item_path test)) -;; (fullname (conc testname "/" itempath)) -;; (dispname (if (string=? itempath "") testname (conc " " itempath))) -;; (rownum (hash-table-ref/default testname-to-row fullname #f)) -;; (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" -;; test-path -;; userdata: (conc "test-id: " test-id)) -;; (let ((node-num (tree:find-node tb (cons "Runs" 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 -;; (conc "COLOR" node-num) -;; color changed)) -;; -;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) -;; ) -;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id) -;; (if (not rownum) -;; (let ((rownums (hash-table-values testname-to-row))) -;; (set! rownum (if (null? rownums) -;; 1 -;; (+ 1 (common:max rownums)))) -;; (hash-table-set! testname-to-row fullname rownum) -;; ;; create the label -;; (set! changed (dcommon:modifiy-if-different -;; (dboard:tabdat-runs-matrix data) -;; (conc rownum ":" 0) -;; dispname -;; changed)) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) -;; ;; (conc rownum ":" 0) dispname) -;; )) -;; ;; set the cell text and color -;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) -;; (set! changed (dcommon:modifiy-if-different -;; (dboard:tabdat-runs-matrix data) -;; (conc rownum ":" colnum) -;; (if (member state '("ARCHIVED" "COMPLETED")) -;; status -;; state) -;; changed)) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) -;; ;; (conc rownum ":" colnum) -;; ;; (if (member state '("ARCHIVED" "COMPLETED")) -;; ;; status -;; ;; state)) -;; (set! changed (dcommon:modifiy-if-different -;; (dboard:tabdat-runs-matrix data) -;; (conc "BGCOLOR" rownum ":" colnum) -;; (car (gutils:get-color-for-state-status state status)) -;; changed)) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) -;; ;; (conc "BGCOLOR" rownum ":" colnum) -;; ;; (car (gutils:get-color-for-state-status state status))) -;; )) -;; tests))) -;; run-ids) -;; -;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) -;; (if updater (updater (hash-table-ref/default data get-details-sig #f)))) -;; -;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) -;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) -;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) -;; (list run-changes all-test-changes))) - -#;(define (dcommon:runsdat-get-col-num dat target runname force-set) - (let* ((runs-index (dboard:runsdat-runs-index dat)) - (col-name (conc target "/" runname)) - (res (hash-table-ref/default runs-index col-name #f))) - (if res - res - (if force-set - (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) - (hash-table-set! runs-index col-name max-col-num) - max-col-num))))) - -#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) - (let* ((tests-index (dboard:runsdat-runs-index dat)) - (row-name (conc testname "/" itempath)) - (res (hash-table-ref/default runs-index row-name #f))) - (if res - res - (if force-set - (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) - (hash-table-set! runs-index row-name max-row-num) - max-row-num))))) - -(define (dcommon:rundat-copy-tests-to-by-name rundat) - (let ((src-ht (dboard:rundat-tests rundat)) - (trg-ht (dboard:rundat-tests-by-name rundat))) - (if (and (hash-table? src-ht)(hash-table? trg-ht)) - (begin - (hash-table-clear! trg-ht) - (for-each - (lambda (testdat) - (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) - (hash-table-values src-ht))) - (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) - - -;;====================================================================== -;; TESTS DATA -;;====================================================================== - -;; Produce a list of lists ready for common:sparse-list-generate-index -;; -(define (dcommon:minimize-test-data tests-dat) - (if (null? tests-dat) - '() - (let loop ((hed (car tests-dat)) - (tal (cdr tests-dat)) - (res '())) - (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations - (test-name (db:test-get-testname hed)) - (item-path (db:test-get-item-path hed)) - (state (db:test-get-state hed)) - (status (db:test-get-status hed)) - (event-time (db:test-get-event_time hed)) - (newitem (list test-name item-path (list test-id state status event-time)))) - (if (null? tal) - (reverse (cons newitem res)) - (loop (car tal)(cdr tal)(cons newitem res))))))) - -(define (dcommon:tests-mindat->hash tests-mindat) - (let* ((res (make-hash-table))) - (for-each - (lambda (item) - (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) - (value (list-ref item 2))) - (hash-table-set! res test-name+item-path value))) - tests-mindat) - res)) - -;; return 1 if status1 is better -;; return 0 if status1 and 2 are equally good -;; return -1 if status2 is better -(define (dcommon:status-compare3 status1 status2) - (let* - ((status-goodness-ranking (cdr ;; cdr to drop first item -- "n/a" - (append (map cadr *common:std-statuses*) - '(#f)) ;; algorithm requres last item to be #f - ) ) - (mem1 (member status1 status-goodness-ranking)) - (mem2 (member status2 status-goodness-ranking)) - ) - (cond - ((and (not mem1) (not mem2)) 0) - ((not mem1) -1) - ((not mem2) 1) - ((= (length mem1) (length mem2)) 0) - ((> (length mem1) (length mem2)) 1) - (else -1)))) - -(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) - (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) - (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) - (all-keys - (reverse (sort - (delete-duplicates - (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) - - (lambda (a b) - (cond - ((< 0 (string-compare3 (car a) (car b))) #t) - ((> 0 (string-compare3 (car a) (car b))) #f) - ((< 0 (string-compare3 (cdr a) (cdr b))) #t) - (else #f))) - - )))) - (let ((res - (map ;; TODO: rename xor to delta globally in dcommon and dashboard - (lambda (key) - (let* ((test-name (car key)) - (item-path (cdr key)) - - (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) - (dest-test-id (if dest-value (list-ref dest-value 0) #f)) - (dest-state (if dest-value (list-ref dest-value 1) #f)) - (dest-status (if dest-value (list-ref dest-value 2) #f)) - - (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) - (src-test-id (if src-value (list-ref src-value 0) #f)) - (src-state (if src-value (list-ref src-value 1) #f)) - (src-status (if src-value (list-ref src-value 2) #f)) - - (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete - - (dest-complete - (and dest-value dest-state dest-status - (equal? dest-state "COMPLETED") - (not (member dest-status incomplete-statuses)))) - (src-complete - (and src-value src-state src-status - (equal? src-state "COMPLETED") - (not (member src-status incomplete-statuses)))) - (status-compare-result (dcommon:status-compare3 src-status dest-status)) - (xor-new-item - (cond - ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) - ;; neither complete -> bad - - ;; src !complete, dest complete -> better - ((and (not dest-complete) (not src-complete)) - (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) - ((not dest-complete) - (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) - ((not src-complete) - (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) - ((and - (equal? src-state dest-state) - (equal? src-status dest-status)) - (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) - ;; better or worse: pass > warn > waived > skip > fail > abort - ;; pass > warn > waived > skip > fail > abort - - ((= 1 status-compare-result) ;; src is better, dest is worse - (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) - (else - (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) - ))) - (list test-name item-path xor-new-item))) - all-keys))) - - (if hide-clean - (filter - (lambda (item) - ;;(print item) - (not - (equal? - "CLEAN" - (list-ref (list-ref item 2) 1)))) - res) - res)))) - -(define (dcommon:examine-xterm run-id test-id) - (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) - (if (not testdat) - (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) - (let* - ((rundir (if testdat - (db:test-get-rundir testdat) - (current-directory))) ;; logfile)) - (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) - (xterm (lambda () - (if (directory-exists? rundir) - (let* ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - "")) - (command (conc "cd " rundir - ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (print "Command =" command) - (common:without-vars - command - "MT_.*")) - (message-window (conc "Directory " rundir " not found")))))) - (xterm) - (print "Adding xterm code"))))) - -;;====================================================================== -;; D A T A T A B L E S -;;====================================================================== - -;; Table of keys -(define (dcommon:keys-matrix rawconfig) - (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig "fields")) - (keys-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (length key-vals) - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) - ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") - (iup:attribute-set! keys-matrix "WIDTH0" 0) - (iup:attribute-set! keys-matrix "0:1" "Key Name") - ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") - ;; fill in keys - (for-each - (lambda (var) - ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) - (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) - (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) - key-vals) - (iup:attribute-set! keys-matrix "WIDTHDEF" "40") - keys-matrix)) - -;; Section to table -(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" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (min 10 (length key-vals)) - #:scrollbar "YES"))) - (iup:attribute-set! section-matrix "0:0" varcolname) - (iup:attribute-set! section-matrix "0:1" valcolname) - (iup:attribute-set! section-matrix "WIDTH1" "200") - ;; fill in keys - (for-each - (lambda (var) - ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) - (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) - (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) - (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) - key-vals) - (iup:vbox - (iup:label (if title title (conc "Settings from [" sectionname "]")) - ;; #:size "5x" - #:expand "HORIZONTAL" - ) - section-matrix))) - -;; General data -;; -(define (dcommon:general-info) - (let ((general-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" - #:numcol 1 - #:numlin 2 - #:numcol-visible 1 - #:numlin-visible 2))) - (iup:attribute-set! general-matrix "WIDTH1" "150") - (iup:attribute-set! general-matrix "0:1" "About this Megatest area") - ;; User (this is not always obvious - it is common to run as a different user - (iup:attribute-set! general-matrix "1:0" "User") - (iup:attribute-set! general-matrix "1:1" (current-user-name)) - ;; Megatest area - ;; (iup:attribute-set! general-matrix "2:0" "Area") - ;; (iup:attribute-set! general-matrix "2:1" *toppath*) - ;; Megatest version - (iup:attribute-set! general-matrix "2:0" "Version") - (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) - - general-matrix)) - -(define (dcommon:stats-updater commondat tabdat stats-matrix) - (if (and (iup:ihandle? stats-matrix) - (dashboard:database-changed? commondat tabdat context-key: 'run-stats)) - (let* ((changed #f) - (run-stats (rmt:get-run-stats)) - (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) - (row-indices (car indices)) - (col-indices (cadr indices)) - (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) - (max-col (if (null? col-indices) 1 - (common:max (map cadr col-indices)))) - (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) - (max-col-vis (if (> max-col 10) 10 max-col)) - (numrows 1) - (numcols 1)) - (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") - (iup:attribute-set! stats-matrix "NUMCOL" max-col ) - (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 - (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) - (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - ;;(print "row-indices: " row-indices " col-indices: " col-indices) - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute stats-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key name))))) - row-indices) - - ;; Col labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute stats-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key name))))) - col-indices) - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (car entry)) - (col-name (cadr entry)) - (value (caddr entry)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (if (not (equal? (iup:attribute stats-matrix key) value)) - (begin - (set! changed #t) - (iup:attribute-set! stats-matrix key value))))) - run-stats) - (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))) - - -(define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) - (let* ((stats-matrix (iup:matrix expand: "YES")) - (stats-updater (lambda () - (dcommon:stats-updater commondat tabdat stats-matrix)))) - ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass - ;; (mark-for-update tabdat) - ;; (stats-updater) - (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num) - ;; (set! dashboard:update-summary-tab updater) - (iup:attribute-set! stats-matrix "WIDTHDEF" "40") - (iup:vbox - ;; (iup:label "Run statistics" #:expand "HORIZONTAL") - stats-matrix))) - -(define (dcommon:servers-table commondat tabdat) - (let* ((colnum 0) - (rownum 0) - (servers-matrix (iup:matrix #:expand "YES" - #:numcol 7 - #:numcol-visible 7 - #:numlin-visible 5 - )) - (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) - (updater (lambda () - (if (dashboard:monitor-changed? commondat tabdat) - (let ((servers (server:get-list *toppath* limit: 10))) - (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) - ;; (set! colnum 0) - ;; (for-each (lambda (colname) - ;; ;; (print "colnum: " colnum " colname: " colname) - ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) - ;; (set! colnum (+ 1 colnum))) - ;; colnames) - (set! rownum 1) - (for-each - (lambda (server) - (set! colnum 0) - (match-let (((mod-time host port start-time server-id pid) - server)) - (let* ((uptime (- (current-seconds) mod-time)) - (runtime (if start-time - (- mod-time start-time) - 0)) - (vals (list "-" ;; (vector-ref server 0) ;; Id - "-" ;; (vector-ref server 9) ;; MT-Ver - pid ;; (vector-ref server 1) ;; Pid - host ;; (vector-ref server 2) ;; Hostname - (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port - (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) - (cond - ((< uptime 5) "alive") - ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State - (else "dead")) - "-" ;; (vector-ref server 12) ;; RunId - ))) - (for-each (lambda (val) - (let* ((row-col (conc rownum ":" colnum)) - (curr-val (iup:attribute servers-matrix row-col))) - (if (not (equal? (conc val) curr-val)) - (begin - (iup:attribute-set! servers-matrix row-col val) - (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) - (set! colnum (+ 1 colnum)))) - vals) - (set! rownum (+ rownum 1))) - (iup:attribute-set! servers-matrix "REDRAW" "ALL"))) - (sort servers (lambda (a b)(> (car a)(car b)))))))))) - (set! colnum 0) - (for-each (lambda (colname) - (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) - (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) - (set! colnum (+ colnum 1))) - colnames) - ;; (set! dashboard:update-servers-table updater) - (dboard:commondat-add-updater commondat updater) - ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") - ;; (iup:hbox - ;; (iup:vbox - ;; (iup:button "Start" - ;; ;; #:size "50x" - ;; #:expand "YES" - ;; #:action (lambda (obj) - ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - ;; "megatest -server - &"))) - ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - ;; (system cmd)))) - ;; (iup:button "Stop" - ;; #:expand "YES" - ;; ;; #:size "50x" - ;; #:action (lambda (obj) - ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - ;; "megatest -stop-server 0 &"))) - ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - ;; (system cmd)))) - ;; (iup:button "Restart" - ;; #:expand "YES" - ;; ;; #:size "50x" - ;; #:action (lambda (obj) - ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - ;; "megatest -stop-server 0;megatest -server - &"))) - ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - ;; (system cmd))))) - ;; servers-matrix - ;; ))) - servers-matrix - )) - -;; The main menu -(define (dcommon:main-menu) - (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) - (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) - (fd (iup:file-dialog #:dialogtype "DIR")) - (top (iup:show fd #:modal? "YES"))) - (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct - (iup:attribute fd "VALUE")) - (iup:destroy! fd)))) - ;; (lambda (obj) - ;; (iup:show (iup:file-dialog)) - ;; (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) - -;;====================================================================== -;; CANVAS STUFF FOR TESTS -;;====================================================================== - -(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected) - (let* ((llx (dcommon:x->canvas x scalef xoffset)) - (lly (dcommon:y->canvas y scalef yoffset)) - (urx (dcommon:x->canvas (+ x w) scalef xoffset)) - (ury (dcommon:y->canvas (+ y h) scalef yoffset))) - (canvas-text! cnv (+ llx 5)(+ lly 5) name) - (canvas-rectangle! cnv llx urx lly ury) - (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) - -(define (dcommon:draw-arrow cnv test-box-center waiton-center) - (let* ((test-box-center-x (vector-ref test-box-center 0)) - (test-box-center-y (vector-ref test-box-center 1)) - (waiton-center-x (vector-ref waiton-center 0)) - (waiton-center-y (vector-ref waiton-center 1)) - (delta-y (- waiton-center-y test-box-center-y)) - (delta-x (- waiton-center-x test-box-center-x)) - (abs-delta-x (abs delta-x)) - (abs-delta-y (abs delta-y)) - (use-delta-x (> abs-delta-x abs-delta-y)) ;; use the larger one - (delta-ratio (if use-delta-x - (if (> abs-delta-x 0) - (/ abs-delta-y abs-delta-x) - 1) - (if (> abs-delta-y 0) - (/ abs-delta-x abs-delta-y) - 1))) - (x-adj (if use-delta-x - 8 - (* delta-ratio 8))) - (y-adj (if use-delta-x - (* x-adj delta-ratio) - 8)) - (new-waiton-x (inexact->exact - (round (if (> delta-x 0) ;; have positive x - (- waiton-center-x x-adj) - (+ waiton-center-x x-adj))))) - (new-waiton-y (inexact->exact - (round (if (> delta-y 0) - (- waiton-center-y y-adj) - (+ waiton-center-y y-adj)))))) - ;; (canvas-line-width-set! cnv 5) - (canvas-line! cnv - test-box-center-x - test-box-center-y - new-waiton-x - new-waiton-y - ) - (canvas-mark! cnv new-waiton-x new-waiton-y))) - -(define (dcommon:get-box-center box) - (let* ((llx (list-ref box 0)) - (lly (list-ref box 1)) - (boxw (list-ref box 4)) - (boxh (list-ref box 5))) - (vector (+ llx (/ boxw 2)) - (+ lly (/ boxh 2))))) - -(define-inline (num->int num) - (inexact->exact (round num))) - -(define (dcommon:draw-edges cnv xoffset yoffset scalef edges) - (for-each - (lambda (e) - (let loop ((x1 (car e)) - (y1 (cadr e)) - (x2 #f) - (y2 #f) - (tal (cddr e))) - (if (and x1 y1 x2 y2) - (canvas-line! - cnv - (num->int (dcommon:x->canvas x1 scalef xoffset)) - (num->int (dcommon:y->canvas y1 scalef yoffset)) - (num->int (dcommon:x->canvas x2 scalef xoffset)) - (num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2))) - (if (< (length tal) 2) - (canvas-mark! cnv - (num->int (dcommon:x->canvas x1 scalef xoffset)) - (num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1)) - (loop (car tal)(cadr tal) x1 y1 (cddr tal))))) - ;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges))) - edges)) - - -(define (dcommon:draw-arrows cnv testname tests-hash test-records) - (let* ((test-box-info (hash-table-ref tests-hash testname)) - (test-box-center (dcommon:get-box-center test-box-info)) - (test-record (hash-table-ref test-records testname)) - (waitons (vector-ref test-record 2))) - (for-each - (lambda (waiton) - (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f)) - (waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info)))) - (dcommon:draw-arrow cnv test-box-center waiton-center))) - waitons) - ;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info) - ;; (debug:print 0 *default-log-port* "test-record=" test-record) - )) - -(define (dcommon:estimate-scale sizex sizey originx originy nodes) - ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes) - (let* ((maxx 1) - (maxy 1)) - (for-each - (lambda (node) - (if (equal? (car node) "node") - (let ((x (string->number (list-ref node 2))) - (y (string->number (list-ref node 3)))) - (if (and x (> x maxx))(set! maxx x)) - (if (and y (> y maxy))(set! maxy y))))) - nodes) - (let ((scalex (/ sizex maxx)) - (scaley (/ sizey maxy))) - ;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley) - (min scalex scaley)))) - -(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in) - (let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0))) - (sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500)))) - (hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks - (hash-table-set! tests-draw-state 'sizex sizex) - (* (/ sizex 2) (- 0.5 xadj)))) - -(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in) - (let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0))) - (sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500)))) - (hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks - (hash-table-set! tests-draw-state 'sizey sizey) - (* (/ sizey 2) (- yadj 0.5)))) - -(define (dcommon:x->canvas x scalef xoffset) - (+ xoffset (* x scalef))) - -(define (dcommon:y->canvas y scalef yoffset) - (+ yoffset (* y scalef))) - -;; sizex, sizey - canvas size -;; originx, originy - canvas origin -;; -(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) - (let* ((dot-data ;; (map cdr (filter - ;; (lambda (x)(equal? "node" (car x))) - (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) - (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) - (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) - (no-dot (configf:lookup *configdat* "setup" "nodot")) - (boxh 15) - (boxw 10) - (margin 5) - (tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests )) - (scalef (if no-dot - 1 - (dcommon:estimate-scale sizex sizey originx originy dot-data))) - (sorted-testnames (if no-dot - (sort sorted-testnames string>=?) - sorted-testnames)) - (curr-x 0) ;; NB// NOT screen units - (curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot - (scaled-sizex (/ sizex scalef))) - - (hash-table-set! tests-draw-state 'scalef scalef) - - (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) - (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) - (if (> x-max boxw)(set! boxw (+ 10 x-max))))) - ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) - (if (not (null? sorted-testnames)) - (let loop ((hed (car (reverse sorted-testnames))) - (tal (cdr (reverse sorted-testnames)))) - (let* ((nodedat (if no-dot - #f - (let ((tmpres (filter (lambda (x) - (if (and (not (null? x)) - (equal? (car x) "node")) - (equal? hed (cadr x)) - #f)) - dot-data))) - (if (null? tmpres) - ;; llx lly boxw boxh - (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found - (car tmpres))))) - (edgedat (if no-dot - '() - (let ((edges (filter (lambda (x) ;; filter for edge - (if (and (not (null? x)) - (equal? (car x) "edge")) - (equal? hed (cadr x)) - #f)) - dot-data))) - (map (lambda (inlst) - (dcommon:process-polyline - (map (lambda (instr) - (string->number instr)) ;; convert to number and scale - (let ((il (cddddr inlst))) - (take il (- (length il) 2)))) - (lambda (x y) - (list (+ x 0) ;; xtorig) - (+ y 0))) ;; ytorig))) - #f #f)) ;; process polyline - edges)))) - (cx (if no-dot ;; this is the centerpoint! - curr-x - (string->number (list-ref nodedat 2)))) - (cy (if no-dot - curr-y - (string->number (list-ref nodedat 3)))) - (boxw (if no-dot - boxw - (string->number (list-ref nodedat 4)))) - (boxh (if no-dot - boxh - (string->number (list-ref nodedat 5)))) - (boxw/2 (/ boxw 2)) - (boxh/2 (/ boxh 2)) - (urx (+ cx boxw/2)) - (ury (+ cy boxh/2)) - (llx (- cx boxw/2)) - (lly (- cy boxh/2))) - - ;; if we are in no-dot mode then increment curr-x and curr-y as needed - (if no-dot - (begin - (cond - ((< curr-x (- scaled-sizex boxw boxw margin)) - (set! curr-x (+ curr-x boxw margin))) - ((> curr-x (- scaled-sizex boxw boxw margin)) - (set! curr-x 0) - (set! curr-y (- curr-y (+ boxh margin))))))) - ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) - (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - ;; (dcommon:draw-arrows cnv testname tests-info test-records)) - (dcommon:draw-edges cnv xoffset yoffset scalef edgedat) - - ;; data used by mouse click calc. keep the wacky order for now. - (hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat)) - (if (not (null? tal)) - (loop (car tal) - (cdr tal)))))) - )) - -;; per-point-proc required, remainder optional -;; -(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc) - (if (< (length line) 2) - '() - (let loop ((x1 (car line)) - (y1 (cadr line)) - (x2 #f) - (y2 #f) - (tal (cddr line)) - (res '())) - (if (and x1 y1 x2 y2 per-segment-proc) - (per-segment-proc x1 y1 x2 y2)) - (if (< (length tal) 2) - (begin - (if last-segment-proc (last-segment-proc x1 y1 x2 y2)) - (append res (per-point-proc x1 y1))) - (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1))))))) - -(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) - (let* ((scalef (hash-table-ref tests-draw-state 'scalef)) - (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) - (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) - (tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - (if (not (null? sorted-testnames)) - (let loop ((hed (car (reverse sorted-testnames))) - (tal (cdr (reverse sorted-testnames)))) - (let* ((tvals (hash-table-ref tests-info hed)) - (llx (list-ref tvals 0)) - (lly (list-ref tvals 1)) - (boxw (list-ref tvals 4)) - (boxh (list-ref tvals 5)) - (edges (map (lambda (pline) - (dcommon:process-polyline pline - (lambda (x1 y1) - (list x1 y1)) - #f #f)) - (list-ref tvals 6))) - (urx (+ llx boxw)) - (ury (+ lly boxh))) - (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - (dcommon:draw-edges cnv xoffset yoffset scalef edges) - (if (not (null? tal)) - ;; leave a column of space to the right to list items - (loop (car tal) - (cdr tal)))))))) - -;;====================================================================== -;; RUN CONTROLS -;;====================================================================== - -(define (dcommon:command-execution-control data) - ;; The command line display/exectution control - (iup:frame - #:title "Command to be exectuted" - (iup:hbox - (iup:label "Run on" #:size "40x") - (iup:radio - (iup:hbox - (iup:toggle "Local" #:size "40x") - (iup:toggle "Server" #:size "40x"))) - (let ((tb (iup:textbox - #:value "megatest " - #:expand "HORIZONTAL" - #:readonly "YES" - #:font "Courier New, -12" - ))) - (dboard:tabdat-command-tb-set! data tb) - tb) - (iup:button "Execute" #:size "50x" - #:action (lambda (obj) - ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))))))) - ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - ;; (system cmd))))))) - -(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) - (iup:frame - #:title "Set the action to take" - (iup:hbox - ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") - (let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs")) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - ;; (print obj " " val " " index " " lbstate) - (dboard:tabdat-command-set! tabdat val) - (dashboard:update-run-command tabdat)))) - (default-cmd (car cmds-list))) - (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) - (dboard:tabdat-command-set! tabdat default-cmd) - lb)))) - -(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data) - (iup:frame - #:title "Runname" - (let* ((default-run-name (seconds->work-week/day (current-seconds))) - (tb (iup:textbox #:expand "HORIZONTAL" - #:action (lambda (obj val txt) - (debug:catch-and-dump - (lambda () - ;; (print "obj: " obj " val: " val " unk: " unk) - (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) - (dashboard:update-run-command tabdat)) - "command-runname-selector tb action")) - #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) - (lb (iup:listbox #:expand "HORIZONTAL" - #:dropdown "YES" - #:action (lambda (obj val index lbstate) - (debug:catch-and-dump - (lambda () - (if (not (equal? val "")) - (begin - (iup:attribute-set! tb "VALUE" val) - (dboard:tabdat-run-name-set! tabdat val) - (dashboard:update-run-command tabdat)))) - "command-runname-selector lb action")))) - (refresh-runs-list (lambda () - (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) - (let* (;; (target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) - (runs-header (vector-ref runs-for-targ 0)) - (runs-dat (vector-ref runs-for-targ 1)) - (run-names (cons default-run-name - (map (lambda (x) - (db:get-value-by-header x runs-header "runname")) - runs-dat)))) - ;; (print "DEBUGINFO: run-names=" run-names) - ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") - (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) - ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) - (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) - ;; (refresh-runs-list) - (dboard:tabdat-run-name-set! tabdat default-run-name) - (iup:hbox - tb - lb)))) - -(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;; key-listboxes) - (iup:vbox - ;; Text box for test patterns - (iup:frame - #:title "Test patterns (one per line)" - (let ((tb (iup:textbox #:action (lambda (val a b) - (debug:catch-and-dump - (lambda () - (dboard:tabdat-test-patts-set!-use - tabdat - (dboard:lines->test-patt b)) - (dashboard:update-run-command tabdat)) - "command-testname-selector tb action")) - #:value (dboard:test-patt->lines - (dboard:tabdat-test-patts-use tabdat)) - #:expand "YES" - #:size "x30" ;; was 10x30 - #:multiline "YES"))) - (set! test-patterns-textbox tb) - (dboard:tabdat-test-patterns-textbox-set! tabdat tb) - tb)) -;; (iup:frame -;; #:title "Target" -;; ;; Target selectors -;; (apply iup:hbox -;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals)) -;; (key-lb (car dat)) -;; (combos (cadr dat))) -;; combos))) - ;; (iup:hbox - ;; ;; Text box for STATES - ;; (iup:frame - ;; #:title "States" - ;; (dashboard:text-list-toggle-box - ;; ;; Move these definitions to common and find the other useages and replace! - ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - ;; (lambda (all) - ;; (dboard:tabdat-states-set! tabdat all) - ;; (dashboard:update-run-command tabdat)))) - ;; ;; Text box for STATES - ;; (iup:frame - ;; #:title "Statuses" - ;; (dashboard:text-list-toggle-box - ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") - ;; (lambda (all) - ;; (dboard:tabdat-statuses-set! tabdat all) - ;; (dashboard:update-run-command tabdat))))) - )) - -(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state) - (iup:frame - #:title "Tests and Tasks" - (let* ((updater #f) - (last-xadj 0) - (last-yadj 0) - (the-cnv #f) - (canvas-obj - (iup:canvas #:action (make-canvas-action - (lambda (cnv xadj yadj) - (if (not updater) - (set! updater (lambda (xadj yadj) - ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) - (set! last-xadj xadj) - (set! last-yadj yadj)))) - (updater xadj yadj) - (set! the-cnv cnv) - )) - ;; Following doesn't work - #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. - (let ((scalef (hash-table-ref tests-draw-state 'scalef))) - (hash-table-set! tests-draw-state 'scalef (+ scalef - (if (> step 0) - (* 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 "250x250" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj ", pressed " pressed ", status " status) - ; (print "canvas-origin: " (canvas-origin the-cnv)) - ;; (let-values (((xx yy)(canvas-origin the-cnv))) - ;; (canvas-transform-set! the-cnv #f) - ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) - (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) - (scalef (hash-table-ref tests-draw-state 'scalef)) - (sizey (hash-table-ref tests-draw-state 'sizey)) - (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) - (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) - (new-y (- sizey y)) - (test-patterns-textbox (dboard:tabdat-test-patterns-textbox tabdat))) - ;; (print "xoffset=" xoffset ", yoffset=" yoffset) - ;; (print "\tx\ty\tllx\tlly\turx\tury") - (for-each (lambda (test-name) - (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) - (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) - (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) - (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) - ;; (if (eq? pressed 1) - ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) - (if (and (eq? pressed 1) - (>= x llx) - (>= new-y lly) - (<= x urx) - (<= new-y ury)) - (let* ((box-patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))) - (test-patts (string-split (or (dboard:tabdat-test-patts tabdat) - "") - ",")) - (patterns (delete-duplicates (append box-patterns test-patts)))) - (let* ((selected (not (member test-name patterns))) - (newpatt-list (if selected - (cons test-name patterns) - (delete test-name patterns))) - (newpatt (string-intersperse newpatt-list "\n"))) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (iup:attribute-set! obj "REDRAW" "ALL") - (hash-table-set! selected-tests test-name selected) - (dboard:tabdat-test-patts-set!-use tabdat (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command tabdat) - (if updater (updater last-xadj last-yadj))))))) - (hash-table-keys tests-info))))))) - canvas-obj))) - -;;====================================================================== -;; S T E P S -;;====================================================================== - -(define (dcommon:populate-steps teststeps steps-matrix run-id test-id) - (let* ((max-row 0) - (max-col 9) - (white "255 255 255") - - (testinfo (rmt:get-testinfo-state-status run-id test-id)) - (state (db:test-get-state testinfo)) - (status (db:test-get-status testinfo)) - (test-status-color (car (gutils:get-color-for-state-status state status))) - (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) - (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) - (if (null? teststeps) - (begin - (iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) - (if (> rownum max-row)(set! max-row rownum)) - (let* ((status (vector-ref hed 3)) - (val (vector-ref hed (- colnum 1))) - (bgcolor (cond - ((member (conc status) '("" "-" "#")) - running-color) - - ((member (conc status) '("0" 0)) - white) - (else test-status-color))) - ; (else failcolor))) - (mtrx-rc (conc rownum ":" colnum))) - ;;(print "BB> status=>"status"< bgcolor="bgcolor) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 5) - (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor)) - (if (< colnum max-col) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) - (loop (car tal) (cdr tal) (+ rownum 1) 1)))))) - (if (> max-row 0) - (begin - ;; we are going to speculatively clear rows until we find a row that is already cleared - (let loop ((rownum (+ max-row 1)) - (colnum 0) - (deleted #f)) - ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum) - (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) - (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) - (mtrx-rc (conc rownum ":" colnum)) - (curr-val (iup:attribute steps-matrix mtrx-rc))) - ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum " currval= " curr-val) - (if (and (string? curr-val) - (not (equal? curr-val ""))) - (begin - (iup:attribute-set! steps-matrix mtrx-rc "") - (loop next-row next-col #t)) - (if (eq? colnum max-col) ;; not done, didn't get a full blank row - (if deleted (loop next-row next-col #f)) ;; exit on this not met - (loop next-row next-col deleted))))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) - -;;====================================================================== -;; U T I L I T I E S -;;====================================================================== - -(define (dcommon:run-html-viewer lfilename) - (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) - (if htmlviewercmd - (system (conc "(" htmlviewercmd " " lfilename " ) &")) - (iup:send-url lfilename)))) - -(define (dashboard:monitor-changed? commondat tabdat) - (let* ((run-update-time (current-seconds)) - (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) - (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) - (file-modification-time monitor-db-path) - -1))) - (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) - (or (> monitor-modtime *last-monitor-update-time*) - (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case - (begin - (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) - #t) - #f))) - -;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db -;; is closed (I think). If db dir starts with /tmp always return true -;; -(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) - (let* ((run-update-time (current-seconds)) - (dbdir (dboard:tabdat-dbdir tabdat)) - (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)))) - ;; (dboard:tabdat-last-db-update tabdat)))) - (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) - (dboard:commondat-please-update-set! commondat #f) - recalc)) - -(define (dashboard:get-youngest-run-db-mod-time dbdir) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) - " db-dir="dbdir ", exn=" exn) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc dbdir "/*.db*")))))) - -(define (dboard:get-last-db-update tabdat context) - (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) - -(define (dboard:set-last-db-update! tabdat context newtime) - (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) - -;; point inside line -;; -(define-inline (dashboard:px-between px lx1 lx2) - (and (< lx1 px)(> lx2 px))) - -(define (dashboard:recalc modtime please-update-buttons last-db-update-time) - (or please-update-buttons - (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific - (> modtime (- last-db-update-time 3)) ;; add three seconds of margin - (> (current-seconds)(+ last-db-update-time 1))))) - Index: dcommonmod.scm ================================================================== --- dcommonmod.scm +++ dcommonmod.scm @@ -20,36 +20,46 @@ (declare (unit dcommonmod)) (declare (uses commonmod)) (declare (uses debugprint)) (declare (uses configfmod)) +(declare (uses vgmod)) +(declare (uses margsmod)) +(declare (uses rmtmod)) (module dcommonmod * (import scheme chicken data-structures extras ports) (use (prefix iup iup:) canvas-draw (prefix sqlite3 sqlite3:) + files posix typed-records srfi-18 srfi-69 matchable sparse-vectors srfi-1 regex srfi-13 + matchable ) (import canvas-draw-iup) (import commonmod) (import debugprint) (import configfmod) +(import vgmod) +(import margsmod) +(import rmtmod) (include "common_records.scm") +(include "db_records.scm") +(include "vg_records.scm") ;;====================================================================== ;; T R E E S T U F F ;;====================================================================== @@ -445,9 +455,6098 @@ ((last-update 0) : number) ;; last query to db got records from before last-update ((last-db-time 0) : number) ;; last timestamp on megatest.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)) + +;;====================================================================== +;; From dashboard.scm +;;====================================================================== + +;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) +;; +(define (dboard:common-get-tabdat commondat #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat) + 0)) ;; tab-num value is curr-tab-num value in passed commondat + (ht (dboard:commondat-tabdats commondat)) + (res (hash-table-ref/default ht tnum #f))) + (or res + (let ((new-tabdat (dboard:tabdat-make-data))) + (hash-table-set! ht tnum new-tabdat) + new-tabdat)))) + +;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table +;; +(define (dboard:common-set-tabdat! commondat tabnum tabdat) + (hash-table-set! + (dboard:commondat-tabdats commondat) + tabnum + tabdat)) + +;; gets and calls updater list based on curr-tab-num +;; +(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat + (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) + (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) + tnum + '()))) + (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) + (for-each ;; perform the function calls for the complete updaters list + (lambda (updater) + ;; (debug:print 3 *default-log-port* "Running " updater) + (updater)) + updaters)))) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) + + +(define (dboard:tabdat-target-string vec) + (let ((targ (dboard:tabdat-target vec))) + (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +(define (dboard:tabdat-make-data) + (let ((dat (make-dboard:tabdat))) + (dboard:tabdat-runs-btn-height-set! dat (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) ;; was 12 + (dboard:tabdat-runs-btn-fontsz-set! dat (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) ;; was 8 + (dboard:tabdat-runs-cell-width-set! dat (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) ;; was 50 + (dboard:tabdat-numruns-set! dat (string->number (or (args:get-arg "-cols") + (configf:lookup *configdat* "dashboard" "cols") + "8"))) + (dboard:tabdat-access-mode-set! dat (db:get-access-mode)) ;; use cached db or not + (dboard:setup-tabdat dat) + (dboard:setup-num-rows dat) + dat)) + +(define (dboard:setup-tabdat tabdat) + (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area)) + (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 "%")) + ) + +(define (dboard:runsdat-make-init) + (make-dboard:runsdat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +;; default is to NOT set the cell if the column and row names are not pre-existing +;; +(define (dboard:runsdat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) + (let* ((col-num (dcommon:runsdat-get-col-num dat target runname force-set)) + (row-num (dcommon:runsdat-get-row-num dat testname itempath force-set))) + (if (and row-num col-num) + (let ((tdat (dboard:testdat + id: test-id + state: state + status: status))) + (sparse-array-set! (dboard:runsdat-matrix-dat dat) col-num row-num tdat) + tdat) + #f))) + +(define *dashboard-mode* (string->symbol (or (configf:lookup *configdat* "dashboard" "mode") "dashboard"))) + + +(define *exit-started* #f) + +;; sorting global data (would apply to many testsuites so leave it global for now) +;; +(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") + (vector "Sort -a" 'testname "DESC") + (vector "Sort +t" 'event_time "ASC") + (vector "Sort -t" 'event_time "DESC") + (vector "Sort +s" 'statestatus "ASC") + (vector "Sort -s" 'statestatus "DESC") + (vector "Sort +a" 'testname "ASC"))) + +(define *tests-sort-type-index* '(("+testname" 0) + ("-testname" 1) + ("+event_time" 2) + ("-event_time" 3) + ("+statestatus" 4) + ("-statestatus" 5))) + +;; Don't forget to adjust the >= below if you add to the sort-options above +(define (next-sort-option) + (if (>= *tests-sort-reverse* 5) + (set! *tests-sort-reverse* 0) + (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) + *tests-sort-reverse*) + +(define *tests-sort-reverse* + (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) + (if t-sort + (cadr t-sort) + 3))) + +(define (get-curr-sort) + (vector-ref *tests-sort-options* *tests-sort-reverse*)) + +;; (print "Got here #2") + +;;====================================================================== + +;;====================================================================== +(common:debug-setup) + +;; (define uidat #f) + +(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) +(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) +(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) +(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) + +(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +(define (pad-list l n)(append l (make-list (- n (length l))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define (dboard:compare-tests test1 test2) + (let* ((test-name1 (db:test-get-testname test1)) + (item-path1 (db:test-get-item-path test1)) + (eventtime1 (db:test-get-event_time test1)) + (test-name2 (db:test-get-testname test2)) + (item-path2 (db:test-get-item-path test2)) + (eventtime2 (db:test-get-event_time test2)) + (same-name (equal? test-name1 test-name2)) + (test1-top (equal? item-path1 "")) + (test2-top (equal? item-path2 "")) + (test1-older (> eventtime1 eventtime2)) + (same-time (equal? eventtime1 eventtime2))) + (if same-name + (if same-time + (string>? item-path1 item-path2) + test1-older) + (if same-time + (string>? test-name1 test-name2) + test1-older)))) + +;; This is roughly the same as dboard:get-tests-dat, should merge them if possible +;; +;; gets all the tests for run-id that match testnamepatt and key-vals, merges them +;; +;; NOTE: Yes, this is used +;; +(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) + (let* ((start-time (current-seconds)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") + "200"))) + (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) + (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) + (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab + (sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + ;; note: the rundat is normally created in "update-rundat". + (run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f) + (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) + rd))) + ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) + (last-update (if ;;(or + do-not-use-query-timestamps + ;;(dboard:tabdat-filters-changed tabdat)) + 0 + (dboard:rundat-last-update run-dat))) + (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"))) + (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 + (tmptests (if (or do-not-use-db-file-timestamps + (dboard:tabdat-filters-changed tabdat) + db-modified) + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) ;; query offset + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + last-update ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) + (use-new (dboard:tabdat-hide-not-hide tabdat)) + (tests-ht (if (dboard:tabdat-filters-changed tabdat) + (let ((ht (make-hash-table))) + (dboard:rundat-tests-set! run-dat ht) + ht) + (dboard:rundat-tests run-dat))) + (got-all (< (length tmptests) num-to-get)) ;; got all for this round + ) + + ;; if we saw the db modified, reset it (the signal has already been used) + (if (and got-all ;; (not multi-get) + db-modified) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + + ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset + ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the + ;; data has been read + ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above + ;; + ;; (debug:print 0 *default-log-port* "got-all: " got-all " multi-get: " multi-get " num-to-get: " num-to-get " (length tmptests): " (length tmptests) " db-modified: " db-modified " db-mod-time: " db-mod-time " db-path: " db-path) + (if got-all + (begin + (dboard:rundat-last-update-set! run-dat (- start-time 2)) + (dboard:rundat-run-data-offset-set! run-dat 0)) + (begin + (dboard:rundat-run-data-offset-set! run-dat + (+ num-to-get (dboard:rundat-run-data-offset run-dat))))) + + (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) + + tests-ht)) + +;; tmptests - new tests data +;; prev-tests - old tests data +;; +;; (define (dashboard:merge-changed-tests tabdat tests tmptests) ;; use-new prev-tests) +;; (let* ((newdat (filter +;; (lambda (x) +;; (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging +;; (delete-duplicates (if use-new ;; (dboard:tabdat-filters-changed tabdat) +;; tmptests +;; (append tmptests prev-tests)) +;; (lambda (a b) +;; (eq? (db:test-get-id a)(db:test-get-id b))))))) +;; (print "Time took: " (- (current-seconds) start-time)) +;; (if (eq? *tests-sort-reverse* 3) ;; +event_time +;; (sort newdat dboard:compare-tests) +;; newdat))) + +;; 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 (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (rmt:get-keys)) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (rmt: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)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + ;;(BB> "In update-rundat") + ;;(inspect allruns runs-hash) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (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 (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) res (cons run-struct res))) + (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 get-tests-for-run uses last update + (begin + (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) + (dboard:tabdat-allruns-set! tabdat new-res) + 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))) + +;; 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)) + (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 (rmt: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)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (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 (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (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 get-tests-for-run uses last update + (begin + (when (> elapsed-time 2) + (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (if (< (string->number new-val) 5000) + ((debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val)))) + + + ) + (dboard:tabdat-allruns-set! tabdat new-res) + 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))) + +(define *collapsed* (make-hash-table)) + +(define (toggle-hide lnum uidat) ; fulltestname) + (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) + (fulltestname (iup:attribute btn "TITLE")) + (parts (string-split fulltestname "(")) + (basetestname (if (null? parts) "" (car parts)))) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + (if (hash-table-ref/default *collapsed* basetestname #f) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")s + (hash-table-delete! *collapsed* basetestname)) + (begin + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + (hash-table-set! *collapsed* basetestname #t))))) + +(define blank-line-rx (regexp "^\\s*$")) + +(define (run-item-name->vectors lst) + (map (lambda (x) + (let ((splst (string-split x "(")) + (res (vector "" ""))) + (vector-set! res 0 (car splst)) + (if (> (length splst) 1) + (vector-set! res 1 (car (string-split (cadr splst) ")")))) + res)) + lst)) + +(define (collapse-rows tabdat inlst) + (let* ((sort-info (get-curr-sort)) + (sort-by (vector-ref sort-info 1)) + (sort-order (vector-ref sort-info 2)) + (bubble-type (if (member sort-order '(testname)) + 'testname + 'itempath)) + (newlst (filter (lambda (x) + (let* ((tparts (string-split x "(")) + (basetname (if (null? tparts) x (car tparts)))) + ;(print "x " x " tparts: " tparts " basetname: " basetname) + (cond + ((string-match blank-line-rx x) #f) + ((equal? x basetname) #t) + ((hash-table-ref/default *collapsed* basetname #f) + ;(print "Removing " basetname " from items") + #f) + (else #t)))) + inlst)) + (vlst (run-item-name->vectors newlst)) + (vlst2 (bubble-up tabdat vlst priority: bubble-type))) + (map (lambda (x) + (if (equal? (vector-ref x 1) "") + (vector-ref x 0) + (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) + vlst2))) + +(define (update-labels uidat alltestnames) + (let* ((rown 0) + (keycol (dboard:uidat-get-keycol uidat)) + (lftcol (dboard:uidat-get-lftcol uidat)) + (numcols (vector-length lftcol)) + (maxn (- numcols 1)) + (allvals (make-vector numcols ""))) + (for-each (lambda (name) + (if (<= rown maxn) + (vector-set! allvals rown name)) ;) + (set! rown (+ 1 rown))) + alltestnames) + (let loop ((i 0)) + (let* ((lbl (vector-ref lftcol i)) + (keyval (vector-ref keycol i)) + (oldval (iup:attribute lbl "TITLE")) + (newval (vector-ref allvals i))) + (if (not (equal? oldval newval)) + (let ((munged-val (let ((parts (string-split newval "("))) + (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) + (vector-set! keycol i newval) + (iup:attribute-set! lbl "TITLE" munged-val))) + (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) + (if (< i maxn) + (loop (+ i 1))))))) + +;; +(define (get-itemized-tests test-dats) + (let ((tnames '())) + (for-each (lambda (tdat) + (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (if (not (equal? ipath "")) + (if (and (list? tnames) + (string? tname) + (not (member tname tnames))) + (set! tnames (append tnames (list tname))))))) + test-dats) + tnames)) + +;; Bubble up the top tests to above the items, collect the items underneath +;; all while preserving the sort order from the SQL query as best as possible. +;; +(define (bubble-up tabdat test-dats #!key (priority 'itempath)) + (if (null? test-dats) + test-dats + (begin + (let* ((tnames '()) ;; list of names used to reserve order + (tests (make-hash-table)) ;; hash of lists, used to build as we go + (itemized (get-itemized-tests test-dats))) + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (if (equal? ipath "") + ;; This a top level, prepend it + (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) + ;; This is item, append it + (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) + test-dats) + ;; Set all tests with items + (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + (dboard:tabdat-item-test-names tabdat))) + (let loop ((hed (car tnames)) + (tal (cdr tnames)) + (res '())) + (let ((newres (append res (hash-table-ref tests hed)))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))))) + +;; optimized to get runs constrained by what is visible on the screen +;; - not appropriate for where all the runs are needed +;; +(define (update-buttons tabdat uidat numruns numtests) + (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) + (take-right (dboard:tabdat-allruns tabdat) numruns) + (pad-list (dboard:tabdat-allruns tabdat) numruns))) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) + (coln 0) + (all-test-names (make-hash-table))) + ;; create a concise list of test names + ;; + (for-each + (lambda (rundat) + (if rundat + (let* ((testdats (dboard:rundat-tests rundat)) + (testnames (map test:test-get-fullname (hash-table-values testdats)))) + (dcommon:rundat-copy-tests-to-by-name rundat) + ;; for the normalized list of testnames (union of all runs) + (if (not (and (dboard:tabdat-hide-empty-runs tabdat) + (null? testnames))) + (for-each (lambda (testname) + (hash-table-set! all-test-names testname #t)) + testnames))))) + runs) + + ;; create the minimize list of testnames to be displayed. Sorting + ;; happens here *before* trimming + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (collapse-rows + tabdat + (sort (hash-table-keys all-test-names) string>?))) ;; FIXME: Sorting needs to happen here + + ;; Trim the names list to fit the matrix of buttons + ;; + (dboard:tabdat-all-test-names-set! + tabdat + (let ((xl (if (> (length (dboard:tabdat-all-test-names tabdat)) (dboard:tabdat-start-test-offset tabdat)) + (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 + (lambda (rundat) + ;; if rundat is junk clobber it with a decent placeholder + (if (or (not rundat) ;; handle padded runs + (not (dboard:rundat-run rundat))) + (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)) + (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) + (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 + ;; + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f))) + (if (and buttondat + (hash-table? testsdat-by-name)) + (let* ((testdat (let ((matching (hash-table-ref/default testsdat-by-name testname #f))) + ;; (filter + ;; (lambda (x)(equal? (test:test-get-fullname x) testname)) + ;; 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) + (else + teststate))) + (button (vector-ref columndat rown)) + (color (car (gutils:get-color-for-state-status teststate teststatus))) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 testdat) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + (dboard:tabdat-all-test-names tabdat))) + (set! coln (+ coln 1)))) + runs))) + +(define (mkstr . x) + (string-intersperse (map conc x) ",")) + +(define (set-bg-on-filter commondat tabdat) + (let ((search-changed (not (null? (filter (lambda (key) + (not (equal? (hash-table-ref (dboard:tabdat-searchpatts tabdat) key) "%"))) + (hash-table-keys (dboard:tabdat-searchpatts tabdat)))))) + (state-changed (not (null? (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))))) + (status-changed (not (null? (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))))) + (iup:attribute-set! (dboard:commondat-hide-not-hide-tabs commondat) "BGCOLOR" + (if (or search-changed + state-changed + status-changed) + "190 180 190" + "190 190 190" + )) + (dboard:tabdat-filters-changed-set! tabdat #t))) + +(define (update-search commondat tabdat x val) + (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) + (dboard:tabdat-filters-changed-set! tabdat #t) + (mark-for-update tabdat) + (set-bg-on-filter commondat tabdat)) + +;; force ALL updates to zero (effectively) +;; +(define (mark-for-update tabdat) + (dboard:tabdat-last-db-update-set! tabdat (make-hash-table))) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; field = target field name for this dropdown +;; referent-vals = selected value in the left dropdown +;; targets = list of targets to use to build the dropdown +;; +;; each node is chained: key1 -> key2 -> key3 +;; +;; must select values from only apropriate targets +;; a b c +;; a d e +;; a b f +;; a/b => c f +;; +(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs) + ;; is the current value in the new list? choose new default if not + (let* ((remvalues (map (lambda (row) + (common:list-is-sublist referent-vals (vector->list row))) + targets)) + (values (delete-duplicates (map car (filter list? remvalues)))) + (sel-valnum (iup:attribute lb "VALUE")) + (sel-val (iup:attribute lb sel-valnum)) + (val-num 1)) + ;; first check if the current value is in the new list, otherwise replace with + ;; first value from values + (iup:attribute-set! lb "REMOVEITEM" "ALL") + (for-each (lambda (val) + ;; (iup:attribute-set! lb "APPENDITEM" val) + (iup:attribute-set! lb (conc val-num) val) + (if (equal? sel-val val) + (iup:attribute-set! lb "VALUE" val-num)) + (set! val-num (+ val-num 1))) + values) + (let ((val (iup:attribute lb "VALUE"))) + (if val + val + (if (not (null? values)) + (let ((newval (car values))) + (iup:attribute-set! lb "VALUE" newval) + newval)))))) + +(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) + (let* ((runconf-targs (common:get-runconfig-targets)) + (key-lbs (dboard:tabdat-key-listboxes tabdat)) + (db-target-dat (rmt:get-targets)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. + (list->vector + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header))))) + (all-targets (append (list (munge-target (string-intersperse + (map (lambda (x) "%") header) + "/"))) + db-targets + (map munge-target + runconf-targs) + )) + (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) + (if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes)) + (let loop ((key (car header)) + (remkeys (cdr header)) + (refvals '()) + (indx 0) + (lbs '())) + (let* ((lb (let ((lb (list-ref key-listboxes indx))) + (if lb + lb + (iup:listbox + #:size "x60" + #:fontsize "10" + #:expand "YES" ;; "VERTICAL" + ;; #:dropdown "YES" + #:editbox "YES" + #:action (lambda (obj a b c) + (debug:catch-and-dump action-proc "update-target-selector")) + #:caret_cb (lambda (obj a b c) + (debug:catch-and-dump action-proc "update-target-selector")) + )))) + ;; loop though all the targets and build the list for this dropdown + (selected-value (dashboard:populate-target-dropdown lb refvals all-targets))) + (if (null? remkeys) + ;; return a list of the listbox items and an iup:hbox with the labels and listboxes + (let* ((listboxes (append lbs (list lb))) + (res (list listboxes + (map (lambda (htxt lb) + (iup:vbox + (iup:label htxt) + lb)) + header + listboxes)))) + (dboard:tabdat-key-listboxes-set! tabdat res) + res) + (loop (car remkeys) + (cdr remkeys) + (append refvals (list selected-value)) + (+ indx 1) + (append lbs (list lb)))))))) + +;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string +;; interspersed with commas +;; +(define (dashboard:text-list-toggle-box items proc) + (let ((alltgls (make-hash-table))) + (apply iup:vbox + (map (lambda (item) + (iup:toggle + item + #:fontsize 8 + #:expand "YES" + #:action (lambda (obj tstate) + (debug:catch-and-dump + (lambda () + (if (eq? tstate 0) + (hash-table-delete! alltgls item) + (hash-table-set! alltgls item #t)) + (let ((all (hash-table-keys alltgls))) + (proc all))) + "text-list-toggle-box")))) + items)))) + +;; (print "Got here #3") + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; + +(define (dboard:target-updater tabdat) ;; key-listboxes) + (let ((targ (map (lambda (x) + (iup:attribute x "VALUE")) + (car (dashboard:update-target-selector tabdat)))) + (curr-runname (dboard:tabdat-run-name tabdat))) + (dboard:tabdat-target-set! tabdat targ) + ;; (if (dboard:tabdat-updater-for-runs tabdat) + ;; ((dboard:tabdat-updater-for-runs tabdat))) + (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) + (equal? (dboard:tabdat-run-name tabdat) "")) + (dboard:tabdat-run-name-set! tabdat curr-runname)) + (dashboard:update-run-command tabdat))) + +;; used by run-controls +;; +(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) + (let* ((tb (dboard:tabdat-runs-tree tabdat)) + (runconf-targs (common:get-runconfig-targets)) + (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + (all-targets (append (list (munge-target (string-intersperse + (map (lambda (x) "%") header) + "/"))) + (map vector->list db-targets) + (map munge-target + runconf-targs) + ))) + (for-each + (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)) + (hash-table-set! runs-tree-ht target #t)))) + all-targets))) + +;; Run controls panel +;; +(define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) + (let* ((targets (make-hash-table)) + (test-records (make-hash-table)) + (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) + (test-names (hash-table-keys all-tests-registry)) + (sorted-testnames #f) + (action "-run") + (cmdln "") + (runlogs (make-hash-table)) + ;;; (key-listboxes #f) + (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" + (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) + (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas + (test-patterns-textbox #f)) + (hash-table-set! tests-draw-state 'first-time #t) + ;; (hash-table-set! tests-draw-state 'scalef 1) + (tests:get-full-data test-names test-records '() all-tests-registry) + (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) + + ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys + (let* ((result + (iup:vbox + (dcommon:command-execution-control tabdat) + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 200 + ;; + ;; (iup:split + ;; #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dboard:runs-tree-browser commondat tabdat)) + (iup:vbox + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals))) + ;; key-listboxes)) + (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:commondat-add-updater + commondat + (lambda () + (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) + (dashboard:update-tree-selector tabdat))) + tab-num: tab-num) + result))) + + ;;(iup:frame + ;; #:title "Logs" ;; To be replaced with tabs + ;; (let ((logs-tb (iup:textbox #:expand "YES" + ;; #:multiline "YES"))) + ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) + ;; logs-tb)) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; +(define (dboard:runs-tree-browser commondat tabdat) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:tabdat-target-set! tabdat + (string-split b "/"))) + (dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + #:value (dboard:test-patt->lines + (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + (dashboard:update-run-command tabdat) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-view-changed-set! tabdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:tabdat-runs-tree-set! tabdat tb) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) + +;; browse runs as a tree. Used in both "Runs" tab and +;; in the runs control panel. +;; +;; THIS IS THE NEW ONE +;; +(define (dboard:runs-tree-new-browser commondat rdat) + (let* ((txtbox (iup:textbox + #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:rdat-targ-sql-filt-set! rdat + (string-split b "/"))) + #;(dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? + ;; (dboard:tabdat-test-patts-use tabdat)) + #:expand "HORIZONTAL" + ;; #:size "10x30" + )) + (tb + (iup:treebox + #:value 0 + #:title "Runs" ;; was #:name -- iup 3.19 changed + ;; this... "Changed: [DEPRECATED + ;; REMOVED] removed the old attribute + ;; NAMEid from IupTree to avoid + ;; conflict with the common attribute + ;; NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + (let* ((run-path (tree:node->path obj id)) + (run-id (new-tree-path->run-id rdat (cdr run-path)))) + ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? + ;; done below when run-id is a number + (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print + ;; "run-path: + ;; " + ;; run-path) + (iup:attribute-set! txtbox "VALUE" + (string-intersperse (cdr run-path) "/")) + #;(dashboard:update-run-command tabdat) + #;(dboard:tabdat-layout-update-ok-set! tabdat #f) + (if (number? run-id) + (begin + ;; capture last two in tabdat. + (dboard:rdat-push-run-id rdat run-id) + (dboard:rdat-view-changed-set! rdat #t)) + (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) + "treebox")) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (dboard:rdat-runs-tree-set! rdat tb) + (iup:detachbox + (iup:vbox + txtbox + tb + )))) + +;;====================================================================== +;; R U N C O N T R O L S +;;====================================================================== +;; +;; A gui for launching tests +;; +(define (dashboard:run-times commondat tabdat #!key (tab-num #f)) + (let* ((drawing (vg:drawing-new)) + (run-times-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:run-times-tab-canvas-updater commondat tabdat tab-num) + (if (> (- now-time last-data-update) 5) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat now-time) + ;; this is threadified to return control to the gui for a redraw. + ;; it relies on the running-layout flag to prevent overlapping + ;; calls. + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater"))) + )))))) + "dashboard:run-times-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 + + (dboard:runs-tree-browser commondat tabdat) + + (iup:hbox + (iup:toggle + "Compact layout" + #:fontsize 8 + #:expand "HORIZONTAL" + #:value 1 + #:action (lambda (obj tstate) + (debug:catch-and-dump + (lambda () + (print "tstate: " tstate) + (if (eq? tstate 0) + (dboard:tabdat-compact-layout-set! tabdat #f) + (dboard:tabdat-compact-layout-set! tabdat #t)) + (dboard:tabdat-last-filter-str-set! tabdat "") + ) + "text-list-toggle-box")))) + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals)) + (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) + (let* ((hb1 (iup:hbox)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (changed #f) + (graph-matrix (iup:matrix + #:alignment1 "ALEFT" + ;; #:expand "YES" ;; "HORIZONTAL" + #:scrollbar "YES" + #:numcol 10 + #:numlin 20 + #:numcol-visible 5 ;; (min 8) + #:numlin-visible 1 + #:click-cb + (lambda (obj row col status) + (let* + ((graph-cell (conc row ":" col)) + (graph-dat (hash-table-ref/default graph-cell-table graph-cell #f)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (dboard:graph-dat-flag-set! graph-dat #f) + (dboard:graph-dat-flag-set! graph-dat #t)) + (if (not (dboard:tabdat-running-layout tabdat)) + (begin + (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (dboard:tabdat-last-data-update-set! tabdat (current-seconds)) + (thread-start! (make-thread + (lambda () + (dboard:tabdat-running-layout-set! tabdat #t) + (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + (dboard:tabdat-running-layout-set! tabdat #f)) + "run-times-tab-layout-updater")))) + ;;(dboard:tabdat-view-changed-set! tabdat #t) + ))))) + (dboard:tabdat-graph-matrix-set! tabdat graph-matrix) + (iup:attribute-set! graph-matrix "WIDTH0" 0) + (iup:attribute-set! graph-matrix "HEIGHT0" 0) + graph-matrix)) + (iup:hbox + (iup:vbox + (iup:button "Show All" #:action (lambda (obj) + (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 #t))) + (hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))) + (iup:hbox + (iup:button "Hide All" #:action (lambda (obj) + (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))))))) + )))) + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +;; (define (dboard:get-tests-dat tabdat run-id last-update) +;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) +;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run +;; run-id +;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") +;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() +;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() +;; #f #f ;; offset limit +;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in +;; #f #f ;; sort-by sort-order +;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval +;; (if (dboard:tabdat-filters-changed tabdat) +;; 0 +;; last-update) +;; *dashboard-mode*) +;; '()))) ;; get 'em all +;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) +;; (sort tdat (lambda (a b) +;; (let* ((aval (vector-ref a 2)) +;; (bval (vector-ref b 2)) +;; (anum (string->number aval)) +;; (bnum (string->number bval))) +;; (if (and anum bnum) +;; (< anum bnum) +;; (string<= aval bval))))))) + + +(define (dashboard:safe-cadr-assoc name lst) + (let ((res (assoc name lst))) + (if (and res (> (length res) 1)) + (cadr res) + #f))) + +(define (dboard:update-tree tabdat 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)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (changed #f) + (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))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (for-each (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key) + (let ((val (db:get-value-by-header run-record runs-header key))) + (if (string? val) val ""))) + (dboard:tabdat-keys tabdat))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (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)) + ;; 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))) + +(define (dashboard:tests-ht->tests-dat tests-ht) + (reverse + (sort + (hash-table-values tests-ht) + (lambda (a b) + (let ((a-test-name (db:test-get-testname a)) + (a-item-path (db:test-get-item-path a)) + (b-test-name (db:test-get-testname b)) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (not (equal? a-test-name b-test-name)) + (> a-event-time b-event-time) + (cond + ((< 0 (string-compare3 a-test-name b-test-name)) #t) + ((> 0 (string-compare3 a-test-name b-test-name)) #f) + ((< 0 (string-compare3 a-item-path b-item-path)) #t) + (else #f)))))))) + + +(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) + (let* ((run (hash-table-ref/default runs-hash run-id #f)) + (key-vals (rmt:get-key-vals run-id)) + (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) + (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) + (when (not run) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) + ) + tests-mindat)) + +(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) + (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) + (dest-run-id (dboard:tabdat-curr-run-id tabdat))) + (if (and src-run-id dest-run-id) + (dcommon:xor-tests-mindat + (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + hide-clean: hide-clean) + #f))) + + +(define (dashboard:get-runs-hash tabdat) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update 0);;(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 (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)) + + +(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 (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)) + (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)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + (when matrix-content + (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + (row-indices (cadr indices)) + (col-indices (car indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + (numrows 1) + (numcols 1) + (changed #f) + ) + + (dboard:tabdat-filters-changed-set! tabdat #f) + (let loop ((pass-num 0) + (changed #f)) + ;; Update the runs tree + ;; (dboard:update-tree tabdat runs-hash runs-header tb) + + (if (eq? pass-num 1) + (begin ;; big reset + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + + (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" max-col )) + + (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + ;; (print "row-indices: " row-indices " col-indices: " col-indices) + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + matrix-content) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (if (<= num max-col) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + col-indices) + + (if (and (eq? pass-num 0) changed) + (loop 1 #t)) ;; force second pass due to column labels changing + + ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) + +;;====================================================================== +;; S U M M A R Y +;;====================================================================== +;; +;; General info about the run(s) and megatest area +(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 300 + (iup:frame + #:title "General Info" + (iup:vbox + (iup:hbox + (iup:label "Area Path") + (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + ))) + (iup:frame + #:title "Server" + (dcommon:servers-table commondat tabdat))) + (iup:frame + #:title "Megatest config settings" + (iup:hbox + (dcommon:section-matrix rawconfig "setup" "Varname" "Value") + (iup:vbox + (dcommon:section-matrix rawconfig "server" "Varname" "Value") + ;; (iup:frame + ;; #:title "Disks Areas" + (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) + (iup:frame + #:title "Run statistics" + (dcommon:run-stats commondat tabdat tab-num: tab-num))))) + +;;====================================================================== +;; H A N D L E U S E R C O N T R I B U T E D V I E W S +;;====================================================================== + +(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num) + (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. + (source (configf:lookup views-cfgdat view-name "source")) + (viewgen (configf:lookup views-cfgdat view-name "viewgen")) + (updater (configf:lookup views-cfgdat view-name "updater")) + (result-child #f)) + (if (and (common:file-exists? source) + (file-read-access? source)) + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") + (set! success #f)) + (load source)) + (begin + (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) + ;; now run the user supplied definition for the tab view + (if success + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen + ", with; tab-num=" tab-num ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (print "Adding tab " view-name " with proc " viewgen) + ;; (iup:child-add! tabs + (set! result-child + ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) + ;; and finally set the updater + (if success + (dboard:commondat-add-updater commondat + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater + "\", with; tabnum=" tab-num ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) + ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) + tab-num: tab-num)) + ;;(if success + ;; (begin + ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) + ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) + result-child)) + + + +(define (dboard:runs-summary-buttons-updater tabdat) + (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) + (modes-left (dboard:tabdat-runs-summary-modes tabdat))) + (if (or (null? buttons-left) (null? modes-left)) + #t + (let* ((this-button (car buttons-left)) + (mode-item (car modes-left)) + (this-mode (car mode-item)) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (current-mode (dboard:tabdat-runs-summary-mode tabdat))) + (if (eq? this-mode current-mode) + (iup:attribute-set! this-button "BGCOLOR" sel-color) + (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) + (loop (cdr buttons-left) (cdr modes-left)))))) + +(define (dboard:runs-summary-xor-labels-updater tabdat) + (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat))) + (when (and source-runname-label dest-runname-label) + (case mode + ((xor-two-runs xor-two-runs-hide-clean) + (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (rmt:get-run-name-from-id curr-run-id) + "None")) + (prev-runname (if prev-run-id + (rmt:get-run-name-from-id prev-run-id) + "None"))) + (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) + (else + (iup:attribute-set! source-runname-label "TITLE" "") + (iup:attribute-set! dest-runname-label "TITLE" "")))))) + +(define (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-xor-labels-updater tabdat) + (dboard:runs-summary-buttons-updater tabdat)) + + +;; setup buttons and callbacks to switch between modes in runs summary tab +;; +(define (dashboard:runs-summary-control-panel tabdat) + (let* ((summary-buttons ;; build buttons + (map + (lambda (mode-item) + (let* ((this-mode (car mode-item)) + (this-mode-label (cdr mode-item))) + (iup:button this-mode-label + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) + (dboard:runs-summary-control-panel-updater tabdat)) + "runs summary control panel updater"))))) + (dboard:tabdat-runs-summary-modes tabdat))) + (summary-buttons-hbox (apply iup:hbox summary-buttons)) + (xor-runname-labels-hbox + (iup:hbox + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) + temp-label)))) + (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) + + ;; maybe wrap in a frame + (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) + (dboard:runs-summary-control-panel-updater tabdat) + res + ))) + + + +;;====================================================================== +;; R U N +;;====================================================================== +;; +;; display and manage a single run at a time + +;; This is the Run Summary tab +;; +(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" + #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." + #:expand "YES" + #:addexpanded "YES" + #: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)))) + (if (number? run-id) + (begin + (dboard:tabdat-prev-run-id-set! + tabdat + (dboard:tabdat-curr-run-id tabdat)) + + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + ;; (dashboard:update-run-summary-tab) + ) + ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) + ))) + "selection-cb in runs-summary") + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (cell-lookup (make-hash-table)) + (run-matrix (iup:matrix + #:expand "YES" + #:click-cb + + (lambda (obj lin col status) + (debug:catch-and-dump + (lambda () + + ;; Bummer - we dont have the global get/set api mapped in chicken + ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) + ;; (BB> "modkeys="modkeys)) + + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) + ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path))) + (status-chars (char-set->list (string->char-set status))) + (run-id (dboard:tabdat-curr-run-id tabdat))) + (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") + (cond + ((member #\1 status-chars) ;; 1 is left mouse button + (dboard:launch-testpanel run-id test-id)) + + ((member #\2 status-chars) ;; 2 is middle mouse button + + (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + (else + (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + ) + + )) "runs-summary-click-callback")))) + (runs-summary-updater + (lambda () + (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 + (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)) + ) + (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) + (dboard:tabdat-runs-tree-set! tabdat tb) + (iup:vbox + (iup:split + #:value 200 + tb + run-matrix) + (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) + +;;====================================================================== +;; 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 + #:title "filter test and items" + (iup:vbox + (iup:hbox + (iup:vbox + (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" + #:expand "NO" + #:action (lambda (obj unk val) + (debug:catch-and-dump + (lambda () + (mark-for-update tabdat) + (update-search commondat tabdat "test-name" val)) + "make-controls"))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj) + (exit)) + #:expand "NO" #:size "40x15") + (iup:button "Refresh" #:action (lambda (obj) + (dboard:tabdat-last-data-update-set! tabdat 0) + (dboard:tabdat-last-runs-update-set! tabdat 0) + (dboard:tabdat-run-update-times-set! tabdat (make-hash-table)) + (dboard:tabdat-last-test-dat-set! tabdat (make-hash-table)) + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) + (dboard:tabdat-done-runs-set! tabdat '()) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-view-changed-set! tabdat #t) + (dboard:commondat-please-update-set! commondat #t) + (mark-for-update tabdat)) + #:expand "NO" #:size "40x15") + (iup:button "Collapse" #:action (lambda (obj) + (debug:catch-and-dump + (lambda () + (let ((myname (iup:attribute obj "TITLE"))) + (if (equal? myname "Collapse") + (begin + (for-each (lambda (tname) + (hash-table-set! *collapsed* tname #t)) + (dboard:tabdat-item-test-names tabdat)) + (iup:attribute-set! obj "TITLE" "Expand")) + (begin + (for-each (lambda (tname) + (hash-table-delete! *collapsed* tname)) + (hash-table-keys *collapsed*)) + (iup:attribute-set! obj "TITLE" "Collapse")))) + (mark-for-update tabdat)) + "make-controls collapse button")) + #:expand "NO" #:size "40x15"))) + (iup:vbox + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update tabdat))) + + (let* ((hide #f) + (show #f) + (hide-empty #f) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" + #:size "80x15" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (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 (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")) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (set! show (iup:button "Show" + #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" + #:action (lambda (obj) + (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) + (iup:attribute-set! show "BGCOLOR" sel-color) + (iup:attribute-set! hide "BGCOLOR" nonsel-color) + (mark-for-update tabdat)))) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) + ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... + (iup:vbox + (iup:hbox hide show) + sort-lb))) + ) + + ;; insert extra widget here + (if extra-widget + extra-widget + (iup:hbox)) ;; empty widget + + + + + ))) + + (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)) + +;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) +;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) +;; simple-run-event_time procedure (x3834) +;; simple-run-event_time-set! procedure (x3830 val3831) +;; simple-run-id procedure (x3794) +;; simple-run-id-set! procedure (x3790 val3791) +;; simple-run-owner procedure (x3826) +;; simple-run-owner-set! procedure (x3822 val3823) +;; simple-run-runname procedure (x3802) +;; simple-run-runname-set! procedure (x3798 val3799) +;; simple-run-state procedure (x3810) +;; simple-run-state-set! procedure (x3806 val3807) +;; simple-run-status procedure (x3818) +;; simple-run-status-set! procedure (x3814 val3815) +;; simple-run-target procedure (x3786) +;; simple-run-target-set! procedure (x3782 val3783) +;; simple-run? procedure (x3780) + +(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) + (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)) + (runs-browse-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)) + (header (make-vector nruns)) + (lftcol (make-vector ntests)) + (keycol (make-vector ntests)) + (controls (dboard:make-controls commondat runs-dat)) ;; '()) + (lftlst '()) + (hdrlst '()) + (bdylst '()) + (result '()) + (i 0) + (btn-height (dboard:tabdat-runs-btn-height runs-dat)) + (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) + (cell-width (dboard:tabdat-runs-cell-width runs-dat))) + ;; 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 + (map (lambda (x) + (let ((res (iup:hbox + #:expand "HORIZONTAL" + (iup:label x + #:size (conc 40 btn-height) + #:fontsize btn-fontsz + #:expand "NO") ;; "HORIZONTAL") + (iup:textbox + #:size (conc 35 btn-height) + #:fontsize btn-fontsz + #:value "%" + #:expand "NO" ;; "HORIZONTAL" + #:action (lambda (obj unk val) + ;; each field + ;; (field name is "x" var) live updates + ;; the search filter as it is typed + (dboard:tabdat-target-set! runs-dat #f) + ;; ensure fields text boxes are used + ;; and not the info from the tree + (mark-for-update runs-dat) + (update-search commondat runs-dat x val)))))) + (set! i (+ i 1)) + res)) + keynames))))) + (let loop ((testnum 0) + (res '())) + (cond + ((>= testnum ntests) + ;; now lftlst will be an hbox with the test keys and the test name labels + (set! lftlst + (append + lftlst + (list + (iup:hbox + #:expand "HORIZONTAL" + (iup:valuator + #:valuechanged_cb + (lambda (obj) + (let ((val (string->number (iup:attribute obj "VALUE"))) + (oldmax (string->number (iup:attribute obj "MAX"))) + (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-start-test-offset-set! runs-dat + (inexact->exact (round (/ val 10)))) + (debug:print 6 *default-log-port* + "(dboard:tabdat-start-test-offset runs-dat) " + (dboard:tabdat-start-test-offset runs-dat) " val: " val + " newmax: " newmax " oldmax: " oldmax) + (if (< val 10) + (iup:attribute-set! obj "MAX" newmax)) + )) + #:expand "VERTICAL" + #:orientation "VERTICAL" + #:min 0 + #:step 0.01) + (apply iup:vbox (reverse res))))))) + (else + (let ((labl (iup:button + "" ;; the testname labels + #:flat "YES" + #:alignment "ALEFT" + ; #:image img1 + ; #:impress img2 + #:size (conc cell-width btn-height) + #:expand "HORIZONTAL" + #:fontsize btn-fontsz + #:action (lambda (obj) + (mark-for-update runs-dat) + (toggle-hide testnum (dboard:commondat-uidat commondat)))))) + (vector-set! lftcol testnum labl) + (loop (+ testnum 1)(cons labl res)))))) + ;; These are the headers for each row + (let loop ((runnum 0) + (keynum 0) + (keyvec (make-vector nkeys)) + (res '())) + (cond ;; nb// no else for this approach. + ((>= runnum nruns) #f) + ((>= keynum nkeys) + (vector-set! header runnum keyvec) + (set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst)) + (loop (+ runnum 1) 0 (make-vector nkeys) '())) + (else + (let ((labl (iup:label "" #:size (conc cell-width btn-height) #:fontsize btn-fontsz #:expand "HORIZONTAL"))) ;; #:expand "HORIZONTAL" "60x15" + (vector-set! keyvec keynum labl) + (loop runnum (+ keynum 1) keyvec (cons labl res)))))) + ;; By here the hdrlst contains a list of vboxes containing nkeys labels + (let loop ((runnum 0) + (testnum 0) + (testvec (make-vector ntests)) + (res '())) + (cond + ((>= runnum nruns) #f) ;; (vector tableheader runsvec)) + ((>= testnum ntests) + (vector-set! runsvec runnum testvec) + (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) + (loop (+ runnum 1) 0 (make-vector ntests) '())) + (else + (let* ((button-key (mkstr runnum testnum)) + (butn (iup:button + "" ;; button-key + #:size (conc cell-width btn-height ) + #:expand "HORIZONTAL" + #:fontsize btn-fontsz + #:button-cb + (lambda (obj a pressed x y btn . rem) + ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) + (if (substring-index "3" btn) + (if (eq? pressed 1) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (run-info (rmt:get-run-info run-id)) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path)))) + (iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ;; (print "got here") + )) + (if (eq? pressed 0) + (let* ((toolpath (car (argv))) + (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) + (test-id (db:test-get-id (vector-ref buttndat 3))) + (run-id (db:test-get-run_id (vector-ref buttndat 3)))) + (dboard:launch-testpanel run-id test-id)))))))) + (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) + (vector-set! testvec testnum butn) + (loop runnum (+ testnum 1) testvec (cons butn res)))))) + ;; now assemble the hdrlst and bdylst and kick off the dialog + (iup:show + (iup:dialog + #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) + #:menu (dcommon:main-menu) + #:shrink "YES" + (let* ((runs-view (iup:vbox + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #: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)) + (dashboard:runs-horizontal-slider runs-dat)))) + controls + )) + (views-cfgdat (common:load-views-config)) + (additional-tabnames '()) + (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW + ;; (data (dboard:tabdat-init (make-d:data))) + (additional-views ;; process views-dat + (let ((tab-num tab-start-num) + (result '())) + (for-each + (lambda (view-name) + (debug:print 0 *default-log-port* "Adding view " view-name) + (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? + (if (not (string? cfgtype)) + (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name + "\" is missing needed sections. " + "Please consult the documenation and update ~/.mtviews.config or " + *toppath* "/.mtviews.config") + (case (string->symbol cfgtype) + ;; user supplied source for a tab + ;; + ((external) ;; was tabs + (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) + (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) + (set! tab-num (+ tab-num 1)) + (set! result (append result (list tab-content))))))))) + (sort (hash-table-keys views-cfgdat) + (lambda (a b) + (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) + (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) + (> order-a order-b))))) + result)) + (tabs (apply iup:tabs + #:shrink "YES" + #:tabchangepos-cb (lambda (obj curr prev) + (debug:catch-and-dump + (lambda () + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:tabdat-layout-update-ok-set! tabdat #f)) + (dboard:commondat-curr-tab-num-set! commondat curr) + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:commondat-please-update-set! commondat #t) + (dboard:tabdat-layout-update-ok-set! tabdat #t))) + "tabchangepos")) + (dashboard:summary commondat stats-dat tab-num: 0) + runs-view + ;; (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) + (dashboard:runs-browse commondat runs-browse-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" "Runs2") + (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 "TABTITLE3" "New View") + ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") + (iup:attribute-set! tabs "TABTITLE5" "Runs Browse") + + ;; set the tab names for user added tabs + (for-each + (lambda (tab-info) + (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) + additional-tabnames) + + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + ;; make the iup tabs object available (for changing color for example) + (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) + ;; now set up the tabdat lookup + (dboard:common-set-tabdat! commondat 0 stats-dat) + (dboard:common-set-tabdat! commondat 1 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) + (dboard:common-set-tabdat! commondat 4 runtimes-dat) + (dboard:common-set-tabdat! commondat 5 runs-browse-dat) + + (iup:vbox + tabs + ;; controls + )))) + (vector keycol lftcol header runsvec))) + +(define (dboard:setup-num-rows tabdat) + (dboard:tabdat-num-tests-set! tabdat (string->number + (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS") + "15")))) + +(define *tim* (iup:timer)) +(define *ord* #f) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) +(iup:attribute-set! *tim* "RUN" "YES") + +(define *last-recalc-ended-time* 0) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) + +;; (define *monitor-db-path* #f) +(define *last-monitor-update-time* 0) + +;; Force creation of the db in case it isn't already there. +;; (tasks:open-db) + +(define (dashboard:get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " + ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dashboard:monitor-changed? commondat tabdat) + (let* ((run-update-time (current-seconds)) + (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) + (file-modification-time monitor-db-path) + -1))) + (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) + (or (> monitor-modtime *last-monitor-update-time*) + (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case + (begin + (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) + #t) + #f))) + +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (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)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +;;Not reference anywhere +;; +;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing +;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) +;; +(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) + (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) + (let loop ((i 0) + (rowdat (hash-table-ref/default rowhash rownum '()))) + (if (null? rowdat) + #f + (let rowloop ((bar (car rowdat)) + (tal (cdr rowdat))) + (let ((bx1 (car bar)) + (bx2 (cdr bar))) + (cond + ;; newbar x1 inside bar + ((dashboard:px-between x1 bx1 bx2) #t) + ((dashboard:px-between x2 bx1 bx2) #t) + ((and (<= x1 bx1)(>= x2 bx2)) #t) + (else (if (null? tal) + (if (< i lastrow) + (loop (+ i 1) + (hash-table-ref/default rowhash (+ rownum i) '())) + #f) + (rowloop (car tal)(cdr tal))))))))))) + +(define (dashboard:add-bar rowhash rownum x1 x2 #!key (num-rows 0)) + (let loop ((i 0)) + (hash-table-set! rowhash + (+ i rownum) + (cons (cons x1 x2) + (hash-table-ref/default rowhash (+ i rownum) '()))) + (if (< i num-rows) + (loop (+ i 1))))) + +;; sort a list of test-ids by the event _time using a hash table of id => testdat +;; +(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht) + (sort test-ids + (lambda (a b) + (< (db:test-get-event_time (hash-table-ref tests-ht a)) + (db:test-get-event_time (hash-table-ref tests-ht b)))))) + +;; first group items into lists, then sort by time +;; finally sort by first item time +;; +;; NOTE: we are returning lists of lists of ids! +;; +(define (dboard:tests-sort-by-time-group-by-item testsdat) + (let ((test-ids (hash-table-keys testsdat))) + (if (null? test-ids) + test-ids + ;; now group all tests by testname tname => (id1 id2 ...), tname2 => ( ... + (let* ((test-ids-by-name + (let ((ht (make-hash-table))) + (for-each + (lambda (tdat) + (let ((testname (db:test-get-testname tdat)) + (test-id (db:test-get-id tdat))) + (hash-table-set! + ht + testname + (cons test-id (hash-table-ref/default ht testname '()))))) + (hash-table-values testsdat)) + ht))) + ;; remove toplevel tests from iterated tests, sort tests in the list by event time + (for-each + (lambda (testname) + (let ((tests-id-lst (hash-table-ref test-ids-by-name testname))) + (if (> (length tests-id-lst) 1) ;; must be iterated + (let ((item-tests (filter (lambda (tid) ;; filter out toplevel tests + (let ((tdat (hash-table-ref testsdat tid))) + (not (equal? (db:test-get-item-path tdat) "")))) + tests-id-lst))) + (if (not (null? item-tests)) ;; resist bad data, generally should not fail this condition + (hash-table-set! test-ids-by-name + testname + (dboard:sort-testsdat-by-event-time item-tests testsdat))))))) + (hash-table-keys test-ids-by-name)) + ;; finally sort by the event time of the first test + (sort (hash-table-values test-ids-by-name) + (lambda (a b) + (< (db:test-get-event_time (hash-table-ref testsdat (car a))) + (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) + +;; run times tab data updater +;; +(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) + (let* ((access-mode (dboard:tabdat-access-mode 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-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (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)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (tb (dboard:tabdat-runs-tree tabdat)) + (num-runs (length (hash-table-keys runs-hash))) + (update-start-time (current-seconds)) + (inc-mode #f)) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + ;; fill in the tree + (if (and tb + (not inc-mode)) + (for-each + (lambda (run-id) + (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + (dboard:tabdat-keys tabdat))) + (run-name (db:get-value-by-header run-record runs-header "runname")) + (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + (run-path (append key-vals (list run-name)))) + ;; (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)) + ;; 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)) + ;; (print "Updating rundat") + (if (dboard:tabdat-keys tabdat) ;; have keys yet? + (let* ((num-keys (length (dboard:tabdat-keys tabdat))) + (targpatt (map (lambda (k v) + (list k v)) + (dboard:tabdat-keys tabdat) + (take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/") + '("%" "%")) + (make-list num-keys "%")) + num-keys) + )) + (runpatt (if (and (dboard:tabdat-target tabdat) + (list? (dboard:tabdat-target tabdat)) + (not (null? (dboard:tabdat-target tabdat)))) + (last (dboard:tabdat-target tabdat)) + "%")) + (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) + (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 "reseting 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)) + ;; (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-max-row-set! tabdat 0) + (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) + (update-rundat tabdat + runpatt + ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") + + targpatt + + ;; old method + ;; (let ((res '())) + ;; (for-each (lambda (key) + ;; (if (not (equal? key "runname")) + ;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + ;; (if val (set! res (cons (list key val) res)))))) + ;; (dboard:tabdat-dbkeys tabdat)) + ;; res) + ))))) + +;; run times canvas updater +;; +(define (dashboard:run-times-tab-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))))) + +;; doesn't work. +;; +;;(define (gotoescape tabdat escape) +;; (or (dboard:tabdat-layout-update-ok tabdat) +;; (escape #t))) + +(define (dboard:graph-db-open dbstr) + (let* ((parts (string-split dbstr ":")) + (dbpth (if (< (length parts) 2) ;; assume then a filename was provided + dbstr + (if (equal? (car parts) "sqlite3") + (cadr parts) + (begin + (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) + #f))))) + (if (and dbpth (file-read-access? dbpth)) + (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) + (sqlite3:set-busy-handler! db (make-busy-timeout 10000)) + db) + #f))) + +;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... +;; +(define (dboard:graph-read-data cmdstring tstart tend) + (let* ((parts (string-split cmdstring))) ;; spaces not allowed + (if (< (length parts) 6) ;; sqlite3:path tablename timefieldname varfname valfname field1 field2 ... + (debug:print 0 *default-log-port* "ERROR: malformed graph line: " cmdstring) + (let* ((dbdef (list-ref parts 0)) + (tablen (list-ref parts 1)) + (timef (list-ref parts 2)) + (varfn (list-ref parts 3)) + (valfn (list-ref parts 4)) + (fields (cdr (cddddr parts))) + (db (dboard:graph-db-open dbdef)) + (res-ht (make-hash-table))) + (if db + (begin + (for-each + (lambda (fieldname) ;; fields + (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) + (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) + (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) + (reverse + (sqlite3:fold-row + (lambda (res t var val) + (cons (vector t var val) res)) + '() db all-dat-qrystr))) + (let ((zeropt (handle-exceptions + exn + #f + (sqlite3:first-row db all-dat-qrystr)))) + (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. + (hash-table-set! res-ht + fieldname + (cons + (apply vector tstart (cdr zeropt)) + (hash-table-ref/default res-ht fieldname '()))))))) + fields) + res-ht) + #f))))) + +;; graph data +;; tsc=timescale, tfn=function; time->x +;; +(define (dboard:graph commondat tabdat tabnum llx lly ulx uly tstart tend tsc tfn compname cmargin) + (let* ((dwg (dboard:tabdat-drawing tabdat)) + (lib (vg:get/create-lib dwg "runslib")) + (cnv (dboard:tabdat-cnv tabdat)) + (dur (- tstart tend)) ;; time duration + (cmp (vg:get-component dwg "runslib" compname)) + (cfg (configf:get-section *configdat* "graph")) + (stdcolor (vg:rgb->number 120 130 140)) + (delta-y (- uly lly)) + (graph-matrix-table (dboard:tabdat-graph-matrix-table tabdat)) + (graph-cell-table (dboard:tabdat-graph-cell-table tabdat)) + (graph-matrix (dboard:tabdat-graph-matrix tabdat)) + (changed #f)) + (vg:add-obj-to-comp + cmp + (vg:make-rect-obj llx lly ulx uly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- (tfn tstart) 10)(- lly 10)(seconds->year-week/day-time tstart))) + (let*-values (((span timeunit time-blk first timesym) (common:find-start-mark-and-mark-delta tstart tend))) + (let loop ((mark first) + (count 0)) + (let* ((smark (tfn mark)) ;; scale the mark + (mark-delta (quotient (- mark tstart) time-blk)) ;; how far from first mark + (label (conc (* count span) timesym))) ;; was mark-delta + (if (> count 2) + (begin + (vg:add-obj-to-comp + cmp + (vg:make-rect-obj (- smark 1)(- lly 2)(+ smark 1) lly)) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- smark 1)(- lly 10) label)))) + (if (< mark (- tend time-blk)) + (loop (+ mark time-blk)(+ count 1)))))) + (for-each + (lambda (cf) + (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) + (if alldat + (for-each + (lambda (fieldn) + (let*-values (((dat) (hash-table-ref alldat fieldn)) + ((vals minval maxval) (if (null? dat) + (values '() #f #f) + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '()) + (min (vector-ref (car dat) 2)) + (max (vector-ref (car dat) 2))) + (let* ((val (vector-ref hed 2)) + (newmin (if (< val min) val min)) + (newmax (if (> val max) val max)) + (newres (cons val res))) + (if (null? tal) + (values (reverse res) (- newmin 2) (+ newmax 2)) + (loop (car tal)(cdr tal) newres newmin newmax))))))) + (if (not (hash-table-exists? graph-matrix-table fieldn)) + (begin + (let* ((graph-color-rgb (vg:generate-color-rgb)) + (graph-color (vg:iup-color->number graph-color-rgb)) + (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) + (graph-matrix-row (dboard:tabdat-graph-matrix-row tabdat)) + (graph-cell (conc graph-matrix-row ":" graph-matrix-col)) + (graph-dat (make-dboard:graph-dat + id: fieldn + color: graph-color + flag: #t + cell: graph-cell + ))) + (hash-table-set! graph-matrix-table fieldn graph-dat) + (hash-table-set! graph-cell-table graph-cell graph-dat) + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + ;; (print "Graph data " graph-matrix-row " " graph-matrix-col " " fieldn " " graph-color " " graph-color-rgb " ") + (set! changed #t) + (iup:attribute-set! graph-matrix (conc graph-matrix-row ":" graph-matrix-col) fieldn) + (iup:attribute-set! graph-matrix (conc "BGCOLOR" (conc graph-matrix-row ":" graph-matrix-col)) graph-color-rgb) + (if (> graph-matrix-col 10) + (begin + (dboard:tabdat-graph-matrix-col-set! tabdat 1) + (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) + (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) + ))) + (if (not (null? vals)) + (let* (;; (maxval (apply max vals)) + ;; (minval (min 0 (apply min vals))) + (yoff (- minval lly)) ;; minval)) + (deltaval (- maxval minval)) + (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (graph-dat (hash-table-ref graph-matrix-table fieldn)) + (graph-color (dboard:graph-dat-color graph-dat)) + (graph-flag (dboard:graph-dat-flag graph-dat))) + (if graph-flag + (begin + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) + (vg:add-obj-to-comp + cmp + (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) + (fold + (lambda (next prev) ;; #(time ? val) #(time ? val) + (if prev + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) + (if (>= curr-tval last-tval) + (begin + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj last-tval last-yval curr-tval last-yval + line-color: graph-color)) + (vg:add-obj-to-comp + cmp + ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) + (vg:make-line-obj curr-tval last-yval curr-tval next-yval + line-color: graph-color))) + (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + next) + #f ;; (vector tstart minval minval) + dat) + )))))) ;; for each data point in the series + (hash-table-keys alldat))))) + cfg) + (if changed (iup:attribute-set! graph-matrix "REDRAW" "ALL")))) + +;; run times tab +;; +(define (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) + ;; each test is an object in the run component + ;; each run is a component + ;; all runs stored in runslib library + (let escapeloop ((escape #f)) + (if (and (not escape) + tabdat) + (let* ((canvas-margin 10) + (not-done-runs (dboard:tabdat-not-done-runs tabdat)) + (mtx (dboard:tabdat-runs-mutex tabdat)) + (drawing (dboard:tabdat-drawing tabdat)) + (runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib + (allruns (dboard:tabdat-allruns tabdat)) + (num-runs (length allruns)) + (cnv (dboard:tabdat-cnv tabdat)) + (compact-layout (dboard:tabdat-compact-layout tabdat)) + (row-height (if compact-layout 2 10)) + (graph-height 120) + (run-to-run-margin 25)) + (dboard:tabdat-layout-update-ok-set! tabdat #t) + (if (and (canvas? cnv) + (not (null? allruns))) ;; allruns can go null when browsing the runs tree + (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv)) + ((calc-y) (lambda (rownum) + (- (/ sizey 2) + (* rownum row-height)))) + ((fixed-originx) (if (dboard:tabdat-originx tabdat) + (dboard:tabdat-originx tabdat) + (begin + (dboard:tabdat-originx-set! tabdat originx) + originx))) + ((fixed-originy) (if (dboard:tabdat-originy tabdat) + (dboard:tabdat-originy tabdat) + (begin + (dboard:tabdat-originy-set! tabdat originy) + originy)))) + ;; (print "allruns: " allruns) + (let runloop ((rundat (car allruns)) + (runtal (cdr allruns)) + (run-num 1) + (doneruns '())) + (let* ((run (dboard:rundat-run rundat)) + (rowhash (make-hash-table)) ;; store me in tabdat + (key-val-dat (dboard:rundat-key-vals rundat)) + (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 x x ""))))) + (run-key (string-intersperse key-vals "\n")) + (run-full-name (string-intersperse key-vals "/")) + (curr-run-start-row (dboard:tabdat-max-row tabdat))) + ;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row) + (if (not (vg:lib-get-component runslib run-full-name)) + (let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible. + (not (dboard:rundat-hierdat rundat))) + (let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids + (dboard:rundat-hierdat-set! rundat hd) + hd) + (dboard:rundat-hierdat rundat))) + (tests-ht (dboard:rundat-tests rundat)) + (all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat + (testsdat (hash-table-values tests-ht)) + (runcomp (vg:comp-new));; new component for this run + (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) + ;; (row-height 4) + (run-start (common:min-max < (map db:test-get-event_time testsdat))) + (run-end (let ((re (common:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero + (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) + (run-duration (- run-end run-start)) + (timescale (/ (- sizex (* 2 canvas-margin)) + (if (> run-duration 0) + run-duration + (current-seconds)))) ;; a least lously guess + (maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))) + (num-tests (length hierdat)) + (tot-tests (length testsdat)) + (width (* timescale run-duration)) + (graph-lly (calc-y (/ -50 row-height))) + (graph-uly (- (calc-y 0) canvas-margin)) + (sec-per-50pt (/ 50 timescale)) + ) + ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) + ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) + (mutex-lock! mtx) + (vg:add-comp-to-lib runslib run-full-name runcomp) + ;; Have to keep moving the instantiated box as it is anchored at the lower left + ;; this should have worked for x in next statement? (maptime run-start) + ;; add 60 to make room for the graph + (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) + (mutex-unlock! mtx) + ;; (set! run-start-row (+ max-row 2)) + ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) + ;; get tests in list sorted by event time ascending + (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) + (tests-tal (cdr hierdat)) + (test-num 1)) + (let ((iterated (> (length test-ids) 1)) + (first-rownum #f) + (num-items (length test-ids))) + (let testitemloop ((test-id (car test-ids)) ;; loop on test or test items + (tidstal (cdr test-ids)) + (item-num 1) + (test-objs '())) + (let* ((testdat (hash-table-ref tests-ht test-id)) + (event-time (maptime (db:test-get-event_time testdat))) + (test-duration (* timescale (db:test-get-run_duration testdat))) + (end-time (+ event-time test-duration)) + (test-name (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (test-fullname (conc test-name "/" item-path)) + (name-color (gutils:get-color-for-state-status state status)) + (new-test-objs + (let loop ((rownum 0)) ;; new-run-start-row)) ;; (+ start-row 1))) + (if (dashboard:row-collision rowhash rownum event-time end-time) + (loop (+ rownum 1)) + (let* ((title (if iterated (if compact-layout #f item-path) test-name)) + (lly (calc-y rownum)) ;; (- sizey (* rownum row-height))) + (uly (+ lly row-height)) + (use-end (if (< (- end-time event-time) 2)(+ event-time 2) end-time)) ;; if short grow it a little to give the user something to click on + (obj (vg:make-rect-obj event-time lly use-end uly + fill-color: (vg:iup-color->number (car name-color)) + text: title + font: "Helvetica -10")) + (bar-end (max use-end + (+ event-time + (if compact-layout + 1 + (+ 7 (* (string-length title) 10))))))) ;; 8 pixels per letter + ;; (if iterated + ;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items)) + ;; (if (not first-rownum) + ;; (begin + ;; (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items) + ;; (set! first-rownum rownum))) + (dboard:tabdat-max-row-set! tabdat (max (+ curr-run-start-row rownum) + (dboard:tabdat-max-row tabdat))) ;; track the max row used + ;; bar-end has some margin for text - accounting for text in extents not yet working. + (dashboard:add-bar rowhash rownum event-time bar-end) ;; (+ end-time 5)) + (vg:add-obj-to-comp runcomp obj) + ;; (vg:instance-move drawing run-full-name 0 (calc-y (dboard:tabdat-max-row tabdat))) + (dboard:tabdat-view-changed-set! tabdat #t) + (cons obj test-objs)))))) + ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) + ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) + (if (> item-num 50) + (if (eq? 0 (modulo item-num 50)) + (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) + (let ((newdoneruns (cons rundat doneruns))) + (if (null? tidstal) + (if iterated + (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) + (llx (- (car xtents) 10)) + (lly (- (cadr xtents) 10)) + (ulx (+ 5 (caddr xtents))) + (uly (+ 10 (cadddr xtents)))) + ;; (dashboard:add-bar rowhash 0 llx ulx num-rows: num-items) + ;; This is the box around the tests of an iterated test + (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly + text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids))) + line-color: (vg:rgb->number 0 0 255 a: 128) + font: "Helvetica -10")) + ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) + (dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw + (if (dboard:tabdat-layout-update-ok tabdat) + (testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) + ;; If it is an iterated test put box around it now. + (if (not (null? tests-tal)) + (if #f ;; (> (- (current-seconds) update-start-time) 5) + (print "drawing runs taking too long") + (if (dboard:tabdat-layout-update-ok tabdat) + (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))) + ;; placeholder box + (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1)) + ;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height)))) + ;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y))) + ;; instantiate the component + (let* ((extents (vg:components-get-extents drawing runcomp)) + (new-xtnts (match extents + ((x1 y1 x2 y2)(vg#vg:grow-rect 5 5 x1 y1 x2 y2)) + (else (assert #f "ERROR: wrong # of params for rectangle.")))) + (llx (list-ref new-xtnts 0)) + (lly (list-ref new-xtnts 1)) + (ulx (list-ref new-xtnts 2)) + (uly (list-ref new-xtnts 3)) + (outln (vg:make-rect-obj -5 lly ulx uly + text: run-full-name + line-color: (vg:rgb->number 255 0 255 a: 128)))) + ; (vg:components-get-extents d1 c1))) + ;; this is the box around the run + (mutex-lock! mtx) + (vg:add-obj-to-comp runcomp outln) + (mutex-unlock! mtx) + ;; this is where we have enough info to place the graph + (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) + (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) + ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) + )) + ;; end of the run handling loop + (if (not (dboard:tabdat-layout-update-ok tabdat)) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + (let ((newdoneruns (cons rundat doneruns))) + (if (null? runtal) + (begin + (dboard:rundat-data-changed-set! rundat #f) + (dboard:tabdat-not-done-runs-set! tabdat '()) + (dboard:tabdat-done-runs-set! tabdat allruns)) + (if #f ;; (> (- (current-seconds) update-start-time) 5) + (begin + (print "drawing runs taking too long.... have " (length runtal) " remaining") + ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! + ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) + (dboard:tabdat-not-done-runs-set! tabdat runtal)) + (begin + (if (dboard:tabdat-layout-update-ok tabdat) + (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns) + (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) + ))))))))) ;; new-run-start-row + ))) + (debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))) + +;; handy trick for printing a record +;; +;; (pp (dboard:tabdat->alist tabdat)) +;; +;; removing the tabdat-values proc +;; +;; (define (tabdat-values tabdat) + +;; runs update-rundat using the various filters from the gui +;; +(define (dashboard:do-update-rundat tabdat) + (dboard:update-rundat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; generate key patterns from the target stored in tabdat + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + (if val (set! res (cons (list key val) res)))))) + dbkeys) + res)))) + fres)))) + +(define (dashboard:runs-tab-updater commondat tab-num) + (debug:catch-and-dump + (lambda () + (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) + (dbkeys (dboard:tabdat-dbkeys tabdat))) + (dashboard:do-update-rundat tabdat) + (let ((uidat (dboard:commondat-uidat commondat))) + (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) + )) + "dashboard:runs-tab-updater")) + +;;====================================================================== +;; dcommon.scm contents +;;====================================================================== + +;;====================================================================== +;; C O M M O N D A T A S T R U C T U R E +;;====================================================================== +;; +;; data common to all tabs goes here +;; +(defstruct dboard:commondat + ((curr-tab-num 0) : number) + please-update + tabdats + update-mutex + updaters + updating + uidat ;; needs to move to tabdat at some time + hide-not-hide-tabs + ) + +(define (dboard:commondat-make) + (make-dboard:commondat + curr-tab-num: 0 + tabdats: (make-hash-table) + please-update: #t + update-mutex: (make-mutex) + updaters: (make-hash-table) + updating: #f + hide-not-hide-tabs: #f + )) + +;; RADT => Matrix defstruct addition +(defstruct dboard:graph-dat + ((id #f) : string) + ((color #f) : vector) + ((flag #t) : boolean) + ((cell #f) : number) + ) + +;; data for runs, tests etc. was used in run summary? +;; +(defstruct dboard:runsdat + ;; new system + runs-index ;; target/runname => colnum + tests-index ;; testname/itempath => rownum + matrix-dat ;; vector of vectors rows/cols + ) + +(define (dboard:runsdat-make-init) + (make-dboard:runsdat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +;; used to keep the rundata from rmt:get-tests-for-run +;; in sync. +;; +(defstruct dboard:rundat + run + tests-drawn ;; list of id's already drawn on screen + tests-notdrawn ;; list of id's NOT already drawn + rowsused ;; hash of lists covering what areas used - replace with quadtree + 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 + ((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)) + + +;;====================================================================== +;; D O T F I L E +;;====================================================================== + +(define (dcommon:write-dotfile fname dat) + (with-output-to-file fname + (lambda () + (pp dat)))) + +;;====================================================================== +;; TARGET AND PATTERN MANIPULATIONS +;;====================================================================== + +;; Convert to and from list of lines (for a text box) +;; "," => "\n" +(define (dboard:test-patt->lines test-patt) + (string-substitute (regexp ",") "\n" test-patt)) + +(define (dboard:lines->test-patt lines) + (string-substitute (regexp "\n") "," lines #t)) + + +;;====================================================================== +;; P R O C E S S R U N S +;;====================================================================== + +;; MOVE THIS INTO *data* +(define *cachedata* (make-hash-table)) +(hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) +(hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) + +;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise +;; +(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) + (let ((curr-val (iup:attribute mtrx cell-name))) + (if (not (equal? curr-val new-val)) + (begin + (iup:attribute-set! mtrx cell-name new-val) ;; was col-name + #t) ;; need a re-draw + prev-changed))) + + +;; TO-DO +;; 1. Make "data" hash-table hierarchial store of all displayed data +;; 2. Update synchash to understand "get-runs", "get-tests" etc. +;; 3. Add extraction of filters to synchash calls +;; +;; NOTE: Used in newdashboard +;; +;; Mode is 'full or 'incremental for full refresh or incremental refresh +;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) +;; (let* (;; count and offset => #f so not used +;; ;; the synchash calls modify the "data" hash +;; (changed #f) +;; (get-runs-sig (conc (client:get-signature) " get-runs")) +;; (get-tests-sig (conc (client:get-signature) " get-tests")) +;; (get-details-sig (conc (client:get-signature) " get-test-details")) +;; +;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash +;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) +;; ;; run-id is #f in next line to send the query to server 0 +;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) +;; (tests-detail-changes (if (not (null? test-ids)) +;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) +;; '())) +;; +;; ;; Now can calculate the run-ids +;; (run-hash (hash-table-ref/default data get-runs-sig #f)) +;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) +;; +;; (all-test-changes (let ((res (make-hash-table))) +;; (for-each (lambda (run-id) +;; (if (> run-id 0) +;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) +;; run-ids) +;; res)) +;; (runs-hash (hash-table-ref/default data get-runs-sig #f)) +;; (header (hash-table-ref/default runs-hash "header" #f)) +;; (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)) +;; (time-a (db:get-value-by-header record-a header "event_time")) +;; (time-b (db:get-value-by-header record-b header "event_time"))) +;; (> time-a time-b))) +;; )) +;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) +;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) +;; (colnum 1) +;; (rownum 0) +;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header +;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; +;; ;; tests related stuff +;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) +;; +;; ;; Given a run-id and testname/item_path calculate a cell R:C +;; +;; ;; NOTE: Also build the test tree browser and look up table +;; ;; +;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum +;; (for-each (lambda (run-id) +;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) +;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key)) +;; keys)) +;; (run-name (db:get-value-by-header run-record header "runname")) +;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) +;; (run-path (append key-vals (list run-name)))) +;; (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)) +;; 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 +;; ;; Do this analysis in the order of the run-ids, the most recent run wins +;; (for-each (lambda (run-id) +;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id)) +;; (test-changes (hash-table-ref all-test-changes run-id)) +;; (new-test-dat (car test-changes)) +;; (removed-tests (cadr test-changes)) +;; (tests (sort (map cadr (filter (lambda (testrec) +;; (eq? run-id (db:mintest-get-run_id (cadr testrec)))) +;; new-test-dat)) +;; (lambda (a b) +;; (let ((time-a (db:mintest-get-event_time a)) +;; (time-b (db:mintest-get-event_time b))) +;; (> time-a time-b))))) +;; ;; test-changes is a list of (( id record ) ... ) +;; ;; Get list of test names sorted by time, remove tests +;; (test-names (delete-duplicates (map (lambda (t) +;; (let ((i (db:mintest-get-item_path t)) +;; (n (db:mintest-get-testname t))) +;; (if (string=? i "") +;; (conc " " i) +;; n))) +;; tests))) +;; (colnum (car (hash-table-ref runid-to-col run-id)))) +;; ;; for each test name get the slot if it exists and fill in the cell +;; ;; or take the next slot and fill in the cell, deal with items in the +;; ;; run view panel? The run view panel can have a tree selector for +;; ;; browsing the tests/items +;; +;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY +;; (for-each (lambda (test) +;; (let* ((test-id (db:mintest-get-id test)) +;; (state (db:mintest-get-state test)) +;; (status (db:mintest-get-status test)) +;; (testname (db:mintest-get-testname test)) +;; (itempath (db:mintest-get-item_path test)) +;; (fullname (conc testname "/" itempath)) +;; (dispname (if (string=? itempath "") testname (conc " " itempath))) +;; (rownum (hash-table-ref/default testname-to-row fullname #f)) +;; (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" +;; test-path +;; userdata: (conc "test-id: " test-id)) +;; (let ((node-num (tree:find-node tb (cons "Runs" 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 +;; (conc "COLOR" node-num) +;; color changed)) +;; +;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) +;; ) +;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id) +;; (if (not rownum) +;; (let ((rownums (hash-table-values testname-to-row))) +;; (set! rownum (if (null? rownums) +;; 1 +;; (+ 1 (common:max rownums)))) +;; (hash-table-set! testname-to-row fullname rownum) +;; ;; create the label +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc rownum ":" 0) +;; dispname +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" 0) dispname) +;; )) +;; ;; set the cell text and color +;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc rownum ":" colnum) +;; (if (member state '("ARCHIVED" "COMPLETED")) +;; status +;; state) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc rownum ":" colnum) +;; ;; (if (member state '("ARCHIVED" "COMPLETED")) +;; ;; status +;; ;; state)) +;; (set! changed (dcommon:modifiy-if-different +;; (dboard:tabdat-runs-matrix data) +;; (conc "BGCOLOR" rownum ":" colnum) +;; (car (gutils:get-color-for-state-status state status)) +;; changed)) +;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) +;; ;; (conc "BGCOLOR" rownum ":" colnum) +;; ;; (car (gutils:get-color-for-state-status state status))) +;; )) +;; tests))) +;; run-ids) +;; +;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f))) +;; (if updater (updater (hash-table-ref/default data get-details-sig #f)))) +;; +;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL")) +;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) +;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes) +;; (list run-changes all-test-changes))) + +#;(define (dcommon:runsdat-get-col-num dat target runname force-set) + (let* ((runs-index (dboard:runsdat-runs-index dat)) + (col-name (conc target "/" runname)) + (res (hash-table-ref/default runs-index col-name #f))) + (if res + res + (if force-set + (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index)))))) + (hash-table-set! runs-index col-name max-col-num) + max-col-num))))) + +#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set) + (let* ((tests-index (dboard:runsdat-runs-index dat)) + (row-name (conc testname "/" itempath)) + (res (hash-table-ref/default runs-index row-name #f))) + (if res + res + (if force-set + (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index)))))) + (hash-table-set! runs-index row-name max-row-num) + max-row-num))))) + +(define (dcommon:rundat-copy-tests-to-by-name rundat) + (let ((src-ht (dboard:rundat-tests rundat)) + (trg-ht (dboard:rundat-tests-by-name rundat))) + (if (and (hash-table? src-ht)(hash-table? trg-ht)) + (begin + (hash-table-clear! trg-ht) + (for-each + (lambda (testdat) + (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat)) + (hash-table-values src-ht))) + (debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht)))) + + +;;====================================================================== +;; TESTS DATA +;;====================================================================== + +;; Produce a list of lists ready for common:sparse-list-generate-index +;; +(define (dcommon:minimize-test-data tests-dat) + (if (null? tests-dat) + '() + (let loop ((hed (car tests-dat)) + (tal (cdr tests-dat)) + (res '())) + (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations + (test-name (db:test-get-testname hed)) + (item-path (db:test-get-item-path hed)) + (state (db:test-get-state hed)) + (status (db:test-get-status hed)) + (event-time (db:test-get-event_time hed)) + (newitem (list test-name item-path (list test-id state status event-time)))) + (if (null? tal) + (reverse (cons newitem res)) + (loop (car tal)(cdr tal)(cons newitem res))))))) + +(define (dcommon:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (dcommon:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (cdr ;; cdr to drop first item -- "n/a" + (append (map cadr *common:std-statuses*) + '(#f)) ;; algorithm requres last item to be #f + ) ) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((not mem2) 1) + ((= (length mem1) (length mem2)) 0) + ((> (length mem1) (length mem2)) 1) + (else -1)))) + +(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) + (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) + (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) + (dest-test-id (if dest-value (list-ref dest-value 0) #f)) + (dest-state (if dest-value (list-ref dest-value 1) #f)) + (dest-status (if dest-value (list-ref dest-value 2) #f)) + + (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) + (src-test-id (if src-value (list-ref src-value 0) #f)) + (src-state (if src-value (list-ref src-value 1) #f)) + (src-status (if src-value (list-ref src-value 2) #f)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (dcommon:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) + ))) + (list test-name item-path xor-new-item))) + all-keys))) + + (if hide-clean + (filter + (lambda (item) + ;;(print item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) + +(define (dcommon:examine-xterm run-id test-id) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) + (if (not testdat) + (begin + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* + ((rundir (if testdat + (db:test-get-rundir testdat) + (current-directory))) ;; logfile)) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (xterm (lambda () + (if (directory-exists? rundir) + (let* ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + "")) + (command (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (print "Command =" command) + (common:without-vars + command + "MT_.*")) + (message-window (conc "Directory " rundir " not found")))))) + (xterm) + (print "Adding xterm code"))))) + +;;====================================================================== +;; D A T A T A B L E S +;;====================================================================== + +;; Table of keys +(define (dcommon:keys-matrix rawconfig) + (let* ((curr-row-num 1) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") + (iup:attribute-set! keys-matrix "WIDTH0" 0) + (iup:attribute-set! keys-matrix "0:1" "Key Name") + ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num) + (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:attribute-set! keys-matrix "WIDTHDEF" "40") + keys-matrix)) + +;; Section to table +(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" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (min 10 (length key-vals)) + #:scrollbar "YES"))) + (iup:attribute-set! section-matrix "0:0" varcolname) + (iup:attribute-set! section-matrix "0:1" valcolname) + (iup:attribute-set! section-matrix "WIDTH1" "200") + ;; fill in keys + (for-each + (lambda (var) + ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num)) + (iup:attribute-set! section-matrix (conc curr-row-num ":0") var) + (iup:attribute-set! section-matrix (conc curr-row-num ":1") (configf:lookup rawconfig sectionname var)) + (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var))) + key-vals) + (iup:vbox + (iup:label (if title title (conc "Settings from [" sectionname "]")) + ;; #:size "5x" + #:expand "HORIZONTAL" + ) + section-matrix))) + +;; General data +;; +(define (dcommon:general-info) + (let ((general-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin 2 + #:numcol-visible 1 + #:numlin-visible 2))) + (iup:attribute-set! general-matrix "WIDTH1" "150") + (iup:attribute-set! general-matrix "0:1" "About this Megatest area") + ;; User (this is not always obvious - it is common to run as a different user + (iup:attribute-set! general-matrix "1:0" "User") + (iup:attribute-set! general-matrix "1:1" (current-user-name)) + ;; Megatest area + ;; (iup:attribute-set! general-matrix "2:0" "Area") + ;; (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; Megatest version + (iup:attribute-set! general-matrix "2:0" "Version") + (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + + general-matrix)) + +(define (dcommon:stats-updater commondat tabdat stats-matrix) + (if (and (iup:ihandle? stats-matrix) + (dashboard:database-changed? commondat tabdat context-key: 'run-stats)) + (let* ((changed #f) + (run-stats (rmt:get-run-stats)) + (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) + (row-indices (car indices)) + (col-indices (cadr indices)) + (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + (max-col (if (null? col-indices) 1 + (common:max (map cadr col-indices)))) + (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) + (max-col-vis (if (> max-col 10) 10 max-col)) + (numrows 1) + (numcols 1)) + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! stats-matrix "NUMCOL" max-col ) + (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) + (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) + ;;(print "row-indices: " row-indices " col-indices: " col-indices) + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + row-indices) + + ;; Col labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute stats-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key name))))) + col-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (car entry)) + (col-name (cadr entry)) + (value (caddr entry)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (if (not (equal? (iup:attribute stats-matrix key) value)) + (begin + (set! changed #t) + (iup:attribute-set! stats-matrix key value))))) + run-stats) + (if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL"))))) + + +(define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) + (let* ((stats-matrix (iup:matrix expand: "YES")) + (stats-updater (lambda () + (dcommon:stats-updater commondat tabdat stats-matrix)))) + ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass + ;; (mark-for-update tabdat) + ;; (stats-updater) + (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num) + ;; (set! dashboard:update-summary-tab updater) + (iup:attribute-set! stats-matrix "WIDTHDEF" "40") + (iup:vbox + ;; (iup:label "Run statistics" #:expand "HORIZONTAL") + stats-matrix))) + +(define (dcommon:servers-table commondat tabdat) + (let* ((colnum 0) + (rownum 0) + (servers-matrix (iup:matrix #:expand "YES" + #:numcol 7 + #:numcol-visible 7 + #:numlin-visible 5 + )) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) + (updater (lambda () + (if (dashboard:monitor-changed? commondat tabdat) + (let ((servers (server:get-list *toppath* limit: 10))) + (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) + ;; (set! colnum 0) + ;; (for-each (lambda (colname) + ;; ;; (print "colnum: " colnum " colname: " colname) + ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + ;; (set! colnum (+ 1 colnum))) + ;; colnames) + (set! rownum 1) + (for-each + (lambda (server) + (set! colnum 0) + (match-let (((mod-time host port start-time server-id pid) + server)) + (let* ((uptime (- (current-seconds) mod-time)) + (runtime (if start-time + (- mod-time start-time) + 0)) + (vals (list "-" ;; (vector-ref server 0) ;; Id + "-" ;; (vector-ref server 9) ;; MT-Ver + pid ;; (vector-ref server 1) ;; Pid + host ;; (vector-ref server 2) ;; Hostname + (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) + (cond + ((< uptime 5) "alive") + ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State + (else "dead")) + "-" ;; (vector-ref server 12) ;; RunId + ))) + (for-each (lambda (val) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) + vals) + (set! rownum (+ rownum 1))) + (iup:attribute-set! servers-matrix "REDRAW" "ALL"))) + (sort servers (lambda (a b)(> (car a)(car b)))))))))) + (set! colnum 0) + (for-each (lambda (colname) + (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) + (set! colnum (+ colnum 1))) + colnames) + ;; (set! dashboard:update-servers-table updater) + (dboard:commondat-add-updater commondat updater) + ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") + ;; (iup:hbox + ;; (iup:vbox + ;; (iup:button "Start" + ;; ;; #:size "50x" + ;; #:expand "YES" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Stop" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0 &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Restart" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0;megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))) + ;; servers-matrix + ;; ))) + servers-matrix + )) + +;; The main menu +(define (dcommon:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (let* ((area-name (iup:textbox #:expand "HORIZONTAL")) + (fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))) + ;; (lambda (obj) + ;; (iup:show (iup:file-dialog)) + ;; (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +;;====================================================================== +;; CANVAS STUFF FOR TESTS +;;====================================================================== + +(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected) + (let* ((llx (dcommon:x->canvas x scalef xoffset)) + (lly (dcommon:y->canvas y scalef yoffset)) + (urx (dcommon:x->canvas (+ x w) scalef xoffset)) + (ury (dcommon:y->canvas (+ y h) scalef yoffset))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) + (canvas-rectangle! cnv llx urx lly ury) + (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) + +(define (dcommon:draw-arrow cnv test-box-center waiton-center) + (let* ((test-box-center-x (vector-ref test-box-center 0)) + (test-box-center-y (vector-ref test-box-center 1)) + (waiton-center-x (vector-ref waiton-center 0)) + (waiton-center-y (vector-ref waiton-center 1)) + (delta-y (- waiton-center-y test-box-center-y)) + (delta-x (- waiton-center-x test-box-center-x)) + (abs-delta-x (abs delta-x)) + (abs-delta-y (abs delta-y)) + (use-delta-x (> abs-delta-x abs-delta-y)) ;; use the larger one + (delta-ratio (if use-delta-x + (if (> abs-delta-x 0) + (/ abs-delta-y abs-delta-x) + 1) + (if (> abs-delta-y 0) + (/ abs-delta-x abs-delta-y) + 1))) + (x-adj (if use-delta-x + 8 + (* delta-ratio 8))) + (y-adj (if use-delta-x + (* x-adj delta-ratio) + 8)) + (new-waiton-x (inexact->exact + (round (if (> delta-x 0) ;; have positive x + (- waiton-center-x x-adj) + (+ waiton-center-x x-adj))))) + (new-waiton-y (inexact->exact + (round (if (> delta-y 0) + (- waiton-center-y y-adj) + (+ waiton-center-y y-adj)))))) + ;; (canvas-line-width-set! cnv 5) + (canvas-line! cnv + test-box-center-x + test-box-center-y + new-waiton-x + new-waiton-y + ) + (canvas-mark! cnv new-waiton-x new-waiton-y))) + +(define (dcommon:get-box-center box) + (let* ((llx (list-ref box 0)) + (lly (list-ref box 1)) + (boxw (list-ref box 4)) + (boxh (list-ref box 5))) + (vector (+ llx (/ boxw 2)) + (+ lly (/ boxh 2))))) + +(define-inline (num->int num) + (inexact->exact (round num))) + +(define (dcommon:draw-edges cnv xoffset yoffset scalef edges) + (for-each + (lambda (e) + (let loop ((x1 (car e)) + (y1 (cadr e)) + (x2 #f) + (y2 #f) + (tal (cddr e))) + (if (and x1 y1 x2 y2) + (canvas-line! + cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset)) + (num->int (dcommon:x->canvas x2 scalef xoffset)) + (num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2))) + (if (< (length tal) 2) + (canvas-mark! cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1)) + (loop (car tal)(cadr tal) x1 y1 (cddr tal))))) + ;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges))) + edges)) + + +(define (dcommon:draw-arrows cnv testname tests-hash test-records) + (let* ((test-box-info (hash-table-ref tests-hash testname)) + (test-box-center (dcommon:get-box-center test-box-info)) + (test-record (hash-table-ref test-records testname)) + (waitons (vector-ref test-record 2))) + (for-each + (lambda (waiton) + (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f)) + (waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info)))) + (dcommon:draw-arrow cnv test-box-center waiton-center))) + waitons) + ;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info) + ;; (debug:print 0 *default-log-port* "test-record=" test-record) + )) + +(define (dcommon:estimate-scale sizex sizey originx originy nodes) + ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes) + (let* ((maxx 1) + (maxy 1)) + (for-each + (lambda (node) + (if (equal? (car node) "node") + (let ((x (string->number (list-ref node 2))) + (y (string->number (list-ref node 3)))) + (if (and x (> x maxx))(set! maxx x)) + (if (and y (> y maxy))(set! maxy y))))) + nodes) + (let ((scalex (/ sizex maxx)) + (scaley (/ sizey maxy))) + ;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley) + (min scalex scaley)))) + +(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in) + (let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0))) + (sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500)))) + (hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizex sizex) + (* (/ sizex 2) (- 0.5 xadj)))) + +(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in) + (let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0))) + (sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500)))) + (hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizey sizey) + (* (/ sizey 2) (- yadj 0.5)))) + +(define (dcommon:x->canvas x scalef xoffset) + (+ xoffset (* x scalef))) + +(define (dcommon:y->canvas y scalef yoffset) + (+ yoffset (* y scalef))) + +;; sizex, sizey - canvas size +;; originx, originy - canvas origin +;; +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) + (let* ((dot-data ;; (map cdr (filter + ;; (lambda (x)(equal? "node" (car x))) + (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (no-dot (configf:lookup *configdat* "setup" "nodot")) + (boxh 15) + (boxw 10) + (margin 5) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests )) + (scalef (if no-dot + 1 + (dcommon:estimate-scale sizex sizey originx originy dot-data))) + (sorted-testnames (if no-dot + (sort sorted-testnames string>=?) + sorted-testnames)) + (curr-x 0) ;; NB// NOT screen units + (curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot + (scaled-sizex (/ sizex scalef))) + + (hash-table-set! tests-draw-state 'scalef scalef) + + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) + (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) + (if (> x-max boxw)(set! boxw (+ 10 x-max))))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((nodedat (if no-dot + #f + (let ((tmpres (filter (lambda (x) + (if (and (not (null? x)) + (equal? (car x) "node")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (if (null? tmpres) + ;; llx lly boxw boxh + (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found + (car tmpres))))) + (edgedat (if no-dot + '() + (let ((edges (filter (lambda (x) ;; filter for edge + (if (and (not (null? x)) + (equal? (car x) "edge")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (map (lambda (inlst) + (dcommon:process-polyline + (map (lambda (instr) + (string->number instr)) ;; convert to number and scale + (let ((il (cddddr inlst))) + (take il (- (length il) 2)))) + (lambda (x y) + (list (+ x 0) ;; xtorig) + (+ y 0))) ;; ytorig))) + #f #f)) ;; process polyline + edges)))) + (cx (if no-dot ;; this is the centerpoint! + curr-x + (string->number (list-ref nodedat 2)))) + (cy (if no-dot + curr-y + (string->number (list-ref nodedat 3)))) + (boxw (if no-dot + boxw + (string->number (list-ref nodedat 4)))) + (boxh (if no-dot + boxh + (string->number (list-ref nodedat 5)))) + (boxw/2 (/ boxw 2)) + (boxh/2 (/ boxh 2)) + (urx (+ cx boxw/2)) + (ury (+ cy boxh/2)) + (llx (- cx boxw/2)) + (lly (- cy boxh/2))) + + ;; if we are in no-dot mode then increment curr-x and curr-y as needed + (if no-dot + (begin + (cond + ((< curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x (+ curr-x boxw margin))) + ((> curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x 0) + (set! curr-y (- curr-y (+ boxh margin))))))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; (dcommon:draw-arrows cnv testname tests-info test-records)) + (dcommon:draw-edges cnv xoffset yoffset scalef edgedat) + + ;; data used by mouse click calc. keep the wacky order for now. + (hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat)) + (if (not (null? tal)) + (loop (car tal) + (cdr tal)))))) + )) + +;; per-point-proc required, remainder optional +;; +(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc) + (if (< (length line) 2) + '() + (let loop ((x1 (car line)) + (y1 (cadr line)) + (x2 #f) + (y2 #f) + (tal (cddr line)) + (res '())) + (if (and x1 y1 x2 y2 per-segment-proc) + (per-segment-proc x1 y1 x2 y2)) + (if (< (length tal) 2) + (begin + (if last-segment-proc (last-segment-proc x1 y1 x2 y2)) + (append res (per-point-proc x1 y1))) + (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1))))))) + +(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) + (let* ((scalef (hash-table-ref tests-draw-state 'scalef)) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((tvals (hash-table-ref tests-info hed)) + (llx (list-ref tvals 0)) + (lly (list-ref tvals 1)) + (boxw (list-ref tvals 4)) + (boxh (list-ref tvals 5)) + (edges (map (lambda (pline) + (dcommon:process-polyline pline + (lambda (x1 y1) + (list x1 y1)) + #f #f)) + (list-ref tvals 6))) + (urx (+ llx boxw)) + (ury (+ lly boxh))) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (dcommon:draw-edges cnv xoffset yoffset scalef edges) + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (loop (car tal) + (cdr tal)))))))) + +;;====================================================================== +;; RUN CONTROLS +;;====================================================================== + +(define (dcommon:command-execution-control data) + ;; The command line display/exectution control + (iup:frame + #:title "Command to be exectuted" + (iup:hbox + (iup:label "Run on" #:size "40x") + (iup:radio + (iup:hbox + (iup:toggle "Local" #:size "40x") + (iup:toggle "Server" #:size "40x"))) + (let ((tb (iup:textbox + #:value "megatest " + #:expand "HORIZONTAL" + #:readonly "YES" + #:font "Courier New, -12" + ))) + (dboard:tabdat-command-tb-set! data tb) + tb) + (iup:button "Execute" #:size "50x" + #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))))))) + ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))))) + +(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) + (iup:frame + #:title "Set the action to take" + (iup:hbox + ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") + (let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + ;; (print obj " " val " " index " " lbstate) + (dboard:tabdat-command-set! tabdat val) + (dashboard:update-run-command tabdat)))) + (default-cmd (car cmds-list))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (dboard:tabdat-command-set! tabdat default-cmd) + lb)))) + +(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data) + (iup:frame + #:title "Runname" + (let* ((default-run-name (seconds->work-week/day (current-seconds))) + (tb (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj val txt) + (debug:catch-and-dump + (lambda () + ;; (print "obj: " obj " val: " val " unk: " unk) + (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) + (dashboard:update-run-command tabdat)) + "command-runname-selector tb action")) + #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (debug:catch-and-dump + (lambda () + (if (not (equal? val "")) + (begin + (iup:attribute-set! tb "VALUE" val) + (dboard:tabdat-run-name-set! tabdat val) + (dashboard:update-run-command tabdat)))) + "command-runname-selector lb action")))) + (refresh-runs-list (lambda () + (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) + (let* (;; (target (dboard:tabdat-target-string tabdat)) + (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) + (runs-header (vector-ref runs-for-targ 0)) + (runs-dat (vector-ref runs-for-targ 1)) + (run-names (cons default-run-name + (map (lambda (x) + (db:get-value-by-header x runs-header "runname")) + runs-dat)))) + ;; (print "DEBUGINFO: run-names=" run-names) + ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") + (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) + ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) + (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) + ;; (refresh-runs-list) + (dboard:tabdat-run-name-set! tabdat default-run-name) + (iup:hbox + tb + lb)))) + +(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;; key-listboxes) + (iup:vbox + ;; Text box for test patterns + (iup:frame + #:title "Test patterns (one per line)" + (let ((tb (iup:textbox #:action (lambda (val a b) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-test-patts-set!-use + tabdat + (dboard:lines->test-patt b)) + (dashboard:update-run-command tabdat)) + "command-testname-selector tb action")) + #:value (dboard:test-patt->lines + (dboard:tabdat-test-patts-use tabdat)) + #:expand "YES" + #:size "x30" ;; was 10x30 + #:multiline "YES"))) + (set! test-patterns-textbox tb) + (dboard:tabdat-test-patterns-textbox-set! tabdat tb) + tb)) +;; (iup:frame +;; #:title "Target" +;; ;; Target selectors +;; (apply iup:hbox +;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals)) +;; (key-lb (car dat)) +;; (combos (cadr dat))) +;; combos))) + ;; (iup:hbox + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "States" + ;; (dashboard:text-list-toggle-box + ;; ;; Move these definitions to common and find the other useages and replace! + ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + ;; (lambda (all) + ;; (dboard:tabdat-states-set! tabdat all) + ;; (dashboard:update-run-command tabdat)))) + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "Statuses" + ;; (dashboard:text-list-toggle-box + ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + ;; (lambda (all) + ;; (dboard:tabdat-statuses-set! tabdat all) + ;; (dashboard:update-run-command tabdat))))) + )) + +(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state) + (iup:frame + #:title "Tests and Tasks" + (let* ((updater #f) + (last-xadj 0) + (last-yadj 0) + (the-cnv #f) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (set! last-xadj xadj) + (set! last-yadj yadj)))) + (updater xadj yadj) + (set! the-cnv cnv) + )) + ;; Following doesn't work + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (let ((scalef (hash-table-ref tests-draw-state 'scalef))) + (hash-table-set! tests-draw-state 'scalef (+ scalef + (if (> step 0) + (* 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 "250x250" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:button-cb (lambda (obj btn pressed x y status) + ;; (print "obj: " obj ", pressed " pressed ", status " status) + ; (print "canvas-origin: " (canvas-origin the-cnv)) + ;; (let-values (((xx yy)(canvas-origin the-cnv))) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) + (scalef (hash-table-ref tests-draw-state 'scalef)) + (sizey (hash-table-ref tests-draw-state 'sizey)) + (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) + (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) + (new-y (- sizey y)) + (test-patterns-textbox (dboard:tabdat-test-patterns-textbox tabdat))) + ;; (print "xoffset=" xoffset ", yoffset=" yoffset) + ;; (print "\tx\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) + (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) + (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) + (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) + ;; (if (eq? pressed 1) + ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) + (if (and (eq? pressed 1) + (>= x llx) + (>= new-y lly) + (<= x urx) + (<= new-y ury)) + (let* ((box-patterns (string-split (iup:attribute test-patterns-textbox "VALUE"))) + (test-patts (string-split (or (dboard:tabdat-test-patts tabdat) + "") + ",")) + (patterns (delete-duplicates (append box-patterns test-patts)))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (dboard:tabdat-test-patts-set!-use tabdat (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command tabdat) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) + canvas-obj))) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +(define (dcommon:populate-steps teststeps steps-matrix run-id test-id) + (let* ((max-row 0) + (max-col 9) + (white "255 255 255") + + (testinfo (rmt:get-testinfo-state-status run-id test-id)) + (state (db:test-get-state testinfo)) + (status (db:test-get-status testinfo)) + (test-status-color (car (gutils:get-color-for-state-status state status))) + (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) + (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) + (if (null? teststeps) + (begin + (iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS")) + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (colnum 1)) + (if (> rownum max-row)(set! max-row rownum)) + (let* ((status (vector-ref hed 3)) + (val (vector-ref hed (- colnum 1))) + (bgcolor (cond + ((member (conc status) '("" "-" "#")) + running-color) + + ((member (conc status) '("0" 0)) + white) + (else test-status-color))) + ; (else failcolor))) + (mtrx-rc (conc rownum ":" colnum))) + ;;(print "BB> status=>"status"< bgcolor="bgcolor) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 5) + (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor)) + (if (< colnum max-col) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) (+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) + (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum max-col) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) + +;;====================================================================== +;; U T I L I T I E S +;;====================================================================== + +(define (dcommon:run-html-viewer lfilename) + (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd"))) + (if htmlviewercmd + (system (conc "(" htmlviewercmd " " lfilename " ) &")) + (iup:send-url lfilename)))) + +(define (dashboard:monitor-changed? commondat tabdat) + (let* ((run-update-time (current-seconds)) + (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) + (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) + (file-modification-time monitor-db-path) + -1))) + (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) + (or (> monitor-modtime *last-monitor-update-time*) + (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case + (begin + (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) + #t) + #f))) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (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)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +(define (dashboard:get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) + " db-dir="dbdir ", exn=" exn) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dboard:get-last-db-update tabdat context) + (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) + +(define (dboard:set-last-db-update! tabdat context newtime) + (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) + +;; point inside line +;; +(define-inline (dashboard:px-between px lx1 lx2) + (and (< lx1 px)(> lx2 px))) + +(define (dashboard:recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) + +;;====================================================================== +;; dashboard-guimonitor.scm +;;====================================================================== + +(define (control-panel db tdb keys) + (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove? + (key-params (make-hash-table)) + (monitordat '()) ;; list of monitor records + (keyentries (iup:frame + #:title "Keys" + (apply + iup:vbox + (map (lambda (key) + (iup:hbox (iup:label (vector-ref key 0) #:size "60x15") ; #:expand "HORIZONTAL") + (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj a val) + (hash-table-set! key-params (vector-ref key 0) val))))) + keys)))) + (othervars (iup:frame + #:title "Run Vars" + (apply + iup:vbox + (map (lambda (var) + (iup:hbox (iup:label var #:size "60x15") + (iup:textbox #:expand "HORIZONTAL" + #:action (lambda (obj a val) + (hash-table-set! var-params var val))))) + (list "runname" "testpatts" "params"))))) + (controls (iup:frame + #:title "Controls" + (iup:hbox + (iup:frame + #:title "Runs" + (iup:hbox + (iup:button "Start" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (tasks:add-from-params tdb "run" keys key-params var-params) + (print "Launch Run"))) + (iup:button "Remove" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (print "Remove Run") + (tasks:add-from-params tdb "remove" keys key-params var-params) + )) + (iup:button "Rollup" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (print "Rollup Run") + (tasks:add-from-params tdb "rollup" keys key-params var-params))))) + (iup:frame + #:title "Misc" + (iup:hbox + (iup:button "Quit" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (sqlite3:finalize! db) + (sqlite3:finalize! tdb) + (exit)))))))) + (monitors (iup:textbox + #:expand "YES" ; HORIZONTAL" + ; #:size "x40" + #:multiline "YES" + #:font "Courier New, -10" + #:value "None...............................................")) + (actions (iup:textbox + #:expand "YES" + #:multiline "YES" + #:font "Courier New, -10" + #:value "None...............................................")) + (lastmodtime 0) + (next-touch 0) ;; the last time the "last_update" field was updated + (refreshdat (lambda () + (let* ((monitordbpath (conc *toppath* "/monitor.db")) + (megatestdbpath (conc *toppath* "/megatest.db")) + (modtime (max (file-modification-time megatestdbpath) + (file-modification-time monitordbpath)))) + ;; do stuff here when the db is updated by some other process + (if (> modtime lastmodtime) + (let ((tlst (tasks:get-tasks tdb '() '())) + (mlst (tasks:get-monitors tdb))) + (set! tasksdat tlst) + (set! monitorsdat mlst) + (iup:attribute-set! monitors "VALUE" (tasks:monitors->text-table mlst)) + (iup:attribute-set! actions "VALUE" (tasks:tasks->text tlst)) + (tasks:process-queue db tdb) + (set! lastmodtime (max (file-modification-time megatestdbpath) + (file-modification-time monitordbpath))) + (tasks:reset-stuck-tasks tdb))) + ;; stuff to do every 10 seconds + (if (> (current-seconds) next-touch) + (begin + ;; (tasks:process-queue db tdb monitordbpath) + (tasks:monitors-update tdb) + (tasks:reset-stuck-tasks tdb) + (set! monitorsdat (tasks:get-monitors tdb)) + (set! next-touch (+ (current-seconds) 10)) + ))))) + (topdialog #f)) + (set! topdialog (iup:dialog + #:close_cb (lambda (a)(exit)) + #:title "Run Controls" + (iup:vbox + (iup:hbox keyentries othervars) + controls + (let ((tabtop (iup:tabs + (iup:vbox + (let* ((tb (iup:textbox #:expand "HORIZONTAL")) + (bt (iup:button "Remove tasks by id" + #:action (lambda (obj) + (let ((val (iup:attribute tb "VALUE"))) + (tasks:remove-queue-entries tdb val))))) + (lb (iup:label "(comma separated)"))) + (iup:hbox bt tb lb)) + actions) + monitors + ))) + (iup:attribute-set! tabtop "TABTITLE0" "Actions") + (iup:attribute-set! tabtop "TABTITLE1" "Monitors") + tabtop) + ))) + ; (iup:frame + ; #:title "Monitors" + ; monitors) + ; (iup:frame + ; #:title "Actions" + ; actions)))) + + (iup:show topdialog) + (iup:callback-set! *tim* "ACTION_CB" + (lambda (x) + (refreshdat) + (if *exit-started* + (set! *exit-started* 'ok)))))) + +(define (main-window setuptab fsltab collateraltab toolstab) + (iup:show + (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES" + (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab))) + (iup:attribute-set! tabtop "TABTITLE0" "Setup") + (iup:attribute-set! tabtop "TABTITLE1" "Collateral") + (iup:attribute-set! tabtop "TABTITLE2" "Fossil") + (iup:attribute-set! tabtop "TABTITLE3" "Tools") + tabtop)))) + +;; BUG: Remember to re-instate this!!!! +;; (on-exit (lambda () +;; (let ((tdb (tasks:open-db))) +;; ;; (print "On-exit called") +;; (tasks:remove-monitor-record tdb) +;; (sqlite3:finalize! tdb)))) + +(define (gui-monitor db) + (let ((keys (db:get-keys db)) + (tdb (tasks:open-db))) + (tasks:register-monitor db tdb) ;;; let the other monitors know we are here + (control-panel db tdb keys) + ;(tasks:remove-monitor-record db) + ;(sqlite3:finalize! db) + )) + +;;====================================================================== +;; dashboard-tests.scm +;;====================================================================== + +;;====================================================================== +;; C O M M O N +;;====================================================================== + +(define *dashboard-comment-share-slot* #f) + +(define (message-window msg) + (iup:show + (iup:dialog + (iup:vbox + (iup:label msg #:margin "40x40"))))) + +(define (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + + +(define (test-info-panel testdat store-label widgets) + (iup:frame + #:title "Test Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: " + "Test id: " + "Test date: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-label "testname" + (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-testname testdat))) + (store-label "item-path" + (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-item-path testdat))) + (store-label "teststate" + (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-state testdat))) + (let ((lbl (iup:label (db:test-get-status testdat) #:expand "HORIZONTAL"))) + (hash-table-set! widgets "teststatus" + (lambda (testdat) + (let ((newstatus (db:test-get-status testdat)) + (oldstatus (iup:attribute lbl "TITLE"))) + (if (not (equal? oldstatus newstatus)) + (begin + (iup:attribute-set! lbl "FGCOLOR" (car (gutils:get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) + (iup:attribute-set! lbl "TITLE" (db:test-get-status testdat))))))) + lbl) + (store-label "testcomment" + (iup:label "TestComment " + #:expand "HORIZONTAL") + (lambda (testdat) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-share-slot* + "VALUE" + newcomment))) + newcomment))) + (store-label "testid" + (iup:label "TestId " + #:expand "HORIZONTAL") + (lambda (testdat) + (db:test-get-id testdat))) + (store-label "testdate" + (iup:label "TestDate " + #:expand "HORIZONTAL") + (lambda (testdat) + (seconds->work-week/day-time (db:test-get-event_time testdat)))) + ))))) + +;;====================================================================== +;; Test meta panel +;;====================================================================== + +(define (test-meta-panel-get-description testmeta) + (fmt #f (with-width 40 (wrap-lines (db:testmeta-get-description testmeta))))) + +(define (test-meta-panel testmeta store-meta) + (iup:frame + #:title "Test Meta Data" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Author: " + "Owner: " + "Reviewed: " + "Tags: " + "Description: ")) + (list (iup:label "" #:expand "VERTICAL")))) + (apply iup:vbox ; #:expand "YES" + (list + (store-meta "author" + (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-author testmeta))) + (store-meta "owner" + (iup:label (db:testmeta-get-owner testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-owner testmeta))) + (store-meta "reviewed" + (iup:label (db:testmeta-get-reviewed testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) + (store-meta "tags" + (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") + (lambda (testmeta)(db:testmeta-get-tags testmeta))) + (store-meta "description" + (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") + (lambda (testmeta) + (test-meta-panel-get-description testmeta))) + ))))) + + +;;====================================================================== +;; Run info panel +;;====================================================================== +(define (run-info-panel db keydat testdat runname) + (let* ((run-id (db:test-get-run_id testdat)) + (rundat (rmt:get-run-info run-id)) + (header (db:get-header rundat)) + (event_time (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "event_time"))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " "))) + keydat) + (list (iup:label "runname ") + (iup:label "run-id") + (iup:label "run-date")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname) + (iup:label (conc run-id)) + (iup:label (seconds->year-work-week/day-time event_time)) + (iup:label "" #:expand "VERTICAL")))))))) + +;;====================================================================== +;; Host info panel +;;====================================================================== +(define (host-info-panel testdat store-label) + (iup:frame + #:title "Remote host and Test Run Info" ; #:expand "YES" + (iup:hbox ; #:expand "YES" + (apply iup:vbox ; #:expand "YES" ;; The heading labels + (append (map (lambda (val) + (iup:label val ; #:expand "HORIZONTAL" + )) + (list "Hostname: " + "Disk free: " + "CPU Load: " + "Run duration: " + "Logfile: " + "Top process id: " + "Uname -a: ")) + (iup:label "" #:expand "VERTICAL"))) + (apply iup:vbox ; #:expand "YES" + (list + ;; NOTE: Yes, the host can change! + (store-label "HostName" + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") + (lambda (testdat)(db:test-get-host testdat))) + (store-label "DiskFree" + (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-diskfree testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-cpuload testdat)))) + (store-label "RunDuration" + (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") + (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) + (store-label "LogFile" + (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-final_logf testdat)))) + (store-label "ProcessId" + (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") + (lambda (testdat)(conc (db:test-get-process_id testdat)))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") ;; #:wordwrap "YES") + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) + ))))) + +;; if there is a submegatest create a button to launch dashboard in that area +;; +(define (submegatest-panel dbstruct keydat testdat runname testconfig) + (let* ((test-run-dir (db:test-get-rundir testdat)) + (subarea (subrun:get-runarea test-run-dir)) + (area-exists (and subarea (common:file-exists? subarea silent: #t))) + (target #f) + (runname #f) + (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp"))) + (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard + (let* ((cmd-parts (if (file-exists? cmd-parts-file) + (with-input-from-file cmd-parts-file + read) + '())) + (target (alist-ref "-target" cmd-parts equal?)) + (runname (alist-ref "-runname" cmd-parts equal?)) + (run-area (alist-ref "-startdir" cmd-parts equal?))) + (iup:frame + #:title "Megatest Run Info" ; #:expand "YES" + (iup:vbox + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir))) + (iup:button + "Launch Dashboard+Filter" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir target: target runname: runname)))))) + (iup:vbox)))) + +;; use a global for setting the buttons colors +;; state status teststeps +(define *state-status* (vector #f #f #f)) +(define (update-state-status-buttons testdat) + (let* ((state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (color (car (gutils:get-color-for-state-status state status)))) + ((vector-ref *state-status* 0) state color) + ((vector-ref *state-status* 1) status color))) + +(define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) + +;;====================================================================== +;; Set fields +;;====================================================================== +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) + (let ((newcomment #f) + (newstatus #f) + (newstate #f) + (wtxtbox #f)) + (iup:frame + #:title "Set fields" + (iup:vbox + (iup:hbox (iup:label "Comment:") + (let ((txtbox (iup:textbox #:action (lambda (val a b) + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (rmt:test-set-state-status run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + + (apply iup:hbox + (iup:label "STATE:" #:size "30x") + (let* ((btns (map (lambda (state) + (let ((btn (iup:button state + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + (db:test-set-state! testdat state))))) + btn)) + (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) + (vector-set! *state-status* 0 + (lambda (state color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name state) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)) + (apply iup:hbox + (iup:label "STATUS:" #:size "30x") + (let* ((btns (map (lambda (status) + (let ((btn (iup:button status + #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" + #:action (lambda (x) + (let ((t (iup:attribute x "TITLE"))) + (if (equal? t "WAIVED") + (iup:show (dashboard-tests:waiver run-id testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + (db:test-set-status! testdat status)))))))) + btn)) + (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) + (vector-set! *state-status* 1 + (lambda (status color) + (for-each + (lambda (btn) + (let* ((name (iup:attribute btn "TITLE")) + (newcolor (if (equal? name status) color "192 192 192"))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) + btns))) + btns)))))) + +(define (dashboard-tests:run-a-step info) + #t) + +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) + +(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) + (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) + (wregx (if (string? wpatt)(regexp wpatt) #f)) + (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) + (comnt (iup:textbox #:action (lambda (val a b) + (if wpatt + (if (string-match wregx b) + (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) + (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) + ))) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) + #:expand "HORIZONTAL")) + (dlog #f)) + (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title "SET WAIVER" + (iup:vbox ; #:expand "YES" + (iup:label (conc "Enter justification for waiving test " + (db:test-get-testname testdat) + (if (equal? (db:test-get-item-path testdat) "") + "" + (conc "/" (db:test-get-item-path testdat))))) + wmesg ;; the informational msg on whether it matches + comnt + (iup:hbox + (iup:button "Apply and Close " + #:expand "HORIZONTAL" + #:action (lambda (obj) + (let ((comment (iup:attribute comnt "VALUE")) + (test-id (db:test-get-id testdat))) + (if (or (not wpatt) + (string-match wregx comment)) + (begin + ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status run-id test-id #f "WAIVED" comment) + (db:test-set-status! testdat "WAIVED") + (cmtcmd comment) + (iup:destroy! dlog)))))) + (iup:button "Cancel" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (iup:destroy! dlog))))))) + dlog)) + + +;;====================================================================== +;; +;;====================================================================== +(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) + (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") + ;; local: #t)) + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) + (db-mod-time 0) ;; (file-modification-time db-path)) + (last-update 0) ;; (current-seconds)) + (request-update #t)) + (if (not testdat) + (begin + (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) + (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) + (test-registry (tests:get-all)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-rows rundat) + (db:get-header rundat) + "runname") #f)) + ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) + ;; These next two are intentional bad values to ensure errors if they should not + ;; get filled in properly. + (logfile "/this/dir/better/not/exist") + (rundir (if testdat + (db:test-get-rundir testdat) + logfile)) + ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (testname (if testdat (db:test-get-testname testdat) "n/a")) + ;; (tests:get-testconfig testdat testname 'return-procs)) + (testmeta (if testdat + (let ((tm (rmt:testmeta-get-record testname))) + (if tm tm (make-db:testmeta))) + (make-db:testmeta))) + + (keystring (string-intersperse + (map (lambda (keyval) + ;; (conc ":" (car keyval) " " (cadr keyval))) + (cadr keyval)) + keydat) + "/")) + (item-path (db:test-get-item-path testdat)) + ;; this next block was added to fix a bug where variables were + ;; needed. Revisit this. + (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read + (if (common:file-exists? runconfigf) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "failed to set up environment for " runconfigf ", exn=" exn) + #f) ;; do nothing, just keep on trucking .... + (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) + (make-hash-table)))) + (testconfig (begin + ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) + (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (handle-exceptions + exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! + (begin + (debug:print 0 *default-log-port* "testconfig load using " item-path " failed, trying " (db:test-get-item-path testdat) ", exn=" exn) + (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)) + (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) + (viewlog (lambda (x) + (if (common:file-exists? logfile) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer logfile) + (message-window (conc "File " logfile " not found"))))) + (view-a-log (lambda (lfile) + (let ((lfilename (conc rundir "/" lfile))) + ;; (print "lfilename: " lfilename) + (if (common:file-exists? lfilename) + ;(system (conc "firefox " logfile "&")) + (dcommon:run-html-viewer lfilename) + (message-window (conc "File " lfilename " not found")))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (common:without-vars + (conc "cd " rundir + ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&") + "MT_.*")) + (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) + (refreshdat (lambda () + (let* ((curr-mod-time (file-modification-time db-path)) + ;; (max ..... (if (common:file-exists? testdat-path) + ;; (file-modification-time testdat-path) + ;; (begin + ;; (set! testdat-path (conc rundir "/testdat.db")) + ;; 0)))) + (need-update (or (and (>= curr-mod-time db-mod-time) + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds + request-update)) + (newtestdat (if need-update + ;; NOTE: BUG HIDER, try to eliminate this exception handler + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id + ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + #f) + (rmt:get-test-info-by-id run-id test-id))))) + ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) + (cond + ((and need-update newtestdat) + (set! testdat newtestdat) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) + (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! rundir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) + (set! testfullname (db:test-get-fullname testdat)) + ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) + + ;; I don't see why this was implemented this way. Please comment it ... + ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same + ;; (set! db-mod-time (+ curr-mod-time 1)) + ;; (set! db-mod-time curr-mod-time)) + + (if (not (eq? curr-mod-time db-mod-time)) + (set! db-mod-time curr-mod-time)) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... + ) + (need-update ;; if this was true and yet there is no data .... + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) + (meta-widgets (make-hash-table)) + (self #f) + (store-label (lambda (name lbl cmd) + (hash-table-set! widgets name + (lambda (testdat) + (let ((newval (cmd testdat)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-meta (lambda (name lbl cmd) + (hash-table-set! meta-widgets name + (lambda (testmeta) + (let ((newval (cmd testmeta)) + (oldval (iup:attribute lbl "TITLE"))) + (if (not (equal? newval oldval)) + (begin + ;(mutex-lock! mx1) + (iup:attribute-set! lbl "TITLE" newval) + ;(mutex-unlock! mx1) + ))))) + lbl)) + (store-button store-label) + (command-proc (lambda (command-text-box) + (let* ((cmd (iup:attribute command-text-box "VALUE"))) + (common:run-a-command cmd with-orig-env: #t)))) + (command-text-box (iup:textbox + #:expand "HORIZONTAL" + #:font "Courier New, -10" + #:action (lambda (obj cnum val) + ;; (print "cnum=" cnum) + (if (eq? cnum 13) + (command-proc obj))) + )) + (command-launch-button (iup:button "Execute!" #:action (lambda (x) + (command-proc command-text-box)))) + ;; (lambda (x) + ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) + ;; (fullcmd (conc (dtests:get-pre-command) + ;; cmd + ;; (dtests:get-post-command)))) + ;; (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + ;; (common:without-vars fullcmd "MT_.*"))))) + (kill-jobs (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -set-state-status KILLREQ,n/a -testpatt %/% " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (run-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -run -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + )))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (clean-run-execute (lambda (x) + (let ((cmd (conc ;; "megatest -remove-runs -target " keystring " -runname " runname + "megatest -set-state-status NOT_STARTED,n/a -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ";megatest -target " keystring " -runname " runname + " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" + ))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) + (remove-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -remove-runs -target " keystring " -runname " runname + " -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -v")))) + (archive-test (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + ))))) + (cond + ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + (else + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self ; + (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" + #:title testfullname + (iup:vbox ; #:expand "YES" + ;; The run and test info + (iup:hbox ; #:expand "YES" + (run-info-panel dbstruct keydat testdat runname) + (test-info-panel testdat store-label widgets) + (test-meta-panel testmeta store-meta)) + (iup:hbox + (host-info-panel testdat store-label) + (submegatest-panel dbstruct keydat testdat runname testconfig)) + ;; The controls + (iup:frame #:title "Actions" + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "80x") + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") + (iup:button "Archive Test" #:action archive-test #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (apply + iup:hbox + (list command-text-box command-launch-button)))) + (set-fields-panel dbstruct run-id test-id testdat) + (let ((tabs + (iup:tabs + ;; Replace here with matrix + (let ((steps-matrix (iup:matrix + #:font "Courier New, -8" + #:expand "YES" + #:scrollbar "YES" + #:numcol 9 + #:numlin 100 + #:numcol-visible 9 + #:numlin-visible 5 + #:click-cb (lambda (obj lin col status) + ;; (if (equal? col 6) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (print "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) + ;; (let loop ((count 0)) + ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) + ;; (if (< count 30) + ;; (loop (+ count 1)))) + (iup:attribute-set! steps-matrix "0:1" "Step Name") + (iup:attribute-set! steps-matrix "0:2" "Start") + (iup:attribute-set! steps-matrix "0:3" "End") + (iup:attribute-set! steps-matrix "WIDTH3" "50") + (iup:attribute-set! steps-matrix "0:4" "Status") + (iup:attribute-set! steps-matrix "WIDTH4" "50") + (iup:attribute-set! steps-matrix "0:5" "Duration") + (iup:attribute-set! steps-matrix "0:6" "Log File") + (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") + (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") + ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") + (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") + (let ((proc + (lambda (testdat) + (dcommon:populate-steps teststeps steps-matrix run-id test-id)))) + (hash-table-set! widgets "StepsMatrix" proc) + (proc testdat)) + steps-matrix) + ;; populate the Test Data panel + (iup:frame + #:title "Test Data" + (let ((test-data + (iup:textbox ;; #:action (lambda (obj char val) + ;; #f) + #:expand "YES" + #:multiline "YES" + #:font "Courier New, -10" + #:size "100x100"))) + (hash-table-set! widgets "Test Data" + (lambda (testdat) ;; + (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE")) + (fmtstr "~10a~10a~10a~10a~7a~7a~6a~7a~a") ;; category,variable,value,expected,tol,units,type,comment + (newval (string-intersperse + (append + (list + (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment") + (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "=======")) + (map (lambda (x) + (format #f fmtstr + (db:test-data-get-category x) + (db:test-data-get-variable x) + (db:test-data-get-value x) + (db:test-data-get-expected x) + (db:test-data-get-tol x) + (db:test-data-get-status x) + (db:test-data-get-units x) + (db:test-data-get-type x) + (db:test-data-get-comment x))) + (rmt:read-test-data run-id test-id "%"))) + "\n"))) + (if (not (equal? currval newval)) + (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) + test-data)) + ;;(dashboard:run-controls) + ))) + (iup:attribute-set! tabs "TABTITLE0" "Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs)))) + (iup:show self) + (iup:callback-set! *tim* "ACTION_CB" + (lambda (x) + ;; Now start keeping the gui updated from the db + (refreshdat) ;; update from the db here + ;(thread-suspend! other-thread) + (if *exit-started* + (set! *exit-started* 'ok)))))))))) + +(define (colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +;; Display the tests as rows of boxes on the test/task pane +;; +(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) + (canvas-clear! cnv) + (canvas-font-set! cnv "Helvetica, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) + +(define (dboard:tabdat-test-patts-use vec) + (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? + +;; additional setters for dboard:data +(define (dboard:tabdat-test-patts-set!-use vec val) + (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) + +;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed +;; +(define (dashboard:update-run-command tabdat) + (let* ((cmd-tb (dboard:tabdat-command-tb tabdat)) + (cmd (dboard:tabdat-command tabdat)) + (test-patt (let ((tp (dboard:tabdat-test-patts tabdat))) + (if (or (not tp) + (equal? tp "")) + "%" + tp))) + (states (dboard:tabdat-states tabdat)) + (statuses (dboard:tabdat-statuses tabdat)) + (target (let ((targ-list (dboard:tabdat-target tabdat))) + (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) + (run-name (dboard:tabdat-run-name tabdat)) + (states-str (if (or (not states) + (null? states)) + "" + (conc " -state " (string-intersperse states ",")))) + (statuses-str (if (or (not statuses) + (null? statuses)) + "" + (conc " -status " (string-intersperse statuses ",")))) + (full-cmd "megatest")) + (case (string->symbol cmd) + ((run) + (set! full-cmd (conc full-cmd + " -run" + " -testpatt " + test-patt + " -target " + target + " -runname " + run-name + " -clean-cache" + ))) + ((remove-runs) + (set! full-cmd (conc full-cmd + " -remove-runs -runname " + run-name + " -target " + target + " -testpatt " + test-patt + states-str + statuses-str + ))) + (else (set! full-cmd " no valid command "))) + (iup:attribute-set! cmd-tb "VALUE" full-cmd))) + +(define (iuplistbox-fill-list lb items #!key (selected-item #f)) + (let ((i 1)) + (for-each (lambda (item) + (iup:attribute-set! lb (number->string i) item) + (if selected-item + (if (equal? selected-item item) + (iup:attribute-set! lb "VALUE" i))) ;; (number->string i)))) + (set! i (+ i 1))) + items) + ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item "")) + i)) + +;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num +;; adds the updater passed in the updaters list at that hashkey +;; +(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat))) + (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) + (hash-table-set! (dboard:commondat-updaters commondat) + tnum + (cons updater curr-updaters)))) + + + +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) + + +;;====================================================================== +;; dashboard-context-menu.scm +;;====================================================================== + + +(define (dboard:launch-testpanel run-id test-id) + (let* ((dboardexe (common:find-local-megatest "dashboard")) + (cmd (conc dboardexe + " -test " run-id "," test-id + " &"))) + (system cmd))) + + +(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + +(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))))) + +(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps))))) + +(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) + (list + + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (dboard:launch-testpanel run-id test-id))) + + (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info) + + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + (let* ((rundir (db:test-get-rundir test-info)) + (has-subrun (subrun:subrun-test-initialized? rundir))) + (if has-subrun + (iup:menu-item + "Launch subrun dashboard" + #:action + (lambda (obj) + (subrun:launch-dashboard rundir))) + (iup:vbox))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + )) +;; example section for megatest.config: +;; +;; +;; [custom-context-menu-items] +;; # : +;; item1 custom show run-id (%run-id%):echo "%run-id%" +;; item2 custom show test-id (%test-id%):echo "%test-id%" +;; item3 custom show target (%target%):echo "%target%" +;; item4 custom show test-name (%test-name%):echo "%test-name%" +;; item5 custom show test-patt (%test-patt%):echo "%test-patt%" +;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%" +;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%" +;; item8 custom show megatest root (%mt-root%):echo "%mt-root%" +;; item9 custom ls : ls -lrt +;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME + +(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info) + (let* ((vars (configf:section-vars *configdat* "custom-context-menu-items")) + (item-path (db:test-get-item-path test-info)) + (mt-root (pathname-directory (pathname-directory *common:this-exe-dir* )))) + (filter-map + (lambda (var) + (let* ((val (configf:lookup *configdat* "custom-context-menu-items" var)) + (m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val))) + (if m + (let* ((menu-item-text-raw (list-ref m 1)) + (command-line-raw (list-ref m 2)) + (subst-alist ;; template vars + `(( "%run-id%" . ,run-id ) + ( "%test-id%" . ,test-id ) + ( "%target%" . ,target ) + ( "%test-name%" . ,test-name) + ( "%test-patt%" . ,testpatt) + ( "%test-run-dir%" . ,(db:test-get-rundir test-info)) + ( "%mt-root%" . ,mt-root) + ( "%run-name%" . ,run-name) + ( "%run-area-home%" . ,*toppath*) + ( "%item-path%" . ,item-path) + ( "%item-test-patt%" . ,item-test-path ))) + (command-line ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + command-line-raw + subst-alist)) + (menu-item-text ;; replace template vars + (foldr + (lambda (x i) + (string-substitute + (car x) + (->string (cdr x)) + i + #t)) + menu-item-text-raw + subst-alist))) + (iup:menu-item + (conc "*"menu-item-text) + #:action + (lambda (obj) + + (let* ((scheme-match (string-match "^#(\\(.*)" command-line))) + ;;(BB> "cmdline is >"command-line"<") + (common:with-env-vars + ;; TODO: with-env-vars + ;; TODO: with-env-vars MT_* + (runs:get-mt-env-alist run-id run-name target test-name item-path) + + (lambda () + (if scheme-match + (begin + (handle-exceptions + exn + (print "error with custom menu scheme, exn=" exn) + (begin + ;;(BB> "gonna eval it!") + (eval (with-input-from-string (cadr scheme-match) read))))) + (common:run-a-command command-line with-vars: #t)))))))) + #f))) + vars))) + +(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (let* ((run-menu-items + (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (test-menu-items + (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (custom-menu-items + (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + (toplevel-menu-items + (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)) + ) + (apply iup:menu + `(,@toplevel-menu-items + ,(iup:menu-item + "Run" + (apply iup:menu run-menu-items)) + ,(iup:menu-item + "Test" + (apply iup:menu test-menu-items)) + ,@custom-menu-items)))) + +;;====================================================================== +;; gutils.scm +;;====================================================================== + +;; NOTE: These functions will move to iuputils + +(define (gutils:colors-similar? color1 color2) + (let* ((c1 (map string->number (string-split color1))) + (c2 (map string->number (string-split color2))) + (delta (map (lambda (a b)(abs (- a b))) c1 c2))) + (null? (filter (lambda (x)(> x 3)) delta)))) + +(define gutils:colors + '((PASS . "70 249 73") + (FAIL . "253 33 49") + (SKIP . "230 230 0"))) + +(define (gutils:get-color-spec effective-state) + (or (alist-ref effective-state gutils:colors) + (alist-ref 'FAIL gutils:colors))) + +;; BBnote - state status dashboard button color / text defined here +(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) + ;; ((if get-label cadr car) + (case (string->symbol state) + ((COMPLETED) ;; ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 249 73" status)) + ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) + ((WARN WAIVED) (list "255 172 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + ((ABORT) (list "198 36 166" status)) + (else (list "253 33 49" status)))) + ((ARCHIVED) + (case (string->symbol status) + ((PASS) (list "70 170 73" status)) + ((WARN WAIVED) (list "200 130 13" status)) + ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) + (else (list "180 33 49" status)))) + ;; (if (equal? status "PASS") + ;; '("70 249 73" "PASS") + ;; (if (or (equal? status "WARN") + ;; (equal? status "WAIVED")) + ;; (list "255 172 13" status) + ;; (list "223 33 49" status)))) ;; greenish orangeish redish + ((LAUNCHED) (list "101 123 142" state)) + ((CHECK) (list "255 100 50" state)) + ((REMOTEHOSTSTART) (list "50 130 195" state)) + ((RUNNING STARTED) (list "9 131 232" state)) + ((KILLREQ) (list "39 82 206" state)) + ((KILLED) (list "234 101 17" state)) + ((NOT_STARTED) (case (string->symbol status) + ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) + (else (list "240 240 240" state)))) + ;; for xor mode below + ;; + ((CLEAN) + (case (string->symbol status) + ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these + (else (list "60 235 63" status)))) + ((DIRTY-BETTER) (list "160 255 153" status)) + ((DIRTY-WORSE) (list "165 42 42" status)) + ((BOTH-BAD) (list "180 33 49" status)) + + (else (list "192 192 192" state)))) + ;;======================================================================the end ) Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -23,67 +23,5 @@ (use canvas-draw) (use srfi-1 regex regex-case srfi-69) (declare (unit gutils)) -;; NOTE: These functions will move to iuputils - -(define (gutils:colors-similar? color1 color2) - (let* ((c1 (map string->number (string-split color1))) - (c2 (map string->number (string-split color2))) - (delta (map (lambda (a b)(abs (- a b))) c1 c2))) - (null? (filter (lambda (x)(> x 3)) delta)))) - -(define gutils:colors - '((PASS . "70 249 73") - (FAIL . "253 33 49") - (SKIP . "230 230 0"))) - -(define (gutils:get-color-spec effective-state) - (or (alist-ref effective-state gutils:colors) - (alist-ref 'FAIL gutils:colors))) - -;; BBnote - state status dashboard button color / text defined here -(define (gutils:get-color-for-state-status state status);; #!key (get-label #f)) - ;; ((if get-label cadr car) - (case (string->symbol state) - ((COMPLETED) ;; ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 249 73" status)) - ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status)) - ((WARN WAIVED) (list "255 172 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - ((ABORT) (list "198 36 166" status)) - (else (list "253 33 49" status)))) - ((ARCHIVED) - (case (string->symbol status) - ((PASS) (list "70 170 73" status)) - ((WARN WAIVED) (list "200 130 13" status)) - ((SKIP) (list (gutils:get-color-spec 'SKIP) status)) - (else (list "180 33 49" status)))) - ;; (if (equal? status "PASS") - ;; '("70 249 73" "PASS") - ;; (if (or (equal? status "WARN") - ;; (equal? status "WAIVED")) - ;; (list "255 172 13" status) - ;; (list "223 33 49" status)))) ;; greenish orangeish redish - ((LAUNCHED) (list "101 123 142" state)) - ((CHECK) (list "255 100 50" state)) - ((REMOTEHOSTSTART) (list "50 130 195" state)) - ((RUNNING STARTED) (list "9 131 232" state)) - ((KILLREQ) (list "39 82 206" state)) - ((KILLED) (list "234 101 17" state)) - ((NOT_STARTED) (case (string->symbol status) - ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state)) - (else (list "240 240 240" state)))) - ;; for xor mode below - ;; - ((CLEAN) - (case (string->symbol status) - ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these - (else (list "60 235 63" status)))) - ((DIRTY-BETTER) (list "160 255 153" status)) - ((DIRTY-WORSE) (list "165 42 42" status)) - ((BOTH-BAD) (list "180 33 49" status)) - - (else (list "192 192 192" state)))) - Index: utils/fslutil.scm ================================================================== --- utils/fslutil.scm +++ utils/fslutil.scm @@ -142,11 +142,11 @@ ;;(timeline (aref (aref data "payload") "timeline")) ;; extract the timeline alists (start-flag #f) (end-flag #f)) ;; now we have all needed data as a list of alists in time order, extract the ;; messages for given branch starting at start-tag and ending at end-tag - (reverse ;; return results oldest to newest + ;; (reverse ;; return results oldest to newest (filter (lambda (x) x) (map (lambda (entry) (let ((tags (aref entry 'tags))) @@ -176,17 +176,18 @@ (cons 'mode 'auto))) #f))) (if (member end-tag tags)(set! end-flag #t)) res)) #f))))) - (reverse timeline)))))) + (reverse timeline))))) ;; ) (define (run-cmd-file cmdfile new-branch-name dest-node) - (let* ((data (with-input-from-file cmdfile read))) + (let* ((data (with-input-from-file cmdfile read)) + (first-commit #t)) (print "fossil set autosync 0") - (print "fossil branch new "new-branch-name" "dest-node) - (print "fossil co "new-branch-name) + ;; (print "fossil branch new "new-branch-name" "dest-node" --private") + (print "fossil co "dest-node) (for-each (lambda (node) (let* ((timestamp (alist-ref 'timestamp node)) (comment (alist-ref 'comment node)) (user (alist-ref 'user node)) @@ -201,11 +202,15 @@ (with-output-to-file comfile (lambda () (print comment) (print "From: "uuid) (print "User: "user))) - (print "fossil commit -M "comfile))) + (if first-commit + (begin + (print "fossil commit -M "comfile" --branch "new-branch-name" --private") + (set! first-commit #f)) + (print "fossil commit -M "comfile)))) data) (print "## fossil set autosync 1"))) (define (process-fossil branch start-tag end-tag) (print-rows @@ -214,10 +219,12 @@ (define usage "Usage: fslutil cmd [...] tlsum branch start-tag end-tag : generate a timeline summary use - for tags to indicate n/a (i.e. get all) + branchdat branch start-tag end-tag + : dump branch data for the run command (below) run cmdfile new-branch-name dest-node : migrate the nodes from cmdfile to dest-node using branch name new-branch-name ") Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -16,14 +16,18 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use typed-records srfi-1) - (declare (unit vg)) + +(module vg + * + +(import scheme chicken data-structures extras ports) (use canvas-draw iup) +(use typed-records srfi-1 srfi-69) (import canvas-draw-iup) (include "vg_records.scm") ;; ;; structs @@ -662,5 +666,7 @@ (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res) res))) (if (null? tal) newres (loop (car tal)(cdr tal) newres))))))) + +)