@@ -16,32 +16,48 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(use format) - -(use (prefix iup iup:)) - -(use canvas-draw) -(import canvas-draw-iup) - -(use srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct - ) - -(include "megatest-version.scm") ;; (declare (uses common)) ;; (declare (uses megatest-version)) -(declare (uses margs)) +(declare (uses mtargs)) +(declare (uses treemod)) + +(use srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) +(use format + (prefix iup iup:) + canvas-draw) +(import canvas-draw-iup) +;; (debug:setup) + +(module ndboard + * + +(import scheme + chicken + data-structures + format + (prefix iup iup:) + canvas-draw + canvas-draw-iup + srfi-1 posix regex regex-case + srfi-69 typed-records sparse-vectors ;; defstruct + + treemod + (prefix mtargs args:) + ) + + +(include "megatest-version.scm") ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses server)) ;; (declare (uses synchash)) ;; (declare (uses dcommon)) -;; (declare (uses tree)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") @@ -86,18 +102,28 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.newdashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -;; (debug:setup) - (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") +;; areas +;; +(define (get-areas-file) + (conc (get-environment-variable "HOME")"/.ndboard/areas.scm")) + +(define (get-areas) + (let* ((areas-file (get-areas-file))) + (if (file-exists? areas-file) + (with-input-from-file areas-file read)))) + +;; gui utils +;; (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) @@ -113,598 +139,68 @@ (iup:attribute-set! lb "VALUE" item))) ;; (number->string i)))) (set! i (+ i 1))) items) i)) +;; simple widget registration and finding +(define *widgets* (make-hash-table)) +(define (add-widget name wgt) + (hash-table-set! *widgets* name wgt) + wgt) +(define (get-widget name) + (hash-table-ref/default *widgets* name #f)) + (define (pad-list l n)(append l (make-list (- n (length l))))) - -(define (mkstr . x) - (string-intersperse (map conc x) ",")) - -(define (update-search x val) - (hash-table-set! *searchpatts* x val)) - -;; -;; ;; data for each specific tab goes here -;; ;; -;; (defstruct dboard:tabdat -;; ;; runs -;; ((allruns '()) : list) ;; list of dboard:rundat records -;; ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records -;; ((done-runs '()) : list) ;; list of runs already drawn -;; ((not-done-runs '()) : list) ;; list of runs not yet drawn -;; (header #f) ;; header for decoding the run records -;; (keys #f) ;; keys for this run (i.e. target components) -;; ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; -;; ((tot-runs 0) : number) -;; ((last-data-update 0) : number) ;; last time the data in allruns was updated -;; ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree -;; (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects -;; ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id -;; ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id -;; ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files -;; -;; ;; Runs view -;; ((buttondat (make-hash-table)) : hash-table) ;; -;; ((item-test-names '()) : list) ;; list of itemized tests -;; ((run-keys (make-hash-table)) : hash-table) -;; (runs-matrix #f) ;; used in newdashboard -;; ((start-run-offset 0) : number) ;; left-right slider value -;; ((start-test-offset 0) : number) ;; up-down slider value -;; ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 -;; ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 -;; ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 -;; ((all-test-names '()) : list) -;; -;; ;; Canvas and drawing data -;; (cnv #f) -;; (cnv-obj #f) -;; (drawing #f) -;; ((run-start-row 0) : number) -;; ((max-row 0) : number) -;; ((running-layout #f) : boolean) -;; (originx #f) -;; (originy #f) -;; ((layout-update-ok #t) : boolean) -;; ((compact-layout #t) : boolean) -;; -;; ;; Run times layout -;; ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere -;; (graph-matrix #f) -;; ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info -;; ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info -;; ((graph-matrix-row 1) : number) -;; ((graph-matrix-col 1) : number) -;; -;; ;; Controls used to launch runs etc. -;; ((command "") : string) ;; for run control this is the command being built up -;; (command-tb #f) ;; widget for the type of command; run, remove-runs etc. -;; (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns -;; (key-listboxes #f) -;; (key-lbs #f) -;; run-name ;; from run name setting widget -;; states ;; states for -state s1,s2 ... -;; statuses ;; statuses for -status s1,s2 ... -;; -;; ;; Selector variables -;; curr-run-id ;; current row to display in Run summary view -;; prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode -;; curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard -;; ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab -;; ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters -;; ((hide-empty-runs #f) : boolean) -;; ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs -;; (hide-not-hide-button #f) -;; ((searchpatts (make-hash-table)) : hash-table) ;; -;; ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control -;; ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f -;; (target #f) -;; (test-patts #f) -;; -;; ;; db info to file the .db files for the area -;; (access-mode (db:get-access-mode)) ;; use cached db or not -;; (dbdir #f) -;; (dbfpath #f) -;; (dbkeys #f) -;; ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp -;; (monitor-db-path #f) ;; where to find monitor.db -;; ro ;; is the database read-only? -;; -;; ;; tests data -;; ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) -;; -;; ;; runs tree -;; ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id -;; (runs-tree #f) -;; ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) -;; -;; ;; tab data -;; ((view-changed #t) : boolean) -;; ((xadj 0) : number) ;; x slider number (if using canvas) -;; ((yadj 0) : number) ;; y slider number (if using canvas) -;; ;; runs-summary tab state -;; ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) -;; ((runs-summary-mode-buttons '()) : list) -;; ((runs-summary-mode 'one-run) : symbol) -;; ((runs-summary-mode-change-callbacks '()) : list) -;; (runs-summary-source-runname-label #f) -;; (runs-summary-dest-runname-label #f) -;; ;; runs summary view -;; -;; tests-tree ;; used in newdashboard -;; ) -;; -;; -;; -;; ;; mtest is actually the megatest.config file -;; ;; -;; (define (mtest toppath window-id) -;; (let* ((curr-row-num 0) -;; ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) -;; (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig)) -;; (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) -;; (jobtools-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 5 -;; #:numcol-visible 1 -;; #:numlin-visible 3)) -;; (validvals-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 2 -;; #:numcol-visible 1 -;; #:numlin-visible 2)) -;; (envovrd-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 20 -;; #:numcol-visible 1 -;; #:numlin-visible 8)) -;; (disks-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 20 -;; #:numcol-visible 1 -;; #:numlin-visible 8)) -;; ) -;; (iup:attribute-set! disks-matrix "0:0" "Disk Name") -;; (iup:attribute-set! disks-matrix "0:1" "Disk Path") -;; (iup:attribute-set! disks-matrix "WIDTH1" "120") -;; (iup:attribute-set! disks-matrix "WIDTH0" "100") -;; (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") -;; (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") -;; (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") -;; -;; ;; fill in existing info -;; (for-each -;; (lambda (mat fname) -;; (set! curr-row-num 1) -;; (for-each -;; (lambda (var) -;; (iup:attribute-set! mat (conc curr-row-num ":0") var) -;; ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) -;; (set! curr-row-num (+ curr-row-num 1))) -;; '()));; (configf:section-vars rawconfig fname))) -;; (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) -;; (list "setup" "jobtools" "validvalues" "env-override" "disks")) -;; -;; (for-each -;; (lambda (mat) -;; (iup:attribute-set! mat "0:1" "Value") -;; (iup:attribute-set! mat "0:0" "Var") -;; (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") -;; (iup:attribute-set! mat "FIXTOTEXT" "C1") -;; (iup:attribute-set! mat "RESIZEMATRIX" "YES") -;; (iup:attribute-set! mat "WIDTH1" "120") -;; (iup:attribute-set! mat "WIDTH0" "100") -;; ) -;; (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) -;; -;; (iup:attribute-set! validvals-matrix "WIDTH1" "290") -;; (iup:attribute-set! envovrd-matrix "WIDTH1" "290") -;; -;; (iup:vbox -;; (iup:hbox -;; -;; (iup:vbox -;; (let ((tabs (iup:tabs -;; ;; The required tab -;; (iup:hbox -;; ;; The keys -;; (iup:frame -;; #:title "Keys (required)" -;; (iup:vbox -;; (iup:label (conc "Set the fields for organising your runs\n" -;; "here. Note: can only be changed before\n" -;; "running the first run when megatest.db\n" -;; "is created.")) -;; keys-matrix)) -;; (iup:vbox -;; ;; The setup section -;; (iup:frame -;; #:title "Setup" -;; (iup:vbox -;; (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" -;; "linktree : directory where linktree will be created.")) -;; setup-matrix)) -;; ;; The jobtools -;; (iup:frame -;; #:title "Jobtools" -;; (iup:vbox -;; (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" -;; "useshell : use system to run your launcher\n" -;; "workhosts : spread jobs out on these hosts")) -;; jobtools-matrix)) -;; ;; The disks -;; (iup:frame -;; #:title "Disks" -;; (iup:vbox -;; (iup:label (conc "Enter names and existing paths of locations to run tests")) -;; disks-matrix)))) -;; ;; The optional tab -;; (iup:vbox -;; ;; The Environment Overrides -;; (iup:frame -;; #:title "Env override" -;; envovrd-matrix) -;; ;; The valid values -;; (iup:frame -;; #:title "Validvalues" -;; validvals-matrix) -;; )))) -;; (iup:attribute-set! tabs "TABTITLE0" "Required settings") -;; (iup:attribute-set! tabs "TABTITLE1" "Optional settings") -;; tabs)) -;; )))) -;; -;; ;; The runconfigs.config file -;; ;; -;; (define (rconfig window-id) -;; (iup:vbox -;; (iup:frame #:title "Default"))) -;; -;; ;;====================================================================== -;; ;; T E S T S -;; ;;====================================================================== -;; -;; (define (tree-path->test-id path) -;; (if (not (null? path)) -;; (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f) -;; #f)) -;; -;; (define (test-panel window-id) -;; (let* ((curr-row-num 0) -;; (viewlog (lambda (x) -;; (if (common:file-exists? logfile) -;; ;(system (conc "firefox " logfile "&")) -;; (iup:send-url logfile) -;; (message-window (conc "File " logfile " not found"))))) -;; (xterm (lambda (x) -;; (if (directory-exists? rundir) -;; (let ((shell (if (get-environment-variable "SHELL") -;; (conc "-e " (get-environment-variable "SHELL")) -;; ""))) -;; (system (conc "cd " rundir -;; ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) -;; (message-window (conc "Directory " rundir " not found"))))) -;; (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) -;; (command-launch-button (iup:button "Execute!" -;; ;; #:expand "HORIZONTAL" -;; #:size "50x" -;; #:action (lambda (x) -;; (let ((cmd (iup:attribute command-text-box "VALUE"))) -;; (system (conc cmd " &")))))) -;; (run-test (lambda (x) -;; (iup:attribute-set! -;; command-text-box "VALUE" -;; (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname -;; " -runtests " (conc testname "/" (if (equal? item-path "") -;; "%" -;; item-path)) -;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) -;; (remove-test (lambda (x) -;; (iup:attribute-set! -;; command-text-box "VALUE" -;; (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname -;; " -testpatt " (conc testname "/" (if (equal? item-path "") -;; "%" -;; item-path)) -;; " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) -;; (run-info-matrix (iup:matrix -;; #:expand "YES" -;; ;; #:scrollbar "YES" -;; #:numcol 1 -;; #:numlin 4 -;; #:numcol-visible 1 -;; #:numlin-visible 4 -;; #:click-cb (lambda (obj lin col status) -;; (print "obj: " obj " lin: " lin " col: " col " status: " status)))) -;; (test-info-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 7 -;; #:numcol-visible 1 -;; #:numlin-visible 7)) -;; (test-run-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 5 -;; #:numcol-visible 1 -;; #:numlin-visible 5)) -;; (meta-dat-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 1 -;; #:numlin 5 -;; #:numcol-visible 1 -;; #:numlin-visible 5)) -;; (steps-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 6 -;; #:numlin 50 -;; #:numcol-visible 6 -;; #:numlin-visible 8)) -;; (data-matrix (iup:matrix -;; #:expand "YES" -;; #:numcol 8 -;; #:numlin 50 -;; #:numcol-visible 8 -;; #:numlin-visible 8)) -;; (updater (lambda (testdat) -;; (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) -;; -;; ;; Set the updater in updaters -;; ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater) -;; ;; -;; (for-each -;; (lambda (mat) -;; ;; (iup:attribute-set! mat "0:1" "Value") -;; ;; (iup:attribute-set! mat "0:0" "Var") -;; (iup:attribute-set! mat "HEIGHT0" 0) -;; (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") -;; ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") -;; (iup:attribute-set! mat "RESIZEMATRIX" "YES")) -;; ;; (iup:attribute-set! mat "WIDTH1" "120") -;; ;; (iup:attribute-set! mat "WIDTH0" "100")) -;; (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) -;; -;; ;; Steps matrix -;; (iup:attribute-set! steps-matrix "0:1" "Step Name") -;; (iup:attribute-set! steps-matrix "0:2" "Start") -;; (iup:attribute-set! steps-matrix "WIDTH2" "40") -;; (iup:attribute-set! steps-matrix "0:3" "End") -;; (iup:attribute-set! steps-matrix "WIDTH3" "40") -;; (iup:attribute-set! steps-matrix "0:4" "Status") -;; (iup:attribute-set! steps-matrix "WIDTH4" "40") -;; (iup:attribute-set! steps-matrix "0:5" "Duration") -;; (iup:attribute-set! steps-matrix "WIDTH5" "40") -;; (iup:attribute-set! steps-matrix "0:6" "Log File") -;; (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") -;; ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") -;; (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") -;; ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") -;; ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") -;; -;; ;; Data matrix -;; ;; -;; (let ((rownum 1)) -;; (for-each -;; (lambda (x) -;; (iup:attribute-set! data-matrix (conc "0:" rownum) x) -;; (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") -;; (set! rownum (+ rownum 1))) -;; (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) -;; (iup:attribute-set! data-matrix "REDRAW" "ALL") -;; -;; (for-each -;; (lambda (data) -;; (let ((mat (car data)) -;; (keys (cadr data)) -;; (rownum 1)) -;; (for-each -;; (lambda (key) -;; (iup:attribute-set! mat (conc rownum ":0") key) -;; (set! rownum (+ rownum 1))) -;; keys) -;; (iup:attribute-set! mat "REDRAW" "ALL"))) -;; (list -;; (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) -;; (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) -;; (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) -;; (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) -;; -;; (iup:split -;; #:orientation "HORIZONTAL" -;; (iup:vbox -;; (iup:hbox -;; (iup:vbox -;; run-info-matrix -;; test-info-matrix) -;; ;; test-info-matrix) -;; (iup:vbox -;; test-run-matrix -;; meta-dat-matrix)) -;; (iup:vbox -;; (iup:vbox -;; (iup:hbox -;; (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" -;; (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" -;; (iup:hbox -;; (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" -;; (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" -;; (iup:hbox -;; ;; hiup:split ;; hbox -;; ;; #:orientation "HORIZONTAL" -;; ;; #:value 300 -;; command-text-box -;; command-launch-button))) -;; (iup:vbox -;; (let ((tabs (iup:tabs -;; steps-matrix -;; data-matrix))) -;; (iup:attribute-set! tabs "TABTITLE0" "Test Steps") -;; (iup:attribute-set! tabs "TABTITLE1" "Test Data") -;; tabs))))) -;; -;; ;; Test browser -;; (define (tests window-id) -;; (iup:split -;; (let* ((tb (iup:treebox -;; #:selection-cb -;; (lambda (obj id state) -;; ;; (print "obj: " obj ", id: " id ", state: " state) -;; (let* ((run-path (tree:node->path obj id)) -;; (test-id (tree-path->test-id (cdr run-path)))) -;; ;; (if test-id -;; ;; (hash-table-set! (dboard:data-curr-test-ids *data*) -;; ;; window-id test-id)) -;; (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) -;; (iup:attribute-set! tb "VALUE" "0") -;; (iup:attribute-set! tb "NAME" "Runs") -;; ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") -;; ;; (dboard:data-tests-tree-set! *data* tb) -;; tb) -;; (test-panel window-id))) -;; -;; ;; The function to update the fields in the test view panel -;; (define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) -;; ;; get test-id -;; ;; then get test record -;; (if testdat -;; (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) -;; (test-data (hash-table-ref/default testdat test-id #f)) -;; (run-id (db:test-get-run_id test-data)) -;; (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) -;; run-id -;; '())) -;; (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) -;; (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) -;; (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) -;; -;; (if test-data -;; (begin -;; ;; -;; (for-each -;; (lambda (data) -;; (let ((mat (car data)) -;; (vals (cadr data)) -;; (rownum 1)) -;; (for-each -;; (lambda (key) -;; (let ((cell (conc rownum ":1"))) -;; (if (not (equal? (iup:attribute mat cell)(conc key))) -;; (begin -;; ;; (print "setting cell " cell " in matrix " mat " to value " key) -;; (iup:attribute-set! mat cell (conc key)) -;; (iup:attribute-set! mat "REDRAW" cell))) -;; (set! rownum (+ rownum 1)))) -;; vals))) -;; (list -;; (list run-info-matrix -;; (if test-id -;; (list (db:test-get-run_id test-data) -;; target -;; runname -;; "n/a") -;; (make-list 4 ""))) -;; (list test-info-matrix -;; (if test-id -;; (list test-id -;; (db:test-get-testname test-data) -;; (db:test-get-item-path test-data) -;; (db:test-get-state test-data) -;; (db:test-get-status test-data) -;; (seconds->string (db:test-get-event_time test-data)) -;; (db:test-get-comment test-data)) -;; (make-list 7 ""))) -;; (list test-run-matrix -;; (if test-id -;; (list (db:test-get-host test-data) -;; (db:test-get-uname test-data) -;; (db:test-get-diskfree test-data) -;; (db:test-get-cpuload test-data) -;; (seconds->hr-min-sec (db:test-get-run_duration test-data))) -;; (make-list 5 ""))) -;; )) -;; (dcommon:populate-steps steps-dat steps-matrix)))))) -;; ;;(list meta-dat-matrix -;; ;; (if test-id -;; ;; (list ( -;; -;; -;; ;; db:test-get-id -;; ;; db:test-get-run_id -;; ;; db:test-get-testname -;; ;; db:test-get-state -;; ;; db:test-get-status -;; ;; db:test-get-event_time -;; ;; db:test-get-host -;; ;; db:test-get-cpuload -;; ;; db:test-get-diskfree -;; ;; db:test-get-uname -;; ;; db:test-get-rundir -;; ;; db:test-get-item-path -;; ;; db:test-get-run_duration -;; ;; db:test-get-final_logf -;; ;; db:test-get-comment -;; ;; db:test-get-fullname -;; -;; -;; ;;====================================================================== -;; ;; R U N C O N T R O L -;; ;;====================================================================== -;; -;; ;; Overall runs browser -;; ;; -;; (define (runs window-id) -;; (let* ((runs-matrix (iup:matrix -;; #:expand "YES" -;; ;; #:fittosize "YES" -;; #:scrollbar "YES" -;; #:numcol 100 -;; #:numlin 100 -;; #:numcol-visible 7 -;; #:numlin-visible 7 -;; #:click-cb (lambda (obj lin col status) -;; (print "obj: " obj " lin: " lin " col: " col " status: " status))))) -;; -;; (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") -;; (iup:attribute-set! runs-matrix "WIDTH0" "100") -;; -;; ;; (dboard:data-runs-matrix-set! *data* runs-matrix) -;; (iup:hbox -;; (iup:frame -;; #:title "Runs browser" -;; (iup:vbox -;; runs-matrix))))) +;; the main tree, everything starts from here +;; +(define (main-tree) + (iup:treebox + #:value 0 + #:title "Areas" + #:expand "YES" + #:addexpanded "YES" + #:size "10x" + #:selection-cb + (lambda (obj id state) + (print "do nothing...")))) + +(define (runs window-id) + (iup:hbox + (add-widget "main-tree" (main-tree)) + ;; + )) + +(define (runs-init) + (let* ((areas (get-areas)) + (tb (get-widget "main-tree"))) + (for-each + (lambda (areadat) + (tree:add-node tb "Areas" `(,(car areadat)))) + areas))) ;; Browse and control a single run ;; (define (runcontrol window-id) (iup:hbox)) -;;====================================================================== -;; D A S H B O A R D -;;====================================================================== - ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" ;; #:menu (dcommon:main-menu) #:shrink "YES" (let ((tabtop (iup:tabs - ;; (runs window-id) + (add-widget "runs" (runs window-id)) ;; (tests window-id) (runcontrol window-id) ;; (mtest *toppath* window-id) ;; (rconfig window-id) ))) - ;; (iup:attribute-set! tabtop "TABTITLE0" "Runs") + (iup:attribute-set! tabtop "TABTITLE0" "Runs") ;; (iup:attribute-set! tabtop "TABTITLE1" "Tests") - (iup:attribute-set! tabtop "TABTITLE0" "Run Control") + (iup:attribute-set! tabtop "TABTITLE1" "Run Control") ;; (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") ;; (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) @@ -720,24 +216,34 @@ (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application (iup:show (main-panel my-window-id)) + (runs-init) ;; Yes, running iup:show will pop up a new panel ;; (iup:show (main-panel my-window-id)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Want to dedicate no more than 50% of the time to this so skip if ;; 2x delta time has not passed since last query - (if (< nextmintime (current-milliseconds)) + #t + #;(if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) ;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "...")) ) - (debug:print-info 11 *default-log-port* "Server overloaded")))))) + (print "Server overloaded")))))) + +) + + +;;====================================================================== +;; D A S H B O A R D +;;====================================================================== + -;; (dboard:data-updaters-set! *data* (make-hash-table)) -(newdashboard #f) ;; *dbstruct-local*) +(import ndboard) +(newdashboard #f) (iup:main-loop)