Megatest

;;======================================================================
;; 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/>.
;;
;;======================================================================

(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

;; yes, this is non-ideal 
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)

;;======================================================================
;; C O M M O N   D A T A   S T R U C T U R E
;;======================================================================
;; 
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
  ((curr-tab-num 0) : number)
  please-update  
  tabdats
  update-mutex
  updaters 
  updating
  uidat ;; needs to move to tabdat at some time
  hide-not-hide-tabs
  )

(define (dboard:commondat-make)
  (make-dboard:commondat
   curr-tab-num:         0
   tabdats:              (make-hash-table)
   please-update:        #t
   update-mutex:         (make-mutex)
   updaters:             (make-hash-table)
   updating:             #f
   hide-not-hide-tabs:   #f
   ))

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
    ((color        #f) : vector)
    ((flag         #t) : boolean)
    ((cell         #f) : number)
    )

;; data for runs, tests etc. was used in run summary?
;;
(defstruct dboard:runsdat
  ;; new system
  runs-index    ;; target/runname => colnum
  tests-index   ;; testname/itempath => rownum
  matrix-dat    ;; vector of vectors rows/cols
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree
  hierdat        ;; put hierarchial sorted list here
  tests          ;; hash of id => testdat
  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
  key-vals
  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
  ((data-changed  #f)                : boolean)   
  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
  (db-path #f))


;;======================================================================
;; D O T F I L E
;;======================================================================

(define (dcommon:write-dotfile fname dat)
  (with-output-to-file fname

;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise
;;
(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed)
  (let ((curr-val (iup:attribute mtrx cell-name)))
    (if (not (equal? curr-val new-val)) 
	(begin
	  (iup:attribute-set! mtrx cell-name new-val) ;; was col-name
	  #t) ;; need a re-draw
	prev-changed)))


;; TO-DO
;;  1. Make "data" hash-table hierarchial store of all displayed data
;;  2. Update synchash to understand "get-runs", "get-tests" etc.
;;  3. Add extraction of filters to synchash calls
;;
;;    NOTE: Used in newdashboard
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
;;   (let* (;; count and offset => #f so not used
;; 	 ;; the synchash calls modify the "data" hash
;; 	 (changed         #f)
;; 	 (get-runs-sig    (conc (client:get-signature) " get-runs"))
;; 	 (get-tests-sig   (conc (client:get-signature) " get-tests"))
;; 	 (get-details-sig (conc (client:get-signature) " get-test-details"))
;; 
;; 	 ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
;; 	 (test-ids        (hash-table-values (dboard:tabdat-curr-test-ids data)))
;; 	 ;; run-id is #f in next line to send the query to server 0
;;  	 (run-changes     (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
;; 	 (tests-detail-changes (if (not (null? test-ids))
;; 				   (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0  data #f test-ids)
;; 				   '()))
;; 
;; 	 ;; Now can calculate the run-ids
;; 	 (run-hash    (hash-table-ref/default data get-runs-sig #f))
;; 	 (run-ids     (if run-hash (filter number? (hash-table-keys run-hash)) '()))
;; 
;; 	 (all-test-changes (let ((res (make-hash-table)))
;; 			     (for-each (lambda (run-id)
;; 					 (if (> run-id 0)
;; 					     (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
;; 				       run-ids)
;; 			     res))
;; 	 (runs-hash    (hash-table-ref/default data get-runs-sig #f))
;; 	 (header       (hash-table-ref/default runs-hash "header" #f))
;; 	 (run-ids      (sort (filter number? (hash-table-keys runs-hash))
;; 			     (lambda (a b)
;; 			       (let* ((record-a (hash-table-ref runs-hash a))
;; 				      (record-b (hash-table-ref runs-hash b))
;; 				      (time-a   (db:get-value-by-header record-a header "event_time"))
;; 				      (time-b   (db:get-value-by-header record-b header "event_time")))
;; 				 (> time-a time-b)))
;; 			     ))
;; 	 (runid-to-col    (hash-table-ref *cachedata* "runid-to-col"))
;; 	 (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) 
;; 	 (colnum       1)
;; 	 (rownum       0)
;; 	 (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
;;     
;; 	 ;; tests related stuff
;; 	 ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
;; 
;;     ;; Given a run-id and testname/item_path calculate a cell R:C
;; 
;;     ;; NOTE: Also build the test tree browser and look up table
;;     ;;
;;     ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
;;     (for-each (lambda (run-id)
;; 		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
;; 		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record header key))
;; 					keys))
;; 		       (run-name   (db:get-value-by-header run-record header "runname"))
;; 		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
;; 		       (run-path   (append key-vals (list run-name))))
;; 		  (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
;; 		  ;; modify cell - but only if changed
;; 		  (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
;; 		  (hash-table-set! runid-to-col run-id (list colnum run-record))
;; 		  ;; Here we update the tests treebox and tree keys
;; 		  (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
;; 				 userdata: (conc "run-id: " run-id))
;; 		  (set! colnum (+ colnum 1))))
;; 	      run-ids)
;; 
;;     ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
;;     ;; Do this analysis in the order of the run-ids, the most recent run wins
;;     (for-each (lambda (run-id)
;; 		(let* ((run-path       (hash-table-ref (dboard:tabdat-run-keys data) run-id))
;; 		       (test-changes   (hash-table-ref all-test-changes run-id))
;; 		       (new-test-dat   (car test-changes))
;; 		       (removed-tests  (cadr test-changes))
;; 		       (tests          (sort (map cadr (filter (lambda (testrec)
;; 								 (eq? run-id (db:mintest-get-run_id (cadr testrec))))
;; 							       new-test-dat))
;; 					     (lambda (a b)
;; 					       (let ((time-a (db:mintest-get-event_time a))
;; 						     (time-b (db:mintest-get-event_time b)))
;; 						 (> time-a time-b)))))
;; 		       ;; test-changes is a list of (( id record ) ... )
;; 		       ;; Get list of test names sorted by time, remove tests
;; 		       (test-names (delete-duplicates (map (lambda (t)
;; 							     (let ((i (db:mintest-get-item_path t))
;; 								   (n (db:mintest-get-testname  t)))
;; 							       (if (string=? i "")
;; 								   (conc "   " i)
;; 								   n)))
;; 							   tests)))
;; 		       (colnum     (car (hash-table-ref runid-to-col run-id))))
;; 		  ;; for each test name get the slot if it exists and fill in the cell
;; 		  ;; or take the next slot and fill in the cell, deal with items in the
;; 		  ;; run view panel? The run view panel can have a tree selector for
;; 		  ;; browsing the tests/items
;; 
;; 		  ;; SWITCH THIS TO USING CHANGED TESTS ONLY
;; 		  (for-each (lambda (test)
;; 			      (let* ((test-id   (db:mintest-get-id test))
;; 				     (state     (db:mintest-get-state test))
;; 				     (status    (db:mintest-get-status test))
;; 				     (testname  (db:mintest-get-testname test))
;; 				     (itempath  (db:mintest-get-item_path test))
;; 				     (fullname  (conc testname "/" itempath))
;; 				     (dispname  (if (string=? itempath "") testname (conc "   " itempath)))
;; 				     (rownum    (hash-table-ref/default testname-to-row fullname #f))
;; 				     (test-path (append run-path (if (equal? itempath "") 
;; 								     (list testname)
;; 								     (list testname itempath))))
;; 				     (tb         (dboard:tabdat-tests-tree data)))
;; 				(print "INFONOTE: run-path: " run-path)
;; 				(tree:add-node (dboard:tabdat-tests-tree data) "Runs" 
;; 					       test-path
;; 					       userdata: (conc "test-id: " test-id))
;; 				(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
;; 				      (color    (car (gutils:get-color-for-state-status state status))))
;; 				  (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
;; 
;; 				  (set! changed (dcommon:modifiy-if-different 
;; 						 tb
;; 						 (conc "COLOR" node-num)
;; 						 color changed))
;; 
;; 				  ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)

;; 				  )
;; 				(hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
;; 				(if (not rownum)
;; 				    (let ((rownums (hash-table-values testname-to-row)))
;; 				      (set! rownum (if (null? rownums)

;; 						       1
;; 						       (+ 1 (common:max rownums))))
;; 				      (hash-table-set! testname-to-row fullname rownum)
;; 				      ;; create the label
;; 				      (set! changed (dcommon:modifiy-if-different 
;; 						     (dboard:tabdat-runs-matrix data)
;; 						     (conc rownum ":" 0)
;; 						     dispname
;; 						     changed))
;; 				      ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				      ;;   		  (conc rownum ":" 0) dispname)
;; 				      ))
;; 				;; set the cell text and color
;; 				;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
;; 				(set! changed (dcommon:modifiy-if-different 
;; 						     (dboard:tabdat-runs-matrix data)
;; 						     (conc rownum ":" colnum)
;; 						     (if (member state '("ARCHIVED" "COMPLETED"))
;; 							 status
;; 							 state)
;; 						     changed))
;; 				;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				;; 		    (conc rownum ":" colnum)
;; 				;; 		    (if (member state '("ARCHIVED" "COMPLETED"))
;; 				;; 			status
;; 				;; 			state))
;; 				(set! changed (dcommon:modifiy-if-different 
;; 					       (dboard:tabdat-runs-matrix data)
;; 					       (conc "BGCOLOR" rownum ":" colnum)
;; 					       (car (gutils:get-color-for-state-status state status))
;; 					       changed))
;; 				;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; 				;; 		    (conc "BGCOLOR" rownum ":" colnum)
;; 				;; 		    (car (gutils:get-color-for-state-status state status)))
;; 				))
;; 			    tests)))
;; 	      run-ids)
;; 
;;     (let ((updater (hash-table-ref/default  (dboard:commondat-updaters commondat) window-id #f)))
;;       (if updater (updater (hash-table-ref/default data get-details-sig #f))))
;; 
;;     (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;;     ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;;     ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;;     (list run-changes all-test-changes)))

#;(define (dcommon:runsdat-get-col-num dat target runname force-set)
  (let* ((runs-index (dboard:runsdat-runs-index dat))
	 (col-name   (conc target "/" runname))
	 (res        (hash-table-ref/default runs-index col-name #f)))
    (if res
	res
	(if force-set
	    (let ((max-col-num (+ 1 (common:max (cons-1 (hash-table-values runs-index))))))
	      (hash-table-set! runs-index col-name max-col-num)
	      max-col-num)))))

#;(define (dcommon:runsdat-get-row-num dat testname itempath force-set)
  (let* ((tests-index (dboard:runsdat-runs-index dat))
	 (row-name    (conc testname "/" itempath))
	 (res         (hash-table-ref/default runs-index row-name #f)))
    (if res
	res
	(if force-set
	    (let ((max-row-num (+ 1 (common:max (cons -1 (hash-table-values tests-index))))))

		 (tal (cdr tests-dat))
		 (res '()))
	(let* ((test-id    (db:test-get-id hed)) ;; look at the tests-dat spec for locations
	       (test-name  (db:test-get-testname hed))
	       (item-path  (db:test-get-item-path hed))
	       (state      (db:test-get-state hed))
	       (status     (db:test-get-status hed))
               (event-time (db:test-get-event_time hed))
	       (newitem    (list test-name item-path (list test-id state status event-time))))
	  (if (null? tal)
	      (reverse (cons newitem res))
	      (loop (car tal)(cdr tal)(cons newitem res)))))))

(define (dcommon:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
              (value (list-ref item 2)))
         (hash-table-set! res test-name+item-path value)))
     tests-mindat)
    res))

;; return 1 if status1 is better
;; return 0 if status1 and 2 are equally good
;; return -1 if status2 is better
(define (dcommon:status-compare3 status1 status2)
  (let*
      ((status-goodness-ranking  (cdr ;; cdr to drop first item -- "n/a"
                                  (append (map cadr *common:std-statuses*)
                                          '(#f)) ;; algorithm requres last item to be #f
                                  )  )
       (mem1 (member status1 status-goodness-ranking))
       (mem2 (member status2 status-goodness-ranking))
       )
    (cond
     ((and (not mem1) (not mem2)) 0)
     ((not mem1) -1)
     ((not mem2) 1)

    (if (not testdat)
        (begin
          (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
          (exit 1))
        (let*
            ((rundir        (if testdat 
                                (db:test-get-rundir testdat)
                                (current-directory))) ;; logfile))
             (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
             (xterm      (lambda ()
                           (if (directory-exists? rundir)
                               (let* ((shell (if (get-environment-variable "SHELL") 
                                                 (conc "-e " (get-environment-variable "SHELL"))
                                                 ""))
                                      (command (conc "cd " rundir 

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
         (key-vals        (configf:section-vars rawconfig sectionname))
         (section-matrix  (iup:matrix
                           #:alignment1 "ALEFT"
                           ;; #:expand "YES" ;; "HORIZONTAL"
                           #:numcol 1
                           #:numlin (length key-vals)
                           #:numcol-visible 1
                           #:numlin-visible (min 10 (length key-vals))
			   #:scrollbar "YES")))
    (iup:attribute-set! section-matrix "0:0" varcolname)
    (iup:attribute-set! section-matrix "0:1" valcolname)

    ;; (iup:attribute-set! general-matrix "2:0" "Area")
    ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
    ;; Megatest version
    (iup:attribute-set! general-matrix "2:0" "Version")
    (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

    general-matrix))

(define (dcommon:stats-updater commondat tabdat stats-matrix)
  (if (and (iup:ihandle? stats-matrix)
	   (dashboard:database-changed? commondat tabdat context-key: 'run-stats))
      (let* ((changed      #f)
	     (run-stats    (rmt:get-run-stats))
	     (indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
	     (row-indices  (car indices))
	     (col-indices  (cadr indices))
	     (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
	     (max-col      (if (null? col-indices) 1 
			       (common:max (map cadr col-indices))))
	     (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3))
	     (max-col-vis  (if (> max-col 10) 10 max-col))
	     (numrows      1)
	     (numcols      1))
	(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
	(iup:attribute-set! stats-matrix "NUMCOL" max-col )
	(iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
	(iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
	(iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
	(print "row-indices: " row-indices " col-indices: " col-indices)
	;; Row labels
	(for-each (lambda (ind)
		    (let* ((name (car ind))
			   (num  (cadr ind))
			   (key  (conc num ":0")))
		      (if (not (equal? (iup:attribute stats-matrix key) name))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key name)))))
		  row-indices)

	;; Col labels
	(for-each (lambda (ind)
		    (let* ((name (car ind))
			   (num  (cadr ind))
			   (key  (conc "0:" num)))
		      (if (not (equal? (iup:attribute stats-matrix key) name))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key name)))))
		  col-indices)

	;; Cell contents
	(for-each (lambda (entry)
		    (let* ((row-name (car entry))
			   (col-name (cadr entry))
			   (value    (caddr entry))
			   (row-num  (cadr (assoc row-name row-indices)))
			   (col-num  (cadr (assoc col-name col-indices)))
			   (key      (conc row-num ":" col-num)))
		      (if (not (equal? (iup:attribute stats-matrix key) value))
			  (begin
			    (set! changed #t)
			    (iup:attribute-set! stats-matrix key value)))))
		  run-stats)
	(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))))


(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
  (let* ((stats-matrix (iup:matrix expand: "YES"))

	 (stats-updater (lambda ()

















			  (dcommon:stats-updater commondat tabdat stats-matrix))))





































    ;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass 
    ;; (mark-for-update tabdat)
    ;; (stats-updater)
    (dboard:commondat-add-updater commondat stats-updater tab-num: tab-num)
    ;; (set! dashboard:update-summary-tab updater)
    (iup:attribute-set! stats-matrix "WIDTHDEF" "40")
    (iup:vbox

(define (dcommon:main-menu)
  (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
   (iup:menu-item "Files" (iup:menu   ;; Note that you can use either #:action or action: for options
			   (iup:menu-item "Open"  action: (lambda (obj)
							    (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
								   (fd        (iup:file-dialog #:dialogtype "DIR"))
								   (top       (iup:show fd #:modal? "YES")))
							      (iup:attribute-set! area-name "VALUE" ;; was source-tb, no idea what is correct
										  (iup:attribute fd "VALUE"))
							      (iup:destroy! fd))))
			   ;; (lambda (obj)
			   ;;  (iup:show (iup:file-dialog))
			   ;;  (print "File->open " obj)))
			   (iup:menu-item "Save"  #:action (lambda (obj)(print "File->save " obj)))
			   (iup:menu-item "Exit"  #:action (lambda (obj)(exit)))))

					     (let ((il (cddddr inlst)))
					       (take il (- (length il) 2))))
					(lambda (x y)
					  (list (+ x 0)   ;; xtorig)
						(+ y 0))) ;; ytorig)))
					#f #f)) ;; process polyline
				     edges))))
		 (cx   (if no-dot ;; this is the centerpoint!
			   curr-x
			   (string->number (list-ref nodedat 2))))
		 (cy   (if no-dot
			   curr-y
			   (string->number (list-ref nodedat 3))))
		 (boxw (if no-dot
			   boxw
			   (string->number (list-ref nodedat 4))))
		 (boxh (if no-dot
			   boxh
			   (string->number (list-ref nodedat 5))))
		 (boxw/2  (/ boxw 2))
		 (boxh/2  (/ boxh 2))
		 (urx     (+ cx boxw/2))
		 (ury     (+ cy boxh/2))
		 (llx     (- cx boxw/2))
		 (lly     (- cy boxh/2)))

	    ;; if we are in no-dot mode then increment curr-x and curr-y as needed
	    (if no-dot
		(begin
		  (cond 
		   ((< curr-x (- scaled-sizex boxw boxw margin))
		    (set! curr-x (+ curr-x boxw margin)))

;;  #:title "Target"
;;  ;; Target selectors
;;  (apply iup:hbox
;; 	   (let* ((dat      (dashboard:update-target-selector tabdat action-proc: update-keyvals))
;; 		  (key-lb   (car dat))
;; 		  (combos   (cadr dat)))
;; 	     combos)))
   ;; (iup:hbox
   ;;  ;; Text box for STATES
   ;;  (iup:frame
   ;;   #:title "States"
   ;;   (dashboard:text-list-toggle-box 
   ;;    ;; Move these definitions to common and find the other useages and replace!
   ;;    (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
   ;;    (lambda (all)
   ;;      (dboard:tabdat-states-set! tabdat all)
   ;;      (dashboard:update-run-command tabdat))))
   ;;  ;; Text box for STATES
   ;;  (iup:frame
   ;;   #:title "Statuses"
   ;;   (dashboard:text-list-toggle-box 
   ;;    (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
   ;;    (lambda (all)
   ;;      (dboard:tabdat-statuses-set! tabdat all)
   ;;      (dashboard:update-run-command tabdat)))))
   ))

(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
  (iup:frame
   #:title "Tests and Tasks"
   (let* ((updater #f)
	  (last-xadj 0)
	  (last-yadj 0)

				      (hash-table-set! tests-draw-state 'scalef (+ scalef
										   (if (> step 0)
										       (* scalef 0.01)
										       (* scalef -0.01))))
				      (if the-cnv
					  (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
				      ))
		       ;; #:size "250x250"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
		       #:button-cb (lambda (obj btn pressed x y status)
				     ;; (print "obj: " obj ", pressed " pressed ", status " status)
					; (print "canvas-origin: " (canvas-origin the-cnv))

						 (hash-table-keys tests-info)))))))
     canvas-obj)))

;;======================================================================
;;  S T E P S
;;======================================================================

(define (dcommon:populate-steps teststeps steps-matrix run-id test-id)
  (let* ((max-row       0)
	 (max-col       9)
         (white         "255 255 255")
         
         (testinfo      (rmt:get-testinfo-state-status run-id test-id))
         (state         (db:test-get-state testinfo))
         (status        (db:test-get-status testinfo))
         (test-status-color (car (gutils:get-color-for-state-status state status)))
         (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED")))
         (failcolor     (car (gutils:get-color-for-state-status "COMPLETED" "FAIL"))))
    (if (null? teststeps)
	(begin
          (iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS")
          (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS"))
	(let loop ((hed    (car teststeps))
		   (tal    (cdr teststeps))
		   (rownum 1)
		   (colnum 1))
	  (if (> rownum max-row)(set! max-row rownum))
	  (let* ((status  (vector-ref hed 3))
                 (val     (vector-ref hed (- colnum 1)))
                 (bgcolor (cond
                           ((member (conc status) '("" "-" "#<unspecified>"))
                            running-color)
                           
                           ((member (conc status) '("0" 0))
                            white)
                           (else test-status-color)))
                          ; (else failcolor)))
		 (mtrx-rc (conc rownum ":" colnum)))
            ;;(print "BB> status=>"status"< bgcolor="bgcolor)
	    (iup:attribute-set! steps-matrix  mtrx-rc (if val (conc val) ""))
            (if (< colnum 5)
                (iup:attribute-set! steps-matrix  (conc "BGCOLOR" mtrx-rc) bgcolor))
	    (if (< colnum max-col)
		(loop hed tal rownum (+ colnum 1))
		(if (not (null? tal))
		    (loop (car tal) (cdr tal) (+ rownum 1) 1))))))
    (if (> max-row 0)
	(begin
	  ;; we are going to speculatively clear rows until we find a row that is already cleared
	  (let loop ((rownum  (+ max-row 1))
		     (colnum  0)
		     (deleted #f))
	    ;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum)

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

(define (dcommon:run-html-viewer lfilename)
  (let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
    (if htmlviewercmd
	(system (conc "(" htmlviewercmd " " lfilename " ) &")) 
	(iup:send-url lfilename))))

(define (dashboard:monitor-changed? commondat tabdat)
  (let* ((run-update-time (current-seconds))
	 (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
	 (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
			      (file-modification-time monitor-db-path)
			      -1)))
    (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0)
	     (or (> monitor-modtime *last-monitor-update-time*)
		 (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case
	(begin
	  (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime)
	  #t)
	#f)))

;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db
;; is closed (I think). If db dir starts with /tmp always return true
;;
(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
  (let* ((run-update-time (current-seconds))
	 (dbdir           (dboard:tabdat-dbdir tabdat))
	 (modtime         (dashboard:get-youngest-run-db-mod-time dbdir))
	 (recalc          (dashboard:recalc modtime 
					    (dboard:commondat-please-update commondat) 
					    (dboard:get-last-db-update tabdat context-key))))
    ;; (dboard:tabdat-last-db-update tabdat))))
    (if recalc 
	(dboard:set-last-db-update! tabdat context-key run-update-time))
    (dboard:commondat-please-update-set! commondat #f)
    recalc))

(define (dashboard:get-youngest-run-db-mod-time dbdir)
  (handle-exceptions
   exn
   (begin
     (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir)
     (current-seconds)) ;; something went wrong - just print an error and return current-seconds
   (common:max (map (lambda (filen)
		      (file-modification-time filen))
		    (glob (conc dbdir "/*.db*"))))))

(define (dboard:get-last-db-update tabdat context)
  (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0))

(define (dboard:set-last-db-update! tabdat context newtime)
  (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))

;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
  (and (< lx1 px)(> lx2 px)))

(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
  (or please-update-buttons
      (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
	   (> modtime (- last-db-update-time 3)) ;; add three seconds of margin
	   (> (current-seconds)(+ last-db-update-time 1)))))