Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,40 +28,45 @@
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES =
+MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm
+MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
+MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
+DMSRCFILES = dcommonmod.scm
+DMOFILES = $(addprefix mofiles/,$(DMSRCFILES:%.scm=%.o))
+DMOIMPFILES = $(DMSRCFILES:%.scm=%.import.o)
+
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
-MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
-# compiled import files
-MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
-%.import.o : %.import.scm
+%.import.o : %.import.scm mofiles/%.o
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary...
# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm
# @[ -e mofiles ] || mkdir -p mofiles
# csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o
# cp $*.o mofiles/$*.o
-# @touch $*.import.scm # ensure it is touched after the .o is made
-mofiles/%.o : %.scm
- mkdir -p mofiles
+
+# ensure import.scm is touched after the .o is made
+#
+mofiles/%.o %.import.scm : %.scm
csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+ @touch $*.import.scm
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
@@ -87,12 +92,12 @@
csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
- csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) megatest-version.scm megatest-fossil-hash.scm
+ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) $(DMOFILES) $(DMOIMPFILES) -o dboard
mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm
csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
# include makefile.inc
@@ -127,11 +132,11 @@
ezsteps.o
# mofiles/rmtmod.o \
# mofiles/commonmod.o \
-tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm
+tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOIMPFILES) $(MOFILES)
csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
@@ -147,15 +152,17 @@
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
-# Special dependencies for the includes
+# Special dependencies for the module includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
-
-# common.o : mofiles/commonmod.o megatest-fossil-hash.scm
-
+megatest.o : $(MOIMPFILES)
+mofiles/commonmod.o : megatest-fossil-hash.scm
+mofiles/dbmod.o mofiles/servermod.o mofiles/apimod.o mofiles/dcommonmod.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
+common.o : mofiles/commonmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
tests.o db.o launch.o runs.o dashboard-tests.o \
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
@@ -165,10 +172,11 @@
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
+api.o rmt.o : mofiles/apimod.o
megatest.o : megatest-fossil-hash.scm megatest-version.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
@@ -177,11 +185,11 @@
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
vg.o dashboard.o : vg_records.scm megatest-version.scm
-dcommon.o : run_records.scm
+dcommon.o : mofiles/dcommonmod.o run_records.scm
mofiles/stml2.o : mofiles/cookie.o
# # special include based modules
# mofiles/pkts.o : pkts/pkts.scm
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -25,119 +25,15 @@
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses tasks))
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
- '(get-key-val-pairs
- get-var
- get-keys
- get-key-vals
- test-toplevel-num-items
- get-test-info-by-id
- get-steps-info-by-id
- get-data-info-by-id
- test-get-rundir-from-test-id
- get-count-tests-running-for-testname
- get-count-tests-running
- get-count-tests-running-in-jobgroup
- get-previous-test-run-record
- get-matching-previous-test-run-records
- test-get-logfile-info
- test-get-records-for-index-file
- get-testinfo-state-status
- test-get-top-process-pid
- test-get-paths-matching-keynames-target-new
- get-prereqs-not-met
- get-count-tests-running-for-run-id
- get-run-info
- get-run-status
- get-run-state
- get-run-stats
- get-run-times
- get-targets
- get-target
- ;; register-run
- get-tests-tags
- get-test-times
- get-tests-for-run
- get-tests-for-run-state-status
- get-test-id
- get-tests-for-runs-mindata
- get-tests-for-run-mindata
- get-run-name-from-id
- get-runs
- simple-get-runs
- get-num-runs
- get-runs-cnt-by-patt
- get-all-run-ids
- get-prev-run-ids
- get-run-ids-matching-target
- get-runs-by-patt
- get-steps-data
- get-steps-for-test
- read-test-data
- read-test-data*
- login
- tasks-get-last
- testmeta-get-record
- have-incompletes?
- ;; synchash-get
- get-changed-record-ids
- get-run-record-ids
- get-not-completed-cnt))
-
-(define api:write-queries
- '(
- get-keys-write ;; dummy "write" query to force server start
-
- ;; SERVERS
- start-server
- kill-server
-
- ;; TESTS
- test-set-state-status-by-id
- delete-test-records
- delete-old-deleted-test-records
- test-set-state-status
- test-set-top-process-pid
- set-state-status-and-roll-up-items
-
- update-pass-fail-counts
- top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
- ;; RUNS
- register-run
- set-tests-state-status
- delete-run
- lock/unlock-run
- update-run-event_time
- mark-incomplete
- set-state-status-and-roll-up-run
- ;; STEPS
- teststep-set-status!
- delete-steps-for-test
- ;; TEST DATA
- test-data-rollup
- csv->test-data
-
- ;; MISC
- sync-inmem->db
- drop-all-triggers
- create-all-triggers
- update-tesdata-on-repilcate-db
-
- ;; TESTMETA
- testmeta-add-record
- testmeta-update-field
-
- ;; TASKS
- tasks-add
- tasks-set-state-given-param-key
- ))
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses apimod))
+(import apimod)
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -18,20 +18,125 @@
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
-(declare (uses ulex))
+;; (declare (uses ulex))
(module apimod
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
-(import (prefix ulex ulex:))
+
+;; allow these queries through without starting a server
+;;
+(define api:read-only-queries
+ '(get-key-val-pairs
+ get-var
+ get-keys
+ get-key-vals
+ test-toplevel-num-items
+ get-test-info-by-id
+ get-steps-info-by-id
+ get-data-info-by-id
+ test-get-rundir-from-test-id
+ get-count-tests-running-for-testname
+ get-count-tests-running
+ get-count-tests-running-in-jobgroup
+ get-previous-test-run-record
+ get-matching-previous-test-run-records
+ test-get-logfile-info
+ test-get-records-for-index-file
+ get-testinfo-state-status
+ test-get-top-process-pid
+ test-get-paths-matching-keynames-target-new
+ get-prereqs-not-met
+ get-count-tests-running-for-run-id
+ get-run-info
+ get-run-status
+ get-run-state
+ get-run-stats
+ get-run-times
+ get-targets
+ get-target
+ ;; register-run
+ get-tests-tags
+ get-test-times
+ get-tests-for-run
+ get-tests-for-run-state-status
+ get-test-id
+ get-tests-for-runs-mindata
+ get-tests-for-run-mindata
+ get-run-name-from-id
+ get-runs
+ simple-get-runs
+ get-num-runs
+ get-runs-cnt-by-patt
+ get-all-run-ids
+ get-prev-run-ids
+ get-run-ids-matching-target
+ get-runs-by-patt
+ get-steps-data
+ get-steps-for-test
+ read-test-data
+ read-test-data*
+ login
+ tasks-get-last
+ testmeta-get-record
+ have-incompletes?
+ ;; synchash-get
+ get-changed-record-ids
+ get-run-record-ids
+ get-not-completed-cnt))
+
+(define api:write-queries
+ '(
+ get-keys-write ;; dummy "write" query to force server start
+
+ ;; SERVERS
+ start-server
+ kill-server
+
+ ;; TESTS
+ test-set-state-status-by-id
+ delete-test-records
+ delete-old-deleted-test-records
+ test-set-state-status
+ test-set-top-process-pid
+ set-state-status-and-roll-up-items
+
+ update-pass-fail-counts
+ top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
+
+ ;; RUNS
+ register-run
+ set-tests-state-status
+ delete-run
+ lock/unlock-run
+ update-run-event_time
+ mark-incomplete
+ set-state-status-and-roll-up-run
+ ;; STEPS
+ teststep-set-status!
+ delete-steps-for-test
+ ;; TEST DATA
+ test-data-rollup
+ csv->test-data
+
+ ;; MISC
+ sync-inmem->db
+ drop-all-triggers
+ create-all-triggers
+ update-tesdata-on-repilcate-db
+ ;; TESTMETA
+ testmeta-add-record
+ testmeta-update-field
-(define (api:execute-requests params)
- #f)
+ ;; TASKS
+ tasks-add
+ tasks-set-state-given-param-key
+ ))
)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -21,10 +21,13 @@
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -27,10 +27,13 @@
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
;; client:get-signature
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -26,12 +26,12 @@
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
-;; (declare (uses commonmod))
-;; (import commonmod)
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
;; (require-library margs)
@@ -42,10 +42,19 @@
;; (define (exit . code)
;; (if (null? code)
;; (old-exit)
;; (old-exit code)))
+(define (common:debug-setup)
+ (debug:setup (cond ;; debug arg
+ ((args:get-arg "-debug-noprop") 'noprop)
+ ((args:get-arg "-debug") #t)
+ (else #f))
+ (cond ;; verbosity arg
+ ((args:get-arg "-q") 'v)
+ ((args:get-arg "-q") 'q)
+ (else #f))))
;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
(handle-exceptions
@@ -803,10 +812,16 @@
(8 "DEAD")
(9 "FAIL")
(10 "PREQ_FAIL")
(11 "PREQ_DISCARDED")
(12 "ABORT")))
+
+(define (common:status>? s1 s2)
+ (let* ((munged (map (lambda (x) `(,(cadr x) . ,(car x))) *common:std-statuses*))
+ (v1 (alist-ref s1 munged equal?))
+ (v2 (alist-ref s2 munged equal?)))
+ (> v1 v2)))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" ))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -77,177 +77,176 @@
(mutex-lock! mtx)
(let ((res (apply accessor record val)))
(mutex-unlock! mtx)
res))
-;; this was cached based on results from profiling but it turned out the profiling
-;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
-;; in for now but can probably take it out later.
-;;
-(define (debug:calc-verbosity vstr)
- (or (hash-table-ref/default *verbosity-cache* vstr #f)
- (let ((res (cond
- ((number? vstr) vstr)
- ((not (string? vstr)) 1)
- ;; ((string-match "^\\s*$" vstr) 1)
- (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
- (cond
- ((> (length debugvals) 1) debugvals)
- ((> (length debugvals) 0)(car debugvals))
- (else 1))))
- ((args:get-arg "-v") 2)
- ((args:get-arg "-q") 0)
- (else 1))))
- (hash-table-set! *verbosity-cache* vstr res)
- res)))
-
-;; check verbosity, #t is ok
-(define (debug:check-verbosity verbosity vstr)
- (if (not (or (number? verbosity)
- (list? verbosity)))
- (begin
- (print "ERROR: Invalid debug value \"" vstr "\"")
- #f)
- #t))
-
-(define (debug:debug-mode n)
- (cond
- ((and (number? *verbosity*) ;; number number
- (number? n))
- (<= n *verbosity*))
- ((and (list? *verbosity*) ;; list number
- (number? n))
- (member n *verbosity*))
- ((and (list? *verbosity*) ;; list list
- (list? n))
- (not (null? (lset-intersection! eq? *verbosity* n))))
- ((and (number? *verbosity*)
- (list? n))
- (member *verbosity* n))))
-
-(define (debug:setup)
- (let ((debugstr (or (args:get-arg "-debug")
- (args:get-arg "-debug-noprop")
- (getenv "MT_DEBUG_MODE"))))
- (set! *verbosity* (debug:calc-verbosity debugstr))
- (debug:check-verbosity *verbosity* debugstr)
- ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
- (if (not *verbosity*)(set! *verbosity* 1))
- (if (and (not (args:get-arg "-debug-noprop"))
- (or (args:get-arg "-debug")
- (not (getenv "MT_DEBUG_MODE"))))
- (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
- (string-intersperse (map conc *verbosity*) ",")
- (conc *verbosity*))))))
-
-(define (debug:print n e . params)
- (if (debug:debug-mode n)
- (with-output-to-port (or e (current-error-port))
- (lambda ()
- (if *logging*
- (db:log-event (apply conc params))
- (apply print params)
- )))))
-
-;; Brandon's debug printer shortcut (indulge me :)
-(define *BB-process-starttime* (current-milliseconds))
-(define (BB> . in-args)
- (let* ((stack (get-call-chain))
- (location "??"))
- (for-each
- (lambda (frame)
- (let* ((this-loc (vector-ref frame 0))
- (temp (string-split (->string this-loc) " "))
- (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
- (if (equal? this-func "BB>")
- (set! location this-loc))))
- stack)
- (let* ((color-on "\x1b[1m")
- (color-off "\x1b[0m")
- (dp-args
- (append
- (list 0 *default-log-port*
- (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
- in-args)))
- (apply debug:print dp-args))))
-
-(define *BBpp_custom_expanders_list* (make-hash-table))
-
-
-
-;; register hash tables with BBpp.
-(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
- (cons hash-table? hash-table->alist))
-
-;; test name converter
-(define (BBpp_custom_converter arg)
- (let ((res #f))
- (for-each
- (lambda (custom-type-name)
- (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
- (custom-type-test (car custom-type-info))
- (custom-type-converter (cdr custom-type-info)))
- (when (and (not res) (custom-type-test arg))
- (set! res (custom-type-converter arg)))))
- (hash-table-keys *BBpp_custom_expanders_list*))
- (if res (BBpp_ res) arg)))
-
-(define (BBpp_ arg)
- (cond
- ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
- ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
- ((hash-table? arg)
- (let ((al (hash-table->alist arg)))
- (BBpp_ (cons HASH_TABLE: al))))
- ((null? arg) '())
- ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
- ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
- (else (BBpp_custom_converter arg))))
-
-;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
-(define (BBpp arg)
- (pp (BBpp_ arg)))
-
-;(use define-macro)
-(define-syntax inspect
- (syntax-rules ()
- [(_ x)
- ;; (with-output-to-port (current-error-port)
- (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
- ;; )
- ]
- [(_ x y ...) (begin (inspect x) (inspect y ...))]))
-
-(define (debug:print-error n e . params)
- ;; normal print
- (if (debug:debug-mode n)
- (with-output-to-port (if (port? e) e (current-error-port))
- (lambda ()
- (if *logging*
- (db:log-event (apply conc params))
- ;; (apply print "pid:" (current-process-id) " " params)
- (apply print "ERROR: " params)
- ))))
- ;; pass important messages to stderr
- (if (and (eq? n 0)(not (eq? e (current-error-port))))
- (with-output-to-port (current-error-port)
- (lambda ()
- (apply print "ERROR: " params)
- ))))
-
-(define (debug:print-info n e . params)
- (if (debug:debug-mode n)
- (with-output-to-port (if (port? e) e (current-error-port))
- (lambda ()
- (if *logging*
- (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
- (db:log-event res))
- ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
- (apply print "INFO: (" n ") " params) ;; res)
- )))))
-
-
+;; ;; this was cached based on results from profiling but it turned out the profiling
+;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; ;; in for now but can probably take it out later.
+;; ;;
+;; (define (debug:calc-verbosity vstr)
+;; (or (hash-table-ref/default *verbosity-cache* vstr #f)
+;; (let ((res (cond
+;; ((number? vstr) vstr)
+;; ((not (string? vstr)) 1)
+;; ;; ((string-match "^\\s*$" vstr) 1)
+;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+;; (cond
+;; ((> (length debugvals) 1) debugvals)
+;; ((> (length debugvals) 0)(car debugvals))
+;; (else 1))))
+;; ((args:get-arg "-v") 2)
+;; ((args:get-arg "-q") 0)
+;; (else 1))))
+;; (hash-table-set! *verbosity-cache* vstr res)
+;; res)))
+;;
+;; ;; check verbosity, #t is ok
+;; (define (debug:check-verbosity verbosity vstr)
+;; (if (not (or (number? verbosity)
+;; (list? verbosity)))
+;; (begin
+;; (print "ERROR: Invalid debug value \"" vstr "\"")
+;; #f)
+;; #t))
+;;
+;; (define (debug:debug-mode n)
+;; (cond
+;; ((and (number? *verbosity*) ;; number number
+;; (number? n))
+;; (<= n *verbosity*))
+;; ((and (list? *verbosity*) ;; list number
+;; (number? n))
+;; (member n *verbosity*))
+;; ((and (list? *verbosity*) ;; list list
+;; (list? n))
+;; (not (null? (lset-intersection! eq? *verbosity* n))))
+;; ((and (number? *verbosity*)
+;; (list? n))
+;; (member *verbosity* n))))
+;;
+;; (define (debug:setup)
+;; (let ((debugstr (or (args:get-arg "-debug")
+;; (args:get-arg "-debug-noprop")
+;; (getenv "MT_DEBUG_MODE"))))
+;; (set! *verbosity* (debug:calc-verbosity debugstr))
+;; (debug:check-verbosity *verbosity* debugstr)
+;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+;; (if (not *verbosity*)(set! *verbosity* 1))
+;; (if (and (not (args:get-arg "-debug-noprop"))
+;; (or (args:get-arg "-debug")
+;; (not (getenv "MT_DEBUG_MODE"))))
+;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
+;; (string-intersperse (map conc *verbosity*) ",")
+;; (conc *verbosity*))))))
+;;
+;; (define (debug:print n e . params)
+;; (if (debug:debug-mode n)
+;; (with-output-to-port (or e (current-error-port))
+;; (lambda ()
+;; (if *logging*
+;; (db:log-event (apply conc params))
+;; (apply print params)
+;; )))))
+;;
+;; ;; Brandon's debug printer shortcut (indulge me :)
+;; (define *BB-process-starttime* (current-milliseconds))
+;; (define (BB> . in-args)
+;; (let* ((stack (get-call-chain))
+;; (location "??"))
+;; (for-each
+;; (lambda (frame)
+;; (let* ((this-loc (vector-ref frame 0))
+;; (temp (string-split (->string this-loc) " "))
+;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
+;; (if (equal? this-func "BB>")
+;; (set! location this-loc))))
+;; stack)
+;; (let* ((color-on "\x1b[1m")
+;; (color-off "\x1b[0m")
+;; (dp-args
+;; (append
+;; (list 0 *default-log-port*
+;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
+;; in-args)))
+;; (apply debug:print dp-args))))
+;;
+;; (define *BBpp_custom_expanders_list* (make-hash-table))
+;;
+;;
+;;
+;; ;; register hash tables with BBpp.
+;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+;; (cons hash-table? hash-table->alist))
+;;
+;; ;; test name converter
+;; (define (BBpp_custom_converter arg)
+;; (let ((res #f))
+;; (for-each
+;; (lambda (custom-type-name)
+;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
+;; (custom-type-test (car custom-type-info))
+;; (custom-type-converter (cdr custom-type-info)))
+;; (when (and (not res) (custom-type-test arg))
+;; (set! res (custom-type-converter arg)))))
+;; (hash-table-keys *BBpp_custom_expanders_list*))
+;; (if res (BBpp_ res) arg)))
+;;
+;; (define (BBpp_ arg)
+;; (cond
+;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
+;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
+;; ((hash-table? arg)
+;; (let ((al (hash-table->alist arg)))
+;; (BBpp_ (cons HASH_TABLE: al))))
+;; ((null? arg) '())
+;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; (else (BBpp_custom_converter arg))))
+;;
+;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
+;; (define (BBpp arg)
+;; (pp (BBpp_ arg)))
+;;
+;; ;(use define-macro)
+;; (define-syntax inspect
+;; (syntax-rules ()
+;; [(_ x)
+;; ;; (with-output-to-port (current-error-port)
+;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
+;; ;; )
+;; ]
+;; [(_ x y ...) (begin (inspect x) (inspect y ...))]))
+;;
+;; (define (debug:print-error n e . params)
+;; ;; normal print
+;; (if (debug:debug-mode n)
+;; (with-output-to-port (if (port? e) e (current-error-port))
+;; (lambda ()
+;; (if *logging*
+;; (db:log-event (apply conc params))
+;; ;; (apply print "pid:" (current-process-id) " " params)
+;; (apply print "ERROR: " params)
+;; ))))
+;; ;; pass important messages to stderr
+;; (if (and (eq? n 0)(not (eq? e (current-error-port))))
+;; (with-output-to-port (current-error-port)
+;; (lambda ()
+;; (apply print "ERROR: " params)
+;; ))))
+;;
+;; (define (debug:print-info n e . params)
+;; (if (debug:debug-mode n)
+;; (with-output-to-port (if (port? e) e (current-error-port))
+;; (lambda ()
+;; (if *logging*
+;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
+;; (db:log-event res))
+;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
+;; (apply print "INFO: (" n ") " params) ;; res)
+;; )))))
+;;
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -21,14 +21,15 @@
(declare (unit commonmod))
(module commonmod
*
-(import scheme chicken data-structures extras files)
+(import scheme chicken data-structures extras files ports)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
md5 message-digest
- regex srfi-1)
+ regex srfi-1
+ format)
;;======================================================================
;; CONTENTS
;;
;; config file utils
@@ -149,14 +150,110 @@
(let ((adat (get-section cfgdat "areas")))
(map (lambda (entry)
`(,(car entry) .
,(val->alist (cadr entry))))
adat)))
+
+;;======================================================================
+;; debug stuff
+;;======================================================================
+
+(define verbosity (make-parameter '()))
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;;
;; (define (set-functions dbgp dbgpinfo)
;; (set! debug:print dbgp)
;; (set! debug:print-info dbgpinfo))
+
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
+ (let* ((res (cond
+ ((number? vstr) vstr)
+ ((not (string? vstr)) 1)
+ ;; ((string-match "^\\s*$" vstr) 1)
+ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+ (cond
+ ((> (length debugvals) 1) debugvals)
+ ((> (length debugvals) 0)(car debugvals))
+ (else 1))))
+ ((eq? arg 'v) 2) ;; verbose
+ ((eq? arg 'q) 0) ;; quiet
+ (else 1))))
+ (verbosity res)
+ res))
+
+;; check verbosity, #t is ok
+#;(define (debug-check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+(define (debug:debug-mode n)
+ (let* ((vb (verbosity)))
+ (cond
+ ((and (number? vb) ;; number number
+ (number? n))
+ (<= n vb))
+ ((and (list? vb) ;; list number
+ (number? n))
+ (member n vb))
+ ((and (list? vb) ;; list list
+ (list? n))
+ (not (null? (lset-intersection! eq? vb n))))
+ ((and (number? vb)
+ (list? n))
+ (member vb n)))))
+
+(define (debug:setup debug-arg verbose-arg) ;; debug-arg= #f, #t or 'noprop
+ (let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
+ ;; (args:get-arg "-debug-noprop")
+ (get-environment-variable "MT_DEBUG_MODE"))))
+ (debug:calc-verbosity debugstr verbose-arg)
+ ;; (debug:check-verbosity *verbosity* debugstr)
+ ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+ (if (not (verbosity))(set! (verbosity) 1))
+ (if (and (not (eq? debug-arg 'noprop))
+ (or debug-arg
+ (not (get-environment-variable "MT_DEBUG_MODE"))))
+ (setenv "MT_DEBUG_MODE" (if (list? (verbosity))
+ (string-intersperse (map conc (verbosity)) ",")
+ (conc (verbosity)))))))
+
+(define (debug:print n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ ;; (if *logging*
+ ;; (db:log-event (apply conc params))
+ (apply print params)
+ )))) ;; )
+
+(define (debug:print-error n e . params)
+ ;; normal print
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "ERROR: " params)
+ )))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: " params)
+ ))))
+
+(define (debug:print-info n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "INFO: (" n ") " params) ;; res)
+ ))))
)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -25,10 +25,13 @@
(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -39,10 +39,13 @@
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -34,10 +34,13 @@
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -38,10 +38,13 @@
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -46,16 +46,24 @@
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
+(declare (uses commonmod))
+(import commonmod)
+(declare (uses commonmod.import))
+
+(declare (uses dcommonmod))
+(import dcommonmod)
+(declare (uses dcommonmod.import))
+
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
-(include "megatest-fossil-hash.scm")
+;; (include "megatest-fossil-hash.scm")
(include "vg_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
@@ -167,33 +175,11 @@
;; (begin
;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
;;)
-;; data common to all tabs goes here
-;;
-(defstruct dboard:commondat
- ((curr-tab-num 0) : number)
- please-update
- tabdats
- update-mutex
- updaters
- updating
- uidat ;; needs to move to tabdat at some time
- hide-not-hide-tabs
- )
-
-(define (dboard:commondat-make)
- (make-dboard:commondat
- curr-tab-num: 0
- tabdats: (make-hash-table)
- please-update: #t
- update-mutex: (make-mutex)
- updaters: (make-hash-table)
- updating: #f
- hide-not-hide-tabs: #f
- ))
+;; data common to all tabs in dboard:commondat struct moved to dcommonmod
;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(let* ((tnum (or tab-num
@@ -237,133 +223,10 @@
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
-
-;; data for each specific tab goes here
-;;
-(defstruct dboard:tabdat
- ;; runs
- ((allruns '()) : list) ;; list of dboard:rundat records
- ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
- ((done-runs '()) : list) ;; list of runs already drawn
- ((not-done-runs '()) : list) ;; list of runs not yet drawn
- (header #f) ;; header for decoding the run records
- (keys #f) ;; keys for this run (i.e. target components)
- ((numruns (string->number (or (args:get-arg "-cols")
- (configf:lookup *configdat* "dashboard" "cols")
- "8"))) : number) ;;
- ((tot-runs 0) : number)
- ((last-data-update 0) : number) ;; last time the data in allruns was updated
- ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
- (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
- ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
- ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
- ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
-
- ;; Runs view
- ((buttondat (make-hash-table)) : hash-table) ;;
- ((item-test-names '()) : list) ;; list of itemized tests
- ((run-keys (make-hash-table)) : hash-table)
- (runs-matrix #f) ;; used in newdashboard
- ((start-run-offset 0) : number) ;; left-right slider value
- ((start-test-offset 0) : number) ;; up-down slider value
- ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
- ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
- ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
- ((all-test-names '()) : list)
-
- ;; Canvas and drawing data
- (cnv #f)
- (cnv-obj #f)
- (drawing #f)
- ((run-start-row 0) : number)
- ((max-row 0) : number)
- ((running-layout #f) : boolean)
- (originx #f)
- (originy #f)
- ((layout-update-ok #t) : boolean)
- ((compact-layout #t) : boolean)
-
- ;; Run times layout
- ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
- (graph-matrix #f)
- ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
- ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
- ((graph-matrix-row 1) : number)
- ((graph-matrix-col 1) : number)
-
- ;; Controls used to launch runs etc.
- ((command "") : string) ;; for run control this is the command being built up
- (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
- (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
- (key-listboxes #f)
- (key-lbs #f)
- run-name ;; from run name setting widget
- states ;; states for -state s1,s2 ...
- statuses ;; statuses for -status s1,s2 ...
-
- ;; Selector variables
- curr-run-id ;; current row to display in Run summary view
- prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
- curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
- ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
- ((hide-empty-runs #f) : boolean)
- ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
- (hide-not-hide-button #f)
- ((searchpatts (make-hash-table)) : hash-table) ;;
- ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
- ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
- (target #f)
- (test-patts #f)
-
- ;; db info to file the .db files for the area
- (access-mode (db:get-access-mode)) ;; use cached db or not
- (dbdir #f)
- (dbfpath #f)
- (dbkeys #f)
- ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
- (monitor-db-path #f) ;; where to find monitor.db
- ro ;; is the database read-only?
-
- ;; tests data
- ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
-
- ;; runs tree
- ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
- (runs-tree #f)
- ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
-
- ;; tab data
- ((view-changed #t) : boolean)
- ((xadj 0) : number) ;; x slider number (if using canvas)
- ((yadj 0) : number) ;; y slider number (if using canvas)
- ;; runs-summary tab state
- ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
- ((runs-summary-mode-buttons '()) : list)
- ((runs-summary-mode 'one-run) : symbol)
- ((runs-summary-mode-change-callbacks '()) : list)
- (runs-summary-source-runname-label #f)
- (runs-summary-dest-runname-label #f)
- ;; runs summary view
-
- tests-tree ;; used in newdashboard
- )
-
-;; register tabdat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
- (cons dboard:tabdat?
- (lambda (tabdat-item)
- (filter
- (lambda (alist-entry)
- (member (car alist-entry)
- '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
- (dboard:tabdat->alist tabdat-item)))))
-
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
@@ -375,10 +238,17 @@
(define (dboard:tabdat-test-patts-set!-use vec val)
(dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
+ (dboard:tabdat-runs-btn-height-set! dat (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) ;; was 12
+ (dboard:tabdat-runs-btn-fontsz-set! dat (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) ;; was 8
+ (dboard:tabdat-runs-cell-width-set! dat (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) ;; was 50
+ (dboard:tabdat-numruns-set! dat (string->number (or (args:get-arg "-cols")
+ (configf:lookup *configdat* "dashboard" "cols")
+ "8")))
+ (dboard:tabdat-access-mode-set! dat (db:get-access-mode)) ;; use cached db or not
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
@@ -392,51 +262,16 @@
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
-;; RADT => Matrix defstruct addition
-(defstruct dboard:graph-dat
- ((id #f) : string)
- ((color #f) : vector)
- ((flag #t) : boolean)
- ((cell #f) : number)
- )
-
-;; data for runs, tests etc. was used in run summary?
-;;
-(defstruct dboard:runsdat
- ;; new system
- runs-index ;; target/runname => colnum
- tests-index ;; testname/itempath => rownum
- matrix-dat ;; vector of vectors rows/cols
- )
-
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
tests-index: (make-hash-table)
matrix-dat: (make-sparse-array)))
-;; used to keep the rundata from rmt:get-tests-for-run
-;; in sync.
-;;
-(defstruct dboard:rundat
- run
- tests-drawn ;; list of id's already drawn on screen
- tests-notdrawn ;; list of id's NOT already drawn
- rowsused ;; hash of lists covering what areas used - replace with quadtree
- hierdat ;; put hierarchial sorted list here
- tests ;; hash of id => testdat
- ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
- key-vals
- ((last-update 0) : number) ;; last query to db got records from before last-update
- ((last-db-time 0) : number) ;; last timestamp on megatest.db
- ((data-changed #f) : boolean)
- ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
- (db-path #f))
-
;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:
;; sql query data ==> filters ==> data for display
;;
@@ -498,23 +333,10 @@
state
status
start-time
duration
)
-
-;; register dboard:rundat with BBpp
-;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
-(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
- (cons dboard:rundat?
- (lambda (tabdat-item)
- (filter
- (lambda (alist-entry)
- (member (car alist-entry)
- '(run run-data-offset ))) ;; FIELDS OF INTEREST
- (dboard:rundat->alist tabdat-item)))))
-
-
(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
(make-dboard:rundat
run: run
@@ -578,11 +400,11 @@
3)))
(define (get-curr-sort)
(vector-ref *tests-sort-options* *tests-sort-reverse*))
-(debug:setup)
+(common:debug-setup)
;; (define uidat #f)
(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -33,10 +33,13 @@
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
+
+(declare (uses commonmod))
+(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -27,10 +27,17 @@
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
+
+(declare (uses commonmod))
+(import commonmod)
+
+(declare (uses dcommonmod))
+(import dcommonmod)
+
;; (declare (uses synchash))
(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
ADDED dcommonmod.scm
Index: dcommonmod.scm
==================================================================
--- /dev/null
+++ dcommonmod.scm
@@ -0,0 +1,220 @@
+;;======================================================================
+;; Copyright 2017, 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 .
+
+;;======================================================================
+
+(declare (unit dcommonmod))
+(declare (uses commonmod))
+;; (declare (uses ulex))
+
+(module dcommonmod
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18
+ srfi-69)
+(import commonmod)
+;; (import (prefix ulex ulex:))
+
+;;======================================================================
+;; COMMONDAT
+;;======================================================================
+
+;; data common to all tabs goes here
+;;
+(defstruct dboard:commondat
+ ((curr-tab-num 0) : number)
+ please-update
+ tabdats
+ update-mutex
+ updaters
+ updating
+ uidat ;; needs to move to tabdat at some time
+ hide-not-hide-tabs
+ )
+
+(define (dboard:commondat-make)
+ (make-dboard:commondat
+ curr-tab-num: 0
+ tabdats: (make-hash-table)
+ please-update: #t
+ update-mutex: (make-mutex)
+ updaters: (make-hash-table)
+ updating: #f
+ hide-not-hide-tabs: #f
+ ))
+
+;;======================================================================
+;; TABDAT
+;;======================================================================
+
+;; data for each specific tab goes here
+;;
+(defstruct dboard:tabdat
+ ;; runs
+ ((allruns '()) : list) ;; list of dboard:rundat records
+ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
+ ((done-runs '()) : list) ;; list of runs already drawn
+ ((not-done-runs '()) : list) ;; list of runs not yet drawn
+ (header #f) ;; header for decoding the run records
+ (keys #f) ;; keys for this run (i.e. target components)
+ ((numruns 8) : number)
+ ((tot-runs 0) : number)
+ ((last-data-update 0) : number) ;; last time the data in allruns was updated
+ ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
+ (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
+ ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
+ ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
+ ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
+
+ ;; Runs view
+ ((buttondat (make-hash-table)) : hash-table) ;;
+ ((item-test-names '()) : list) ;; list of itemized tests
+ ((run-keys (make-hash-table)) : hash-table)
+ (runs-matrix #f) ;; used in newdashboard
+ ((start-run-offset 0) : number) ;; left-right slider value
+ ((start-test-offset 0) : number) ;; up-down slider value
+ ((runs-btn-height "x16") : string) ;; (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
+ ((runs-btn-fontsz "10") : string) ;; (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
+ ((runs-cell-width "50") : string) ;; (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
+ ((all-test-names '()) : list)
+
+ ;; Canvas and drawing data
+ (cnv #f)
+ (cnv-obj #f)
+ (drawing #f)
+ ((run-start-row 0) : number)
+ ((max-row 0) : number)
+ ((running-layout #f) : boolean)
+ (originx #f)
+ (originy #f)
+ ((layout-update-ok #t) : boolean)
+ ((compact-layout #t) : boolean)
+
+ ;; Run times layout
+ ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere
+ (graph-matrix #f)
+ ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info
+ ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info
+ ((graph-matrix-row 1) : number)
+ ((graph-matrix-col 1) : number)
+
+ ;; Controls used to launch runs etc.
+ ((command "") : string) ;; for run control this is the command being built up
+ (command-tb #f) ;; widget for the type of command; run, remove-runs etc.
+ (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns
+ (key-listboxes #f)
+ (key-lbs #f)
+ run-name ;; from run name setting widget
+ states ;; states for -state s1,s2 ...
+ statuses ;; statuses for -status s1,s2 ...
+
+ ;; Selector variables
+ curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
+ curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
+ ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab
+ ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
+ ((hide-empty-runs #f) : boolean)
+ ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
+ (hide-not-hide-button #f)
+ ((searchpatts (make-hash-table)) : hash-table) ;;
+ ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
+ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
+ (target #f)
+ (test-patts #f)
+
+ ;; db info to file the .db files for the area
+ (access-mode #f)
+ (dbdir #f)
+ (dbfpath #f)
+ (dbkeys #f)
+ ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
+ (monitor-db-path #f) ;; where to find monitor.db
+ ro ;; is the database read-only?
+
+ ;; tests data
+ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
+
+ ;; runs tree
+ ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
+ (runs-tree #f)
+ ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
+
+ ;; tab data
+ ((view-changed #t) : boolean)
+ ((xadj 0) : number) ;; x slider number (if using canvas)
+ ((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
+ tests-tree ;; used in newdashboard
+ )
+
+;;======================================================================
+;; GRAPHDAT
+;;======================================================================
+
+;; RADT => Matrix defstruct addition
+(defstruct dboard:graph-dat
+ ((id #f) : string)
+ ((color #f) : vector)
+ ((flag #t) : boolean)
+ ((cell #f) : number)
+ )
+
+;;======================================================================
+;; RUNSDAT
+;;======================================================================
+
+;; data for runs, tests etc. was used in run summary?
+;;
+(defstruct dboard:runsdat
+ ;; new system
+ runs-index ;; target/runname => colnum
+ tests-index ;; testname/itempath => rownum
+ matrix-dat ;; vector of vectors rows/cols
+ )
+
+;; used to keep the rundata from rmt:get-tests-for-run
+;; in sync.
+;;
+(defstruct dboard:rundat
+ run
+ tests-drawn ;; list of id's already drawn on screen
+ tests-notdrawn ;; list of id's NOT already drawn
+ rowsused ;; hash of lists covering what areas used - replace with quadtree
+ hierdat ;; put hierarchial sorted list here
+ tests ;; hash of id => testdat
+ ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
+ key-vals
+ ((last-update 0) : number) ;; last query to db got records from before last-update
+ ((last-db-time 0) : number) ;; last timestamp on megatest.db
+ ((data-changed #f) : boolean)
+ ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
+ (db-path #f))
+
+
+)
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -18,10 +18,13 @@
(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
+(declare (uses commonmod))
+(import commonmod)
+
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")
Index: docs/manual/Makefile
==================================================================
--- docs/manual/Makefile
+++ docs/manual/Makefile
@@ -34,13 +34,16 @@
megatest_manual.html : megatest_manual.txt *.txt installation.txt *png
asciidoc -b html5 -a icons -a iconsdir=$(DISPATH)/images/icons -a toc2 megatest_manual.txt
# dos2unix megatest_manual.html
-megatest_manual.pdf : megatest_manual.txt *.txt *png
+megatest_manual.pdf : megatest_manual.txt *.txt *png *.ps
a2x -a toc -f pdf megatest_manual.txt
+server.pdf : server.dot
+ dot -Tpdf server.dot > server.pdf
+
server.ps : server.dot
dot -Tps server.dot > server.ps
client.ps : client.dot
dot -Tps client.dot > client.ps
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual