Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,12 @@
ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm
+MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \
+ treemod.scm
all : $(PREFIX)/bin/.$(ARCHSTR) mtest ndboard dboard mtut tcmt
# dbmod.import.o is just a hack here
mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.o
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -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)
ADDED treemod.scm
Index: treemod.scm
==================================================================
--- /dev/null
+++ treemod.scm
@@ -0,0 +1,167 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+(declare (unit treemod))
+;; (declare (uses margs))
+;; (declare (uses launch))
+;; ;; (declare (uses megatest-version))
+;; (declare (uses gutils))
+;; (declare (uses db))
+;; (declare (uses server))
+;; ;; (declare (uses synchash))
+;; (declare (uses dcommon))
+;;
+;; (include "megatest-version.scm")
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(module treemod
+ *
+
+(import
+ scheme
+ chicken
+ data-structures
+
+ (prefix iup iup:)
+ canvas-draw
+ iup
+ regex
+ srfi-1
+ srfi-13
+ format
+ )
+
+;;======================================================================
+;; T R E E S T U F F
+;;======================================================================
+
+;; path is a list of nodes, each the child of the previous
+;; this routine returns the id so another node can be added
+;; either as a leaf or as a branch
+;;
+;; BUG: This needs a stop sensor for when a branch is exhausted
+;;
+(define (tree:find-node obj path)
+ ;; start at the base of the tree
+ (if (null? path)
+ #f ;; or 0 ????
+ (let loop ((hed (car path))
+ (tal (cdr path))
+ (depth 0)
+ (nodenum 0))
+ ;; nodes in iup tree are 100% sequential so iterate over nodenum
+ (if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
+ (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
+ (node-title (iup:attribute obj (conc "TITLE" nodenum))))
+ (if (and (equal? depth node-depth)
+ (equal? hed node-title)) ;; yep, this is the one!
+ (if (null? tal) ;; end of the line
+ nodenum
+ (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
+ ;; this is the case where we found part of the hierarchy but not
+ ;; all of it, i.e. the node-depth went from deep to less deep
+ (if (> depth node-depth) ;; (+ 1 node-depth))
+ #f
+ (loop hed tal depth (+ nodenum 1)))))
+ #f))))
+
+;; top is the top node name zeroeth node VALUE=0
+(define (tree:add-node obj top nodelst #!key (userdata #f))
+ (let ((curr-top (iup:attribute obj "TITLE0")))
+ (if (or (not (string? curr-top))
+ (string-null? curr-top)
+ (string-match "^\\s*$" curr-top))
+ (iup:attribute-set! obj "ADDBRANCH0" top))
+
+
+
+ (cond
+ ((not (equal? top (iup:attribute obj "TITLE0")))
+ (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
+ ((null? nodelst))
+ (else
+ (let loop ((hed (car nodelst))
+ (tal (cdr nodelst))
+ (depth 1)
+ (pathl (list top)))
+ ;; Because the tree dialog changes node numbers when
+ ;; nodes are added or removed we must look up nodes
+ ;; each and every time. 0 is the top node so default
+ ;; to that.
+ (let* ((newpath (append pathl (list hed)))
+ (parentnode (tree:find-node obj pathl))
+ (nodenum (tree:find-node obj newpath)))
+ ;; Add the branch under lastnode if not found
+ (if (not nodenum)
+ (begin
+ (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
+ ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE?
+ (if userdata
+ (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata))
+ (if (null? tal)
+ #t
+ ;; reset to top
+ (loop (car nodelst)(cdr nodelst) 1 (list top))))
+ (if (null? tal) ;; if null here then this path has already been added
+ #t
+ (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))))
+
+(define (tree:node->path obj nodenum)
+ (let loop ((currnode 0)
+ (path '()))
+ (let* ((node-depth (string->number (iup:attribute obj (conc "DEPTH" currnode))))
+ (node-title (iup:attribute obj (conc "TITLE" currnode)))
+ (trimpath (if (and (not (null? path))
+ (> (length path) node-depth))
+ (take path node-depth)
+ path))
+ (newpath (append trimpath (list node-title))))
+ (if (>= currnode nodenum)
+ newpath
+ (loop (+ currnode 1)
+ newpath)))))
+
+(define (tree:delete-node obj top node-path) ;; node-path is a list of strings
+ (let ((id (tree:find-node obj (cons top node-path))))
+ (print "Found node to remove " id " for path " top " " node-path)
+ (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED")))
+
+)
+#|
+
+ (let* ((tb (iup:treebox
+ #:value 0
+ #:name "Runs"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ ;; (print "obj: " obj ", id: " id ", state: " state)
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id (cdr run-path))))
+ (if run-id
+ (begin
+ (dboard:data-curr-run-id-set! data run-id)
+ (dashboard:update-run-summary-tab)))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ ))))
+|#