Megatest

Artifact [e946817510]
Login

Artifact e94681751047f358ec6cb5de082ca29cfd6dc135:


;;======================================================================
;; AREAS
;;======================================================================

(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
  ;; maps data from tabdat view-dat to the matrix
  ;; if input databases have changed, refresh view-dat
  ;; if filters have changed, refresh view-dat from input databases
  ;; if pivots  have changed, refresh view-dat from input databases
  (let* ((runs-hash    (dashboard:areas-get-runs-hash tabdat))
	 (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
	 (tree-path    (dboard:tabdat-tree-path tabdat)))
    (dboard:areas-update-tree tabdat runs-hash runs-header tb)
    (print "Tree path: " tree-path)
    (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
    (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
    (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")

    ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
    (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
   
    ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
    ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
    (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
    (iup:attribute-set! run-matrix "1:1" (conc tree-path))
    (iup:attribute-set! run-matrix "REDRAW" "ALL")))
  
  ;; (dashboard:areas-do-update-rundat tabdat) ;; )
  ;; (dboard:areas-summary-control-panel-updater tabdat)
  ;; (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
  ;; 	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
  ;; 	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
  ;;        (runs         (vector-ref runs-dat 1))
  ;; 	 (run-id       (dboard:tabdat-curr-run-id tabdat))
  ;;        (runs-hash (dashboard:areas-get-runs-hash tabdat))
  ;;        ;; (runs-hash    (let ((ht (make-hash-table)))
  ;; 	 ;;        	 (for-each (lambda (run)
  ;; 	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
  ;; 	 ;;        		   runs)
  ;; 	 ;;        	 ht))
  ;;        )
  ;;   (if (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-tree)
  ;;       (dboard:areas-update-tree tabdat runs-hash runs-header tb))
  ;;   (if run-id
  ;;       (let* ((matrix-content
  ;;               (case (dboard:tabdat-runs-summary-mode tabdat) 
  ;;                 ((one-run) (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash))
  ;;                 ((xor-two-runs) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash))
  ;;                 ((xor-two-runs-hide-clean) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
  ;;                 (else (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)))))
  ;;         (when matrix-content
  ;;           (let* ((indices      (common:sparse-list-generate-index matrix-content)) ;;  proc: set-cell))
  ;;                  (row-indices  (cadr indices))
  ;;                  (col-indices  (car 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)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
  ;;                  (numrows      1)
  ;;                  (numcols      1)
  ;;                  (changed      #f)
  ;;                  )
  ;;             
  ;;             (dboard:tabdat-filters-changed-set! tabdat #f)
  ;;             (let loop ((pass-num 0)
  ;;                        (changed  #f))
  ;;               (if (eq? pass-num 1)
  ;;                   (begin ;; big reset
  ;;                     (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
  ;;                     (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
  ;;                     (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
  ;; 
  ;;               (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
  ;;                   (iup:attribute-set! run-matrix "NUMCOL" max-col ))
  ;; 
  ;;               (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
  ;;                 (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
  ;;                     (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
  ;;               
  ;;               ;; Row labels
  ;;               (for-each (lambda (ind)
  ;;                           (let* ((name (car ind))
  ;;                                  (num  (cadr ind))
  ;;                                  (key  (conc num ":0")))
  ;;                             (if (not (equal? (iup:attribute run-matrix key) name))
  ;;                                 (begin
  ;;                                   (set! changed #t)
  ;;                                   (iup:attribute-set! run-matrix key name)))))
  ;;                         row-indices)
  ;;               ;; (print "row-indices: " row-indices " col-indices: " col-indices)
  ;;               (if (and (eq? pass-num 0) changed)
  ;;                   (loop 1 #t)) ;; force second pass
  ;;               
  ;;               ;; Cell contents
  ;;               (for-each (lambda (entry)
  ;;                           ;; (print "entry: " entry)
  ;;                           (let* ((row-name  (cadr entry))
  ;;                                  (col-name  (car entry))
  ;;                                  (valuedat  (caddr entry))
  ;;                                  (test-id   (list-ref valuedat 0))
  ;;                                  (test-name row-name) ;; (list-ref valuedat 1))
  ;;                                  (item-path col-name) ;; (list-ref valuedat 2))
  ;;                                  (state     (list-ref valuedat 1))
  ;;                                  (status    (list-ref valuedat 2))
  ;;                                  (value     (gutils:get-color-for-state-status state status))
  ;;                                  (row-num   (cadr (assoc row-name row-indices)))
  ;;                                  (col-num   (cadr (assoc col-name col-indices)))
  ;;                                  (key       (conc row-num ":" col-num)))
  ;;                             (hash-table-set! cell-lookup key test-id)
  ;;                             (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
  ;;                                 (begin
  ;;                                   (set! changed #t)
  ;;                                   (iup:attribute-set! run-matrix key (cadr value))
  ;;                                   (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
  ;;                         matrix-content)
  ;;               
  ;;               ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
  ;;               
  ;;               (for-each (lambda (ind)
  ;;                           (let* ((name (car ind))
  ;;                                  (num  (cadr ind))
  ;;                                  (key  (conc "0:" num)))
  ;;                             (if (not (equal? (iup:attribute run-matrix key) name))
  ;;                                 (begin
  ;;                                   (set! changed #t)
  ;;                                   (iup:attribute-set! run-matrix key name)
  ;;                                   (if (<= num max-col)
  ;;                                       (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
  ;;                         col-indices)
  ;;               
  ;;               (if (and (eq? pass-num 0) changed)
  ;;                   (loop 1 #t)) ;; force second pass due to column labels changing
  ;;               
  ;;               ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)
  ;;               ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num)
  ;;               (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))))))

(define (dboard:areas-make-matrix commondat tabdat )
  (iup:matrix
   #:expand "YES"
   #:click-cb
   
   (lambda (obj lin col status)
     (debug:catch-and-dump
      (lambda ()
	
	;; Bummer - we dont have the global get/set api mapped in chicken
	;; (let* ((modkeys (iup:global "MODKEYSTATE")))
	;;   (BB> "modkeys="modkeys))
	
	(debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status)
	;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
	(let* ((toolpath (car (argv)))
	       (key      (conc lin ":" col))
	       (test-id   (hash-table-ref/default cell-lookup key -1))
	       (run-id   (dboard:tabdat-curr-run-id tabdat))
	       (run-info (mrmt:get-run-info run-id))
	       (target   (mrmt:get-target run-id))
	       (runname  (db:get-value-by-header (db:get-rows run-info)
						 (db:get-header run-info) "runname"))
	       (test-info  (mrmt:get-test-info-by-id run-id test-id))
	       (test-name (db:test-get-testname test-info))
	       (testpatt  (let ((tlast (mrmt:tasks-get-last target runname)))
			    (if tlast
				(let ((tpatt (tasks:task-get-testpatt tlast)))
				  (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
				      "%"
				      tpatt))
				"%")))
	       (item-path (db:test-get-item-path (mrmt:get-test-info-by-id run-id test-id)))
	       (item-test-path (conc test-name "/" (if (equal? item-path "")
						       "%" 
						       item-path)))
	       (status-chars (char-set->list (string->char-set status)))
	       (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
	  (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
	  (cond
	   ((member #\1 status-chars) ;; 1 is left mouse button
	    (system testpanel-cmd))
	   
	   ((member #\2 status-chars) ;; 2 is middle mouse button
	    
	    (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
	    (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
		      #:x 'mouse
		      #:y 'mouse
		      #:modal? "NO")
	    )
	   (else
	    (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb.  Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy  iup install??" )
	    (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
		      #:x 'mouse
		      #:y 'mouse
		      #:modal? "NO")
	    )))) "runs-summary-click-callback"))))

;; This is the Areas Summary tab
;; 
(define (dashboard:areas-summary commondat tabdat #!key (tab-num #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Areas"
		   #:expand "YES"
		   #:addexpanded "YES"
		   #:selection-cb
		   (lambda (obj id state)
		     (debug:catch-and-dump
		      (lambda ()
			;; (print "obj: " obj ", id: " id ", state: " state)
			(let* ((prev-tree-path (dboard:tabdat-tree-path tabdat))
			       (tree-path      (tree:node->path obj id))
			       ;; Need to get the path construction from the pivot data but for now assume:
			       ;;   Area Target Runname




			       
			       ;;; ADD STUFF HERE ....


			       )
			  (if (not (equal? prev-tree-path tree-path))
			      (dboard:tabdat-view-changed tabdat))
			  
			  (dboard:tabdat-tree-path-set! tabdat tree-path)))
			  ;;      (run-id   (tree-path->run-id tabdat (cdr run-path))))
			  ;; (if (number? run-id)
			  ;;     (begin
                          ;;       (dboard:tabdat-prev-run-id-set!
                          ;;        tabdat
                          ;;        (dboard:tabdat-curr-run-id tabdat))
			  ;; 
			  ;; 	(dboard:tabdat-curr-run-id-set! tabdat run-id)
			  ;; 	(dboard:tabdat-layout-update-ok-set! tabdat #f)
			  ;; 	;; (dashboard:update-run-summary-tab)
			  ;; 	)
			  ;;     ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
			  ;;     )))
		      "selection-cb in areas-summary")
		     ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		     )))
	 (cell-lookup            (make-hash-table))
	 (areas-matrix           (dboard:areas-make-matrix commondat tabdat))
	 (areas-summary-updater  (lambda ()
				   ;; maps data from tabdat view-dat to the matrix
				   ;; if input databases have changed, refresh view-dat
				   ;; if filters have changed, refresh view-dat from input databases
				   ;; if pivots  have changed, refresh view-dat from input databases
				   (mutex-lock! update-mutex)
				   (if  (or ;; (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-updater)
					    (dboard:tabdat-view-changed tabdat))
					(debug:catch-and-dump
					 (lambda () ;; check that areas-matrix is initialized before calling the updater
					   (if areas-matrix 
					       (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
					 "dashboard:areas-summary-updater")
					)
				   (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat)))
    (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
      areas-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (dboard:tabdat-keys tabdat))
	 (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
         (allruns          (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))
				   runs-tree) ;; (vector-ref runs-dat 1))
			 ht))
	 (tb          (dboard:tabdat-runs-tree tabdat)))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (dboard:tabdat-header-set! tabdat header)
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (if (null? runs)
	(begin
	  (dboard:tabdat-allruns-set! tabdat '())
	  (dboard:tabdat-all-test-names-set! tabdat '())
	  (dboard:tabdat-item-test-names-set! tabdat '())
	  (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 ;; (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (mrmt:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)
	    ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
	    ;; (tests       (bubble-up tmptests priority: bubble-type))
	    ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
	    ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
	    ;; Not sure this is needed?
	    (let* ((newmaxtests (max num-tests maxtests))
		   ;; (last-update (- (current-seconds) 10))
		   (run-struct  (or run-struct
				    (dboard:rundat-make-init
				     run:         run 
				     tests:       tests-ht
				     key-vals:    key-vals)))
		   (new-res     (if (null? all-test-ids)
                                    res
                                    (delete-duplicates
                                     (cons run-struct res)
                                     (lambda (a b)
                                       (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
                                            (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
		   (elapsed-time (- (current-seconds) start-time)))
	      (if (null? all-test-ids)
		  (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
		  (hash-table-set!    (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
	      (if (or (null? tal)
		      (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
		  (begin
		    (when (> elapsed-time 2)   
                      (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
                      (let* ((old-val (iup:attribute *tim* "TIME"))
                             (new-val (number->string (inexact->exact (floor (* 2  (string->number old-val)))))))
                        (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
                        (iup:attribute-set! *tim* "TIME" new-val))


                      )
		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:areas-update-tree tabdat runs-hash header tb)))

;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat tabdat)
  (dboard:areas-update-rundat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       fres))))

(define (dashboard:areas-get-runs-hash tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
    runs-hash))
         
;; 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:areas-database-changed? commondat tabdat #!key (context-key 'default))
  (let* ((run-update-time (current-seconds))
	 (dbdir           (dboard:tabdat-dbdir tabdat))
	 (modtime         (dashboard:areas-get-youngest-run-db-mod-time dbdir))
	 (recalc          (dashboard:areas-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 (dboard:areas-update-tree tabdat runs-hash runs-header tb)
  (let* ((access-mode   (dboard:tabdat-access-mode tabdat))
         (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 runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (new-run-ids  (map (lambda (run)
			      (db:get-value-by-header run runs-header "id"))
			    runs))
	 (areas        (configf:get-section *configdat* "areas")))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (for-each
     (lambda (area)
       (let ((run-path (list area)))
	 (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
	     (begin
	       (tree:add-node tb "Areas" run-path)
	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path 0)))))
     (map car areas))
    ;; here the local area
    (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 runs-header key))
			       (dboard:tabdat-keys tabdat)))
	      (run-name   (db:get-value-by-header run-record runs-header "runname"))
	      (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
	      (run-path   (cons "local " (append key-vals (list run-name)))))
	 (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
	     ;; (let ((existing   (tree:find-node tb run-path)))
	     ;;   (if (not existing)
	     (begin
	       (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
	       ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
	       ;;    		 (conc rownum ":" colnum) col-name)
	       ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
	       ;; Here we update the tests treebox and tree keys
	       (tree:add-node tb "Areas" run-path) ;; (append key-vals (list run-name))
	       ;;                                             userdata: (conc "run-id: " run-id))))
	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
	       ;; (set! colnum (+ colnum 1))
	       ))))
     (append new-run-ids run-ids)))) ;; for-each run-id
  
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (mrmt:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
    (when (not run)
        (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))

(define (dashboard:areas-popup-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"
    #:action
    (lambda (obj)
      (let* ((toolpath (car (argv)))
             (testpanel-cmd
              (conc toolpath " -test " run-id "," test-id " &")))
        (system testpanel-cmd)
        )))
   
   (iup:menu-item
    (conc "View Log " item-test-path)
    #:action
    (lambda (obj)
      (let* ((rundir    (db:test-get-rundir      test-info))
	     (logf      (db:test-get-final_logf  test-info))
	     (fullfile  (conc rundir "/" logf)))
	(if (common:file-exists? fullfile)
	    (dcommon:run-html-viewer fullfile)
	    (message-window (conc "file " fullfile " not found.")))))
    )
   (let* ((steps (tests:get-compressed-steps run-id test-id))   ;; #<stepname start end status Duration Logfile Comment id>
	  (rundir (db:test-get-rundir test-info)))
     (iup:menu-item
      "Step logs"
      (apply iup:menu
	     (map (lambda (step)
		    (let ((stepname (vector-ref step 0))
			  (logfile  (vector-ref step 5))
			  (status   (vector-ref step 3)))
		      (iup:menu-item
		       (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
		       #:action (lambda (obj)
				  (let ((fullfile (conc rundir "/" logfile)))
				    (if (common:file-exists? fullfile)
					(dcommon:run-html-viewer fullfile)
					(message-window (conc "file " fullfile " not found"))))))))
		  steps))))
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))

   
   (iup:menu-item
    "Run"
    (iup:menu              
     (iup:menu-item
      (conc "Rerun " testpatt)
      #:action
      (lambda (obj)
        ;; (print  " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
	(common:run-a-command
	 (conc "megatest -run -target " target
	       " -runname " runname
	       " -testpatt " testpatt
	       " -preclean -clean-cache")
	 )))
     (iup:menu-item
      "Rerun Complete Run"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
               " -runname " runname
               " -testpatt % "
               " -preclean -clean-cache"))))
     (iup:menu-item
      "Clean Complete Run"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -remove-runs -target " target
               " -runname " runname
               " -testpatt % "))))
     (iup:menu-item 
      "Kill Complete Run"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
               " -testpatt % "
               "  -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
     (iup:menu-item 
      "Delete Run Data"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -remove-runs -target " target
               " -runname " runname
               " -testpatt % "
               "  -keep-records"))))))
   (iup:menu-item
    "Test"
    (iup:menu 
     (iup:menu-item
      (conc "Rerun " item-test-path)
      #:action
      (lambda (obj)
	(common:run-a-command
	 (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
	(common:run-a-command
	 (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
     (iup:menu-item
      (conc "Delete data : " item-test-path)
      #:action
      (lambda (obj)
	(common:run-a-command
	 (conc "megatest -remove-runs -target " target
               " -runname " runname
	       " -testpatt " item-test-path 
	       " -keep-records"))))
     (iup:menu-item
      (conc "Clean "item-test-path)
      #:action
      (lambda (obj)
	(common:run-a-command
	 (conc "megatest -remove-runs -target " target
               " -runname " runname
	       " -testpatt " item-test-path))))
     (iup:menu-item
      "Start xterm"
      #:action
      (lambda (obj)
        (dcommon:examine-xterm run-id test-id)))
	;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
	;; (system cmd))))
     (iup:menu-item
      "Edit testconfig"
      #:action
      (lambda (obj)
	(let* ((all-tests (tests:get-all))
	       (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") 
			      "\\b(vim?|nano|pico)\\b"))
	       (editor (or (configf:lookup *configdat* "setup" "editor")
			   (get-environment-variable "VISUAL")
			   (get-environment-variable "EDITOR") "vi"))
	       (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
	       (cmd (conc (if (string-search editor-rx editor)
			      (conc "xterm -e " editor)
			      editor)
			  " " tconfig " &")))
	  (system cmd))))
     ))))


(define (dashboard:areas-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 (dashboard:areas-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)))))

;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:areas-summary-control-panel-updater tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:areas-summary-control-panel-updater tabdat)
      res
      )))

(define (dboard:areas-summary-control-panel-updater tabdat)
  (dboard:areas-summary-xor-labels-updater tabdat)
  (dboard:areas-summary-buttons-updater tabdat))

(define (dboard:areas-summary-xor-labels-updater tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt:get-run-name-from-id prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

(define (dboard:areas-summary-buttons-updater tabdat)
  (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat))
             (modes-left (dboard:tabdat-runs-summary-modes tabdat)))
    (if (or (null? buttons-left) (null? modes-left))
        #t
        (let* ((this-button (car buttons-left))
               (mode-item (car modes-left))
               (this-mode (car mode-item))
               (sel-color    "180 100 100")
               (nonsel-color "170 170 170")
               (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
          (if (eq? this-mode current-mode)
              (iup:attribute-set! this-button "BGCOLOR" sel-color)
              (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
          (loop (cdr buttons-left) (cdr modes-left))))))