Megatest

            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            hostinfo.scm adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm

# GUISRCF = 

GUIMODFILES = tree.scm dashboard-tests.scm  vgmod.scm \
              dashboard-context-menu.scm dcommon.scm 

# dashboard-guimonitor.scm 

mofiles/dashboard-context-menu.o : mofiles/dcommon.o
mofiles/dashboard-tests.o : mofiles/dcommon.o
# mofiles/dcommon.o mofiles/tree.o : mofiles/gutils.o

OFILES   = $(SRCFILES:%.scm=%.o)
# GOFILES  = $(GUISRCF:%.scm=%.o)

MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
GMOFILES = $(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o))

# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
GMOIMPFILES = $(GUIMODFILES:%.scm=%.import.o)

mtest: megatest.scm $(MOFILES) $(MOIMPFILES)
	csc $(CSCOPTS) $(MOFILES) $(MOIMPFILES) megatest.scm -o mtest

showmtesthash:
	@echo $(MTESTHASH)

dboard : $(OFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard

mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut

# include makefile.inc

TCMTOBJS = \

	if  csi -ne '(import mysql-client)';then \
           echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(import postgresql)';then \
	   echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o 
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o 

buildmanual:
	cd docs/manual && make

targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'

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

;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================

(declare (unit dashboard-context-menu))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
;; (declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrunmod))
(declare (uses debugprint))
(declare (uses testsmod))
(declare (uses dcommon))

(module dashboard-context-menu
	*

(import format fmt)
(import (prefix iup iup:))

	chicken.string
	chicken.time

	srfi-1
	regex regex-case srfi-69
	(prefix sqlite3 sqlite3:))















(import commonmod
	dbmod
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
	configfmod

;;======================================================================
;; Test info panel
;;======================================================================

(declare (unit dashboard-tests))
(declare (uses commonmod))
(declare (uses dbmod))
;; (declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrunmod))
(declare (uses debugprint))
(declare (uses configfmod))

(import commonmod
	dcommon
	dbmod
	rmtmod
	ezstepsmod
	subrunmod
	debugprint
;;	gutils
	configfmod
	testsmod
	mtmod
	launchmod
	)

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

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

;; (declare (uses bigmod))
;; (declare (uses gutils))
;; (declare (uses bigmod.import))
;; (declare (uses commonmod))
;; (declare (uses configfmod))
;; (declare (uses dashboard-context-menu))
;; (declare (uses dashboard-tests))
;; (declare (uses dbmod))
;; (declare (uses dcommon))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))

;; (declare (uses itemsmod))
;; (declare (uses launchmod))
;; (declare (uses mtargs))
;; (declare (uses mtmod))
;; (declare (uses mtver))
;; (declare (uses processmod))
;; (declare (uses runsmod))
;; (declare (uses subrunmod))
;; (declare (uses tree))
;; (declare (uses vgmod))

;; (declare (uses dashboard-guimonitor))
;; (declare (uses dashboard-main))

(import (prefix iup iup:))
(import canvas-draw)

;; (import canvas-draw-iup)

;; (include "run_records.scm")
;; (include "task_records.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (include "vg_records.scm")

(import commonmod
	;; gutils
	configfmod
	dbmod
	debugprint
	itemsmod
	launchmod
	(prefix mtargs args:)
	mtmod
	mtver
	processmod
	runsmod
	subrunmod
	vgmod
	dcommon

	tree
	dashboard-context-menu
	dashboard-tests)

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

(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME")))

(define (pad-list l n)(append l (make-list (- n (length l)))))







(define (dboard:compare-tests test1 test2)
  (let* ((test-name1  (db:test-get-testname  test1))
	 (item-path1  (db:test-get-item-path test1))
	 (eventtime1  (db:test-get-event_time test1))
	 (test-name2  (db:test-get-testname  test2))
	 (item-path2  (db:test-get-item-path test2))
	 (eventtime2  (db:test-get-event_time test2))

;; 
;;     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 dcommon))
;; (declare (uses gutils))
(declare (uses dbmod))
(declare (uses mtver))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses mtargs))

(import mtver
	dbmod
	commonmod
	debugprint
	configfmod
	rmtmod
	;; gutils
	(prefix mtargs args:)
	testsmod)

;; (include "megatest-version.scm")
(include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")

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

;;======================================================================
;; stuff from gutils
;;

(define (iuplistbox-fill-list lb items #!key (selected-item #f))
  (let ((i 1))
    (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" i))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    ;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    i))

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

;; NOTE: These functions will move to iuputils

(define (gutils:colors-similar? color1 color2)
  (let* ((c1 (map string->number (string-split color1)))
	 (c2 (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define gutils:colors
  '((PASS . "70 249 73")
    (FAIL . "253 33 49")
    (SKIP . "230 230 0")))

(define (gutils:get-color-spec effective-state)
  (or (alist-ref effective-state gutils:colors)
      (alist-ref 'FAIL gutils:colors)))

;; BBnote - state status dashboard button color / text defined here
(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
  ;; ((if get-label cadr car)
  (case (string->symbol state)
    ((COMPLETED) ;; ARCHIVED)
     (case (string->symbol status)
       ((PASS)        (list "70  249 73" status))
       ((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
       ((WARN WAIVED) (list "255 172 13" status))
       ((SKIP)        (list (gutils:get-color-spec 'SKIP) status))
       ((ABORT)       (list "198 36 166" status))
       (else (list "253 33 49" status))))
    ((ARCHIVED)
     (case (string->symbol status)
       ((PASS)        (list "70  170 73" status))
       ((WARN WAIVED) (list "200 130 13" status))
       ((SKIP)        (list (gutils:get-color-spec 'SKIP) status))
       (else (list "180 33 49" status))))
    ;;      (if (equal? status "PASS")
    ;;	  '("70 249 73" "PASS")
    ;;	  (if (or (equal? status "WARN")
    ;;		  (equal? status "WAIVED"))
    ;;	      (list "255 172 13" status)
    ;;	      (list "223 33 49"  status)))) ;; greenish orangeish redish
    ((LAUNCHED)         (list "101 123 142"  state))
    ((CHECK)            (list "255 100 50"   state))
    ((REMOTEHOSTSTART)  (list "50 130 195"   state))
    ((RUNNING STARTED)          (list "9 131 232"    state))
    ((KILLREQ)          (list "39 82 206"    state))
    ((KILLED)           (list "234 101 17"   state))
    ((NOT_STARTED)      (case (string->symbol status)
			  ((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
			  (else   (list "240 240 240"                 state))))
    ;; for xor mode below
    ;;
    ((CLEAN)
     (case (string->symbol status)
       ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT)  (list "200 130 13" status)) ;; orange requested for these
       (else  (list "60  235 63" status))))
    ((DIRTY-BETTER)     (list "160  255 153" status))
    ((DIRTY-WORSE)      (list "165 42  42" status))
    ((BOTH-BAD)         (list "180 33 49" status))

    (else               (list
			 ;; "192 192 192"
			 "222 222 221"
			 state))))

;; end of stuff from gutils

)

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================

(declare (unit gutils))

(module gutils

	(iuplistbox-fill-list
	 message-window
	 gutils:colors-similar?
	 gutils:colors
	 gutils:get-color-for-state-status
	 )
	 
(import (prefix iup iup:)
	canvas-draw)

(import scheme
	 chicken.base
	 chicken.condition
	 chicken.string

;; 
;;     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 tree))
;; (declare (uses mtargs))
;; (declare (uses mtver))
;; (declare (uses launchmod))
;; ;; (declare (uses megatest-version))
;; ;; (declare (uses gutils))
;; (declare (uses dbmod))
;; (declare (uses servermod))
;; ;; (declare (uses synchash))
;; (declare (uses dcommon))

(module tree
	*
	
(import scheme
	chicken.base
	chicken.string
	chicken.file.posix
	)

(import format
	srfi-13
	(prefix iup iup:)
	canvas-draw
	sqlite3
	srfi-1
	regex regex-case srfi-69
	(prefix sqlite3 sqlite3:))

;; (import mtver
;; 	launchmod
;; 	dbmod
;; 	servermod
;; 	gutils
;; 	)

;; (include "megatest-version.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")

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