;;======================================================================
;; Copyright 2006-2016, 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 (uses debugprint))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses rmtmod))
(declare (uses tree))
(module dashboard
*
(import scheme
chicken.base
chicken.bitwise
chicken.condition
chicken.eval
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.irregex
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.random
chicken.repl
chicken.sort
chicken.string
chicken.tcp
chicken.time
chicken.time.posix
(prefix iup iup:)
canvas-draw
canvas-draw-iup
(prefix sqlite3 sqlite3:)
srfi-1
regex regex-case srfi-69
typed-records
sparse-vectors
format
srfi-4
srfi-14
srfi-18
)
(import (prefix mtargs args:)
;; gutils
debugprint
rmtmod
tree
)
(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
"))
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-cols"
"-run"
"-test"
"-xterm"
"-debug"
"-host"
"-transport"
"-start-dir"
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
"-use-db-cache"
"-skip-version-check"
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
(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"))
(print ". Done. All ok.")))
(if (not (null? remargs))
(begin
(print "Unrecognised arguments: " (string-intersperse remargs " "))
))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (args:get-arg "-start-dir")
(if (directory-exists? (args:get-arg "-start-dir"))
(let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
(setenv "PWD" fullpath)
(change-directory fullpath))
(begin
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
(define (get-debugcontrolf)
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (common:file-exists? debugcontrolf)
debugcontrolf
#f)))
(define (main)
(if (args:get-arg "-repl")
(repl)
(dashboard-main)))
)
(import dashboard)
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (get-debugcontrolf)))
(if debugcontrolf
(load debugcontrolf)))
(import srfi-18)
(thread-join!
(thread-start!
(make-thread main "main")))