;;======================================================================
;; 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 common))
;; (declare (uses megatest-version))
(declare (uses mtargs))
(declare (uses treemod))
(use srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors)
(use format
(prefix iup iup:)
canvas-draw)
(import canvas-draw-iup)
;; (debug:setup)
(module ndboard
*
(import scheme
chicken
data-structures
format
(prefix iup iup:)
canvas-draw
canvas-draw-iup
srfi-1 posix regex regex-case
srfi-69 typed-records sparse-vectors ;; defstruct
treemod
(prefix mtargs args:)
)
(include "megatest-version.scm")
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
;; (declare (uses dcommon))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2011
Usage: dashboard [options]
-h : this help
-server host:port : connect to host:port instead of db access
-test testid : control test identified by testid
-guimonitor : control panel for runs
Misc
-rows N : set number of rows
"))
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
)
(list "-h"
"-guimonitor"
"-main"
"-v"
"-q"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.newdashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; areas
;;
(define (get-areas-file)
(conc (get-environment-variable "HOME")"/.ndboard/areas.scm"))
(define (get-areas)
(let* ((areas-file (get-areas-file)))
(if (file-exists? areas-file)
(with-input-from-file areas-file read))))
;; gui utils
;;
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
(define (iuplistbox-fill-list lb items . default)
(let ((i 1)
(selected-item (if (null? default) #f (car default))))
(iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
(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" item))) ;; (number->string i))))
(set! i (+ i 1)))
items)
i))
;; simple widget registration and finding
(define *widgets* (make-hash-table))
(define (add-widget name wgt)
(hash-table-set! *widgets* name wgt)
wgt)
(define (get-widget name)
(hash-table-ref/default *widgets* name #f))
(define (pad-list l n)(append l (make-list (- n (length l)))))
;; the main tree, everything starts from here
;;
(define (main-tree)
(iup:treebox
#:value 0
#:title "Areas"
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(print "do nothing..."))))
(define (runs window-id)
(iup:hbox
(add-widget "main-tree" (main-tree))
;;
))
(define (runs-init)
(let* ((areas (get-areas))
(tb (get-widget "main-tree")))
(for-each
(lambda (areadat)
(tree:add-node tb "Areas" `(,(car areadat))))
areas)))
;; Browse and control a single run
;;
(define (runcontrol window-id)
(iup:hbox))
;; Main Panel
(define (main-panel window-id)
(iup:dialog
#:title "Megatest Control Panel"
;; #:menu (dcommon:main-menu)
#:shrink "YES"
(let ((tabtop (iup:tabs
(add-widget "runs" (runs window-id))
;; (tests window-id)
(runcontrol window-id)
;; (mtest *toppath* window-id)
;; (rconfig window-id)
)))
(iup:attribute-set! tabtop "TABTITLE0" "Runs")
;; (iup:attribute-set! tabtop "TABTITLE1" "Tests")
(iup:attribute-set! tabtop "TABTITLE1" "Run Control")
;; (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
;; (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
tabtop)))
(define *current-window-id* 0)
(define (newdashboard dbstruct)
(let* ((data (make-hash-table))
(keys '()) ;; (db:get-keys dbstruct))
(runname "%")
(testpatt "%")
(keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
(states '())
(statuses '())
(nextmintime (current-milliseconds))
(my-window-id *current-window-id*))
(set! *current-window-id* (+ 1 *current-window-id*))
;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
(iup:show (main-panel my-window-id))
(runs-init)
;; Yes, running iup:show will pop up a new panel
;; (iup:show (main-panel my-window-id))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
;; Want to dedicate no more than 50% of the time to this so skip if
;; 2x delta time has not passed since last query
#t
#;(if (< nextmintime (current-milliseconds))
(let* ((starttime (current-milliseconds))
;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
(endtime (current-milliseconds)))
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
)
(print "Server overloaded"))))))
)
;;======================================================================
;; D A S H B O A R D
;;======================================================================
(import ndboard)
(newdashboard #f)
(iup:main-loop)