Megatest

           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm tdb.scm client.scm mt.scm	\
           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
mofiles/debugprint.o : mofiles/mtargs.o

;;     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 <http://www.gnu.org/licenses/>.

;;======================================================================

;; (declare (uses common))
;; (declare (uses megatest-version))
(declare (uses mtargs))
(declare (uses treemod))

(use srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors)
(use format)
(use format
     (prefix iup iup:)
     canvas-draw)
(import canvas-draw-iup)
;; (debug:setup)

(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))
(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 margs))

;; (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")

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest

      (exit)))

;; 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")))))

(define (iuplistbox-fill-list lb items . default)
  (let ((i 1)
	(selected-item (if (null? default) #f (car default))))
    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" 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)))))


;; the main tree, everything starts from here
(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)
(define (main-tree)
;;   (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
  (iup:treebox
;; 			    #:expand "YES"
;; 			    #:numcol 1
   #:value 0
;; 			    #:numlin 5
;; 			    #:numcol-visible 1
   #:title "Areas"
;; 			    #: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"
   #: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)
   #:addexpanded "YES"
   #:size "10x"
   #:selection-cb
;; 						       (let ((cmd (iup:attribute command-text-box "VALUE")))
;; 							 (system (conc cmd "  &"))))))
;; 	 (run-test  (lambda (x)
   (lambda (obj id state)
;; 		      (iup:attribute-set! 
;; 		       command-text-box "VALUE"
     (print "do nothing..."))))

;; 		       (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!
(define (runs window-id)
  (iup:hbox
;; 			 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))
   (add-widget "main-tree" (main-tree))
;;       (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)
(define (runs-init)
;;   (iup:split
;;    (let* ((tb      (iup:treebox
  (let* ((areas (get-areas))
;; 		    #: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
	 (tb    (get-widget "main-tree")))
;; 	      ;; 
;; 	      (for-each 
;; 	       (lambda (data)
;; 		 (let ((mat    (car data))
;; 		       (vals   (cadr data))
;; 		       (rownum 1))
;; 		   (for-each 
;; 		    (lambda (key)
    (for-each
     (lambda (areadat)
;; 		      (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)))
       (tree:add-node tb "Areas" `(,(car areadat))))
     areas)))
;; 	       (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)))))

;; 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)

(define (newdashboard dbstruct)
  (let* ((data     (make-hash-table))
	 (keys     '()) ;; (db:get-keys dbstruct))
	 (runname  "%")
	 (testpatt "%")
	 (keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
         (states   '())
	 (statuses '())
	 (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
			 #t
			 (if (< nextmintime (current-milliseconds))
			 #;(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"))))))

)
;; (dboard:data-updaters-set! *data* (make-hash-table))
(newdashboard #f) ;; *dbstruct-local*)    


;;======================================================================
;; D A S H B O A R D
;;======================================================================


(import ndboard)
(newdashboard #f)
(iup:main-loop)

;;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================

(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)
                       ))))
|#