Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,13 +28,14 @@
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 dboard mtut tcmt
+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
mofiles/debugprint.o : mofiles/mtargs.o
@@ -94,10 +95,13 @@
showmtesthash:
@echo $(MTESTHASH)
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
+
+ndboard : $(OFILES) $(GOFILES) newdashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
+ csc $(CSCOPTS) $(OFILES) newdashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o ndboard
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
# include makefile.inc
@@ -223,121 +227,20 @@
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
-$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
- $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
-
-$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
- chmod a+x $(PREFIX)/bin/newdashboard
-
-# mtutil
-
-$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut
- $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut
-
-install-mtut : mtut
- $(INSTALL) mtut $(PREFIX)/bin/mtut
-
-$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil
- chmod a+x $(PREFIX)/bin/mtutil
-
-# mtexec
-
-mtexec: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtexec.scm
- csc $(CSCOPTS) $(OFILES) $(MOFILES) mtexec.scm -o mtexec
-
-$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec
- $(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec
-
-$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec
- chmod a+x $(PREFIX)/bin/mtexec
-
-# tcmt
-
-$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
- $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt
-
-$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
- utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
- chmod a+x $(PREFIX)/bin/tcmt
-
-$(PREFIX)/bin/mt_laststep : utils/mt_laststep
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mt_runstep : utils/mt_runstep
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/serialize-env: serialize-env.scm
- csc serialize-env.scm
- $(INSTALL) serialize-env $@
-
-$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mt_xterm : utils/mt_xterm
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/nbfake : utils/nbfake
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/remrun : utils/remrun
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/viewscreen : utils/viewscreen
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/nbfind : utils/nbfind
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mtrunner : utils/mtrunner
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
- $(INSTALL) $< $@
- chmod a+x $@
-
-
-deploytarg/nbfake : utils/nbfake
- $(INSTALL) $< $@
- chmod a+x $@
-
-deploytarg/viewscreen : utils/viewscreen
- $(INSTALL) $< $@
- chmod a+x $@
-
-deploytarg/nbfind : utils/nbfind
- $(INSTALL) $< $@
- chmod a+x $@
-
-$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm
- make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
-
-mtest-reaper: $(PREFIX)/bin/mtest-reaper
-
-# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
+
+# install dashboard as dboard so wrapper script can be called dashboard
+$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(FILES) utils/mk_wrapper
+ utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
+ chmod a+x $(PREFIX)/bin/newdashboard
+ $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so
if [[ $(ARCHSTR) == 12.5 ]]; then \
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
$(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so; \
@@ -354,11 +257,12 @@
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \
$(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \
fi
install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
- $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
+ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/dashboard \
+ $(HELPERS) $(PREFIX)/bin/nbfake \
$(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
@@ -365,11 +269,10 @@
$(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
$(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
-# $(PREFIX)/bin/.$(ARCHSTR)/ndboard
# $(PREFIX)/bin/newdashboard
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
@@ -390,11 +293,11 @@
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
tcmt readline-fix.scm serialize-env dboard *.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o \
mofiles/*.o vg.o cookie.o dashboard-main.o \
ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o \
- tcmt.o *.import.scm *.import.o
+ tcmt.o *.import.scm *.import.o ndboard
rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) \
$(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut \
tcmt ftail.import.scm readline-fix.scm serialize-env \
dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -16,10 +16,28 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
+(declare (uses common))
+(declare (uses margs))
+(declare (uses keys))
+(declare (uses items))
+(declare (uses db))
+(declare (uses configf))
+(declare (uses process))
+(declare (uses launch))
+(declare (uses runs))
+(declare (uses dashboard-tests))
+(declare (uses treemod))
+(declare (uses dcommon))
+(declare (uses dashboard-context-menu))
+(declare (uses vg))
+(declare (uses subrun))
+(declare (uses mt))
+(declare (uses dbfile))
+
(use format)
(require-library iup)
(import (prefix iup iup:))
@@ -27,28 +45,11 @@
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)
-
-(declare (uses common))
-(declare (uses margs))
-(declare (uses keys))
-(declare (uses items))
-(declare (uses db))
-(declare (uses configf))
-(declare (uses process))
-(declare (uses launch))
-(declare (uses runs))
-(declare (uses dashboard-tests))
-(declare (uses tree))
-(declare (uses dcommon))
-(declare (uses dashboard-context-menu))
-(declare (uses vg))
-(declare (uses subrun))
-(declare (uses mt))
-(declare (uses dbfile))
+(import treemod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
@@ -637,11 +638,11 @@
;;
(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")))
+ "400")))
(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))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -2279,12 +2279,11 @@
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(set! keys (rmt:get-keys)) ;; db))
- (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
- (if (sqlite3:database? db)(sqlite3:finalize! db))
+ (print (string-intersperse keys " "))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 *default-log-port* "Look at the dashboard for now")
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -16,31 +16,54 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(use format)
-
-(use (prefix iup iup:))
+;; (declare (uses common))
+;; (declare (uses megatest-version))
+(declare (uses mtargs))
+(declare (uses treemod))
-(use canvas-draw)
+(use srfi-1
+ posix regex regex-case srfi-69 typed-records sparse-vectors
+ format
+ extras
+ (prefix iup iup:)
+ canvas-draw
+ sqlite3)
+
(import canvas-draw-iup)
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
- (prefix dbi dbi:))
+(module ndboard
+ *
+
+(import scheme
+ chicken
+ data-structures
+ extras
+ format
+ (prefix iup iup:)
+ canvas-draw
+ canvas-draw-iup
+ matchable
+ srfi-1 posix regex regex-case
+ srfi-69 typed-records sparse-vectors ;; defstruct
+ sqlite3
+
+ treemod
+ (prefix mtargs args:)
+ )
+
-(declare (uses common))
-(declare (uses megatest-version))
-(declare (uses margs))
+(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))
+;; (declare (uses dcommon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
@@ -81,21 +104,159 @@
(begin
(print help)
(exit)))
;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
- (if (common:file-exists? debugcontrolf)
+(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 *areas* (make-hash-table))
+(defstruct area
+ path
+ keys
+ targets
+ targets-update-time
+ (dbhs (make-hash-table))
+ )
+
+(define (area-get-path area-name)
+ (let* ((adat (get-area-info area-name)))
+ (if adat
+ (area-path adat)
+ #f)))
+
+(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))))
+
+(define (register-area areadat)
+ (hash-table-set! *areas* (car areadat)
+ (make-area path: (cdr areadat))))
+
+(define (get-area-info area-name)
+ (hash-table-ref/default *areas* area-name #f))
+
+(define (area-save-dbh area-name dbname mtdbh)
+ (hash-table-set! (area-dbhs (get-area-info area-name)) dbname mtdbh))
+
+(define (area-get-dbh area-name dbname)
+ (hash-table-ref/default (area-dbhs (get-area-info area-name)) dbname #f))
+
+;; megatest calls, run in "area"
+;;
+
+;; TODO store the last time the query was run
+;; and clear cache based on timestamp on main.db
+;;
+(define (megatest-get-targets area-name)
+ (let* ((ainfo (get-area-info area-name))
+ (targets (area-targets ainfo)))
+ (if targets
+ targets
+ (let* ((path (area-get-path area-name))
+ (raw-targs (with-input-from-pipe
+ (conc "megatest -list-targets -start-dir "path)
+ read-lines))
+ (clean-targs (filter (lambda (x)
+ (not (equal? x "default")))
+ raw-targs)))
+ (area-targets-set! ainfo clean-targs)
+ (area-targets-update-time-set! ainfo (current-seconds))
+ clean-targs))))
+
+(define (megatest-get-keys area-name)
+ (let* ((ainfo (get-area-info area-name))
+ (keys (area-keys ainfo)))
+ (if keys
+ keys
+ (let* ((path (area-path ainfo))
+ (keysstr (with-input-from-pipe
+ (conc "megatest -show-keys -start-dir "path)
+ read-line)))
+ (if (not (string? keysstr))
+ (print "Unknown error getting keys for area "area-name", path: "path)
+ (let* ((keys (string-split keysstr)))
+ (area-keys-set! ainfo keys)
+ keys))))))
+
+;; megatest area database access functions
+;;
+
+(defstruct mtdb
+ name
+ db
+ path)
+
+;; fall back to old megatest db if .megatest/dbname not found
+;;
+(define (megatest-find-db path dbname)
+ (let ((newpath (conc path"/.megatest/"dbname))
+ (oldpath (conc path"/megatest.db")))
+ (if (file-exists? newpath)
+ newpath
+ (if (file-exists? oldpath)
+ oldpath
+ #f))))
+
+;; dbname is main.db, 1.db ...
+(define (megatest-open-db area-name dbname)
+ (let* ((mtdbh (area-get-dbh area-name dbname)))
+ (if mtdbh
+ mtdbh
+ (let* ((ainfo (get-area-info area-name))
+ (path (area-path ainfo))
+ (dbpath (megatest-find-db path dbname))
+ (dbexists (and dbpath
+ (file-exists? dbpath)
+ (file-read-access? dbpath))))
+ (if dbexists
+ (let* ((db (open-database dbpath)))
+ (set-busy-handler! db (make-busy-timeout 136000))
+ (execute db "PRAGMA synchronous = 0;")
+ (let* ((mtdbh (make-mtdb db: db path: dbpath)))
+ (area-save-dbh area-name dbname mtdbh)
+ mtdbh))
+ #f)))))
+
+;; ADD on-exit to close the opened dbs
+
+;; keys is list, targpatts is list, both same length
+;; and *fully* specified
+;; returns targvals and runname
+(define (megatest-get-run-names area-name keys targpatts)
+ (let* ((mtdbh (megatest-open-db area-name "main.db"))
+ (selector (string-intersperse
+ (map (lambda (k v)(conc k" like '"v"'")) keys targpatts)
+ " AND "))
+ (field-sel (string-intersperse keys ","))
+ (fullqry (conc "SELECT "field-sel",runname FROM runs WHERE "selector";")))
+ (print "fullqry="fullqry)
+ (fold-row ;; proc init db-or-stmt . params)
+ (lambda (res . row)
+ (cons row res))
+ '()
+ (mtdb-db mtdbh) ;; get the db handle
+ fullqry)))
+
+
+
+;; gui utils
+;;
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
@@ -112,605 +273,95 @@
(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)
- #f
- ;;(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)
- #f
- ;; (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)
+ (let* ((path (tree:node->path obj id)))
+ (match path
+ ((treename) #f) ;;(print "nothing to do here"))
+ ((treename area)
+ (let ((tb (get-widget "main-tree"))) ;; wait, isn't this just "obj"?
+ (refresh-targets tb area)))
+ ((treename area . target)
+ (let* ((keys (megatest-get-keys area)))
+ (if (eq? (length keys)(length target))
+ (let* ((runnames (megatest-get-run-names area keys target)))
+ (for-each
+ (lambda (runnamedat)
+ (tree:add-node obj "Areas" (cons area runnamedat)))
+ runnames)))))
+ (else
+ (print "path: "path))
+ )
+ #;(print "obj: "obj", id: "id", state: "state", path: "path)))))
+
+(define (refresh-targets tb area)
+ (let* ((targets (megatest-get-targets area)))
+ (for-each
+ (lambda (target)
+ (let* ((t-path (string-split target "/")))
+ (tree:add-node tb "Areas" (cons area t-path))))
+ targets)))
+
+(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)))
+ (register-area 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)
+ ;; #:menu (dcommon:main-menu)
#:shrink "YES"
(let ((tabtop (iup:tabs
- (runs window-id)
- (tests window-id)
+ (add-widget "runs" (runs window-id))
+ ;; (tests window-id)
(runcontrol window-id)
- (mtest *toppath* window-id)
- (rconfig window-id)
+ ;; (mtest *toppath* window-id)
+ ;; (rconfig window-id)
)))
(iup:attribute-set! tabtop "TABTITLE0" "Runs")
- (iup:attribute-set! tabtop "TABTITLE1" "Tests")
- (iup:attribute-set! tabtop "TABTITLE2" "Run Control")
- (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
- (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
+ ;; (iup:attribute-set! tabtop "TABTITLE1" "Tests")
+ (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)
(define (newdashboard dbstruct)
@@ -724,24 +375,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)
+ ))))
+|#