Megatest

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

(dbfile:db-init-proc db:initialize-main-db)

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

              " license GPL, Copyright (C) Matt Welland 2012-2017

Usage: dashboard [options]
  -h                    : this help
  -test run-id,test-id  : control test identified by testid
  -skip-version-check   : skip the version check
  -use-db-cache         : access database via cache 

Misc
  -rows R         : set number of rows
  -cols C         : set number of columns
"
))

;;   -server host:port     : connect to host:port instead of db access
;;   -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
;;   -guimonitor           : control panel for runs

;; process args
(define remargs (args:get-args 

			"-repl"
                        "-rh5.11" ;; fix to allow running on rh5.11
			"-:p"     ;; ignore the built in chicken profiling switch
			)
		 args:arg-hash
		 0))

;; ################### Top level code ###################

;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin

      (for-each (lambda (var)
		  ;; (display " ")(display var)
		  (if (get-environment-variable var)
		      (begin
			(print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))

    )
)

(if (not (null? remargs))
    (begin
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)))

(if (args:get-arg "-h")

          (change-directory fullpath))
	(begin
	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
 	  (exit 1))))

;; TODO: Move this inside (main)
;;
(print "launch:setup")
(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
	(configf:lookup *configdat* "dashboard" "no-detachbox")
        (not (file-exists? "/etc/os-release")))
    (set! iup:detachbox iup:vbox))

(if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
      (debug:print 0 *default-log-port* "It will be slower." (common:get-homehost))
      ))

;; ########################### end top level code ##############################

    
;; RA => Might require revert for filters 
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")

                              "%"))
	       (testpatt  (or (dboard:tabdat-test-patts tabdat) "%"))
	       (filtrstr  (conc targpatt "/" runpatt "/" testpatt)))
	  ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt)

	  (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
	      (let ((dwg (dboard:tabdat-drawing tabdat)))
		(print "resetting drawing")
		(dboard:tabdat-layout-update-ok-set! tabdat #f)
		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)

   "dashboard:runs-tab-updater"))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
  (print "Starting dashboard main")
  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; 
    (if (and (common:file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
	(if (not (args:get-arg "-skip-version-check"))
            (common:exit-on-version-changed)))
    (let* ((commondat       (dboard:commondat-make)))
      ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...

			     (begin
			     (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (dboard:commondat-updating-set! commondat #f)
			     (mutex-unlock! (dboard:commondat-update-mutex commondat)))
				   ))
			     1))))
      (print "Starting updaters")
      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
        (print "Starting main loop")
	(thread-start! th2)
	(thread-join! th2)))))

;; ########################### top level code ########################

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if (args:get-arg "-repl")
    (repl)
    (main))