Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -26,17 +26,16 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
-SRCFILES = common.scm launch.scm runconfig.scm \
- server.scm configf.scm keys.scm \
- process.scm runs.scm genexample.scm \
- tdb.scm mt.scm \
+SRCFILES = runconfig.scm \
+ server.scm keys.scm \
+ runs.scm \
+ mt.scm \
ezsteps.scm api.scm \
- subrun.scm archive.scm env.scm \
- diff-report.scm
+ subrun.scm archive.scm env.scm
# cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
@@ -43,11 +42,12 @@
tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
configfmod.scm processmod.scm servermod.scm megatestmod.scm \
stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \
pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \
subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \
- ezstepsmod.scm
+ ezstepsmod.scm mtbody.scm envmod.scm genexample.scm mutils.scm \
+ diff-report.scm tdb.scm vgmod.scm dcommon.scm dashboard-tests.scm
transport-mode.scm : transport-mode.scm.template
cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
@@ -56,10 +56,12 @@
mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm
# dbmod.import.o is just a hack here
+mofiles/mtbody.o : mofiles/launchmod.o readline-fix.scm mofiles/envmod.o mofiles/genexample.o mofiles/mutils.o mofiles/diff-report.o mofiles/tdb.o
+mofiles/dcommon.o : mofiles/vgmod.o
process.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o
@@ -66,10 +68,11 @@
mofiles/dbmod.o : mofiles/mtmod.o
# mofiles/mtmod.o : mofiles/tcp-transportmod.o
mofiles/megatestmod.o : mofiles/pkts.o mofiles/servermod.o mofiles/fsmod.o
# mofiles/mtmod.o : mofiles/testsmod.o
mofiles/subrunmod.o : mofiles/tasksmod.o
+mofiles/dcommon.o : mofiles/tasksmod.o
mofiles/launchmod.o : mofiles/subrunmod.o mofiles/runsmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/runsmod.o : mofiles/archivemod.o
mofiles/testsmod.o : mofiles/dbmod.o
@@ -77,11 +80,10 @@
mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o
mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o
mofiles/dbmod.o : mofiles/dbfile.o
mofiles/api.o : mofiles/apimod.o
mofiles/commonmod.o : mofiles/debugprint.o mofiles/stml2.o
-configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o
db.o : mofiles/dbmod.o mofiles/dbfile.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/tcp-transportmod.o : mofiles/portlogger.o
@@ -91,13 +93,12 @@
# 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
-GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
- dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
- vg.scm
+GUISRCF = dashboard-context-menu.scm \
+ dashboard-guimonitor.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
@@ -227,20 +228,20 @@
# make $(MOIMPFILES)
# touch mofiles-made
megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)
-common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm dcommon.scm ezsteps.scm index-tree.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tree.scm : common_records.scm megatest-version.scm
+common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm dcommon.scm ezsteps.scm index-tree.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
mofiles/dbfile.o : mofiles/commonmod.o
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
-vg.o dashboard.o : vg_records.scm megatest-version.scm
+dashboard.o : megatest-version.scm
dcommon.o : run_records.scm
mofiles/stml2.o : mofiles/cookie.o
@@ -448,68 +449,10 @@
tcmt ftail.import.scm readline-fix.scm serialize-env \
dboard dboard.o megatest.o dashboard.o \
megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
rm -rf share
-#======================================================================
-# Make the records files
-#======================================================================
-
-# vg_records.scm : records.sh
-# ./records.sh
-
-#======================================================================
-# Deploy section (not complete yet)
-#======================================================================
-
-$(DEPLOYHELPERS) : utils/mt_*
- $(INSTALL) $< $@
- chmod a+X $@
-
-deploytarg/apropos.so : Makefile
- chicken-install -p deploytarg -deploy -keep-installed $(EGGS)
-
-deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so
-
-# puts deployed megatest in directory "megatest"
-deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so
- csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
- mv deploytarg/deploytarg deploytarg/mtest
-
-deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
- csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
- mv deploytarg/deploytarg deploytarg/dboard
-
-datashare-testing/sd : datashare.scm $(OFILES)
- csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd
-
-datashare-testing/sdat: sharedat.scm $(OFILES)
- csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat
-
-sd : datashare-testing/sd
- mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath
-
-xterm : sd
- (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)
-
-datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish
-
-datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve
-
-
-datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize
-
-sauth-init:
- mkdir -p datashare-testing
- rm datashare-testing/sauthorize
- rm datashare-testing/sretrieve
- rm datashare-testing/spublish
-
-sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish
readline-fix.scm :
if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
echo "(define *use-new-readline* #f)" > readline-fix.scm; \
else \
@@ -530,14 +473,10 @@
fi
if csi -ne '(import postgresql)'&> /dev/null;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 gutils.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 server.o synchash.o tasks.o tdb.o tests.o tree.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 genexample.o gutils.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 server.o sync-hash.o tasks.o tdb.o tests.o tree.o
-
-# IMPORTSTUBS = $(*import.scm:%.scm=%)
unitdeps.dot : *mod.scm ./utils/plot-uses Makefile
./utils/plot-uses todot processmod.import,dbfile.import,dbmod.import,configfmod.import,mtmod.import,procesmod.import,commonmod.import,mtargs.import,mtargs,debugprint $$(ls *.scm|grep -v import) > unitdeps.dot
# ./utils/plot-uses todot commonmod,portlogger,stml2,debugprint,mtargs apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm mtmod.scm processmod.scm rmtmod.scm servermod.scm tcp-transportmod.scm > uses.dot ; dot uses.dot -Tpdf -o uses.pdf
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -40,90 +40,5 @@
matchable
s11n
typed-records)
-;; QUEUE METHOD
-
-(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
- (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))
-
-
-;; indat is (cmd run-id params meta)
-;;
-;; WARNING: Do not print anything in the lambda of this function as it
-;; reads/writes to current in/out port
-;;
-(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
- (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
- (if (not *server-signature*)
- (set! *server-signature* (tt:mk-signature *toppath*)))
- (lambda (indat)
- (api:register-thread (current-thread))
- (let* ((result
- (let* ((numthreads (api:get-count-threads-alive))
- (delay-wait (if (> numthreads 10)
- (- numthreads 10)
- 0))
- (normal-proc (lambda (cmd run-id params)
- (case cmd
- ((ping) *server-signature*)
- (else
- (api:dispatch-request dbstruct cmd run-id params))))))
- (set! *api-process-request-count* numthreads)
- (set! *db-last-access* (current-seconds))
-;; (if (not (eq? numthreads numthreads))
-;; (begin
-;; (api:remove-dead-or-terminated)
-;; (let ((threads-now (api:get-count-threads-alive)))
-;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
-;; (set! numthreads threads-now))))
- (match indat
- ((cmd run-id params meta)
- (let* ((start-t (current-milliseconds))
- (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
- (case cmd
- ((ping) #t) ;; we are fine
- (else
- (assert ok "FATAL: database file and run-id not aligned.")))))
- (ttdat *server-info*)
- (server-state (tt-state ttdat))
- (maxthreads 20) ;; make this a parameter?
- (status (cond
- ((and (> numthreads maxthreads)
- (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
- 'busy)
- ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
- (else 'ok)))
- (errmsg (case status
- ((busy) (conc "Server overloaded, "numthreads" threads in flight"))
- ((loaded) (conc "Server loaded, "numthreads" threads in flight"))
- (else #f)))
- (result (case status
- ((busy)
- (if (eq? cmd 'ping)
- (normal-proc cmd run-id params)
- ;; numthreads must be greater than 5 for busy
- (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
- )) ;; (- numthreads 29)) ;; call back in as many seconds
- ((loaded)
- (normal-proc cmd run-id params))
- (else
- (normal-proc cmd run-id params))))
- (meta (case cmd
- ((ping) `((sstate . ,server-state)))
- (else `((wait . ,delay-wait)))))
- (payload (list status errmsg result meta)))
- ;; (cmd run-id params meta)
- (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
- payload))
- (else
- (assert #f "FATAL: failed to deserialize indat "indat))))))
- ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; (serialize payload)
-
- (api:unregister-thread (current-thread))
- result)))
-
-(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new
-
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -25,11 +25,20 @@
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))
(module apimod
- *
+ (
+ *server-signature*
+ api:tcp-dispatch-request-make-handler-core
+ api:register-thread
+ api:unregister-thread
+ api:get-count-threads-alive
+ api:print-db-stats
+ api:queue-processor
+ api:dispatch-request
+ )
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -19,11 +19,11 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(declare (unit archive))
(declare (uses debugprint))
(declare (uses mtargs))
-(declare (uses common))
+;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69
Index: archivemod.scm
==================================================================
--- archivemod.scm
+++ archivemod.scm
@@ -37,11 +37,19 @@
(declare (uses dbfile))
(use srfi-69)
(module archivemod
- *
+ (
+ archive:get-archive-disks
+ archive:allocate-new-archive-block
+ archive:get-timestamp-dir
+ archive:megatest-db
+ archive:bup-get-data
+ archive:restore-db
+
+ )
(import scheme)
(cond-expand
(chicken-4
@@ -121,11 +129,11 @@
srfi-69
typed-records
z3
)
-(include "common_records.scm")
+;; (include "common_records.scm")
;; (include "db_records.scm")
;;======================================================================
;;
;;======================================================================
ADDED attic/codescanlib.scm
Index: attic/codescanlib.scm
==================================================================
--- /dev/null
+++ attic/codescanlib.scm
@@ -0,0 +1,144 @@
+;; Copyright 2006-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 .
+;;
+
+;; gotta compile with csc, doesn't work with csi -s for whatever reason
+
+(use srfi-69)
+(use matchable)
+(use utils)
+(use ports)
+(use extras)
+(use srfi-1)
+(use posix)
+(use srfi-12)
+
+;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
+(define (load-scm-file scm-file)
+ ;;(print "load "scm-file)
+ (handle-exceptions
+ exn
+ '()
+ (with-input-from-string
+ (conc "("
+ (with-input-from-file scm-file read-all)
+ ")" )
+ read)))
+
+;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
+;; -- be advised:
+;; * this may be fooled by macros, since this code does not take them into account.
+;; * this code does only checks for form (define ( ... ) )
+;; so it excludes from reckoning
+;; - generated functions, as in things like foo-set! from defstructs,
+;; - define-inline, (
+;; - define procname (lambda ..
+;; - etc...
+(define (get-toplevel-procs+file+args+body filename)
+ (let* ((scm-tree (load-scm-file filename))
+ (procs
+ (filter identity
+ (map
+ (match-lambda
+ [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
+ [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
+ [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
+ [('define (defname args ...) body ...) ;; match (define (procname ) )
+ (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
+ (list defname filename args body)
+ #f)]
+ [else #f] ) scm-tree))))
+ procs))
+
+
+;; given a sexp, return a flat list of atoms in that sexp
+(define (get-atoms-in-body body)
+ (cond
+ ((null? body) '())
+ ((atom? body) (list body))
+ (else
+ (apply append (map get-atoms-in-body body)))))
+
+;; given a file, return a list of procname, file, list of atoms in said procname
+(define (get-procs+file+atoms file)
+ (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
+ (res
+ (map
+ (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (args (caddr item))
+ (body (cadddr item))
+ (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
+ (list proc file atoms)))
+ toplevel-proc-items)))
+ res))
+
+;; uniquify a list of atoms
+(define (unique-atoms lst)
+ (let loop ((lst (flatten lst)) (res '()))
+ (if (null? lst)
+ (reverse res)
+ (let ((c (car lst)))
+ (loop (cdr lst) (if (member c res) res (cons c res)))))))
+
+;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
+;; returning alist mapping procname to procname that calls said procname
+(define (get-callers-alist all-procs+file+calls)
+ (let* ((all-procs (map car all-procs+file+calls))
+ (caller-ht (make-hash-table)))
+ ;; let's cross reference with a hash table
+ (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
+ (for-each (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (calls (caddr item)))
+ (for-each (lambda (callee)
+ (hash-table-set! caller-ht callee
+ (cons proc
+ (hash-table-ref caller-ht callee))))
+ calls)))
+ all-procs+file+calls)
+ (map (lambda (x)
+ (let ((k (car x))
+ (r (unique-atoms (cdr x))))
+ (cons k r)))
+ (hash-table->alist caller-ht))))
+
+;; create a handy cross-reference of callees to callers in the form of an alist.
+(define (get-xref all-scm-files)
+ (let* ((all-procs+file+atoms
+ (apply append (map get-procs+file+atoms all-scm-files)))
+ (all-procs (map car all-procs+file+atoms))
+ (all-procs+file+calls ; proc calls things in calls list
+ (map (lambda (item)
+ (let* ((proc (car item))
+ (file (cadr item))
+ (atoms (caddr item))
+ (calls
+ (filter identity
+ (map
+ (lambda (x)
+ (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
+ (member x all-procs))
+ x
+ #f))
+ atoms))))
+ (list proc file calls)))
+ all-procs+file+atoms))
+ (callers (get-callers-alist all-procs+file+calls)))
+ callers))
DELETED codescanlib.scm
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;; Copyright 2006-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 .
-;;
-
-;; gotta compile with csc, doesn't work with csi -s for whatever reason
-
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
-
-;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
-(define (load-scm-file scm-file)
- ;;(print "load "scm-file)
- (handle-exceptions
- exn
- '()
- (with-input-from-string
- (conc "("
- (with-input-from-file scm-file read-all)
- ")" )
- read)))
-
-;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
-;; -- be advised:
-;; * this may be fooled by macros, since this code does not take them into account.
-;; * this code does only checks for form (define ( ... ) )
-;; so it excludes from reckoning
-;; - generated functions, as in things like foo-set! from defstructs,
-;; - define-inline, (
-;; - define procname (lambda ..
-;; - etc...
-(define (get-toplevel-procs+file+args+body filename)
- (let* ((scm-tree (load-scm-file filename))
- (procs
- (filter identity
- (map
- (match-lambda
- [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
- [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
- [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
- [('define (defname args ...) body ...) ;; match (define (procname ) )
- (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
- (list defname filename args body)
- #f)]
- [else #f] ) scm-tree))))
- procs))
-
-
-;; given a sexp, return a flat list of atoms in that sexp
-(define (get-atoms-in-body body)
- (cond
- ((null? body) '())
- ((atom? body) (list body))
- (else
- (apply append (map get-atoms-in-body body)))))
-
-;; given a file, return a list of procname, file, list of atoms in said procname
-(define (get-procs+file+atoms file)
- (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
- (res
- (map
- (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (args (caddr item))
- (body (cadddr item))
- (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
- (list proc file atoms)))
- toplevel-proc-items)))
- res))
-
-;; uniquify a list of atoms
-(define (unique-atoms lst)
- (let loop ((lst (flatten lst)) (res '()))
- (if (null? lst)
- (reverse res)
- (let ((c (car lst)))
- (loop (cdr lst) (if (member c res) res (cons c res)))))))
-
-;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
-;; returning alist mapping procname to procname that calls said procname
-(define (get-callers-alist all-procs+file+calls)
- (let* ((all-procs (map car all-procs+file+calls))
- (caller-ht (make-hash-table)))
- ;; let's cross reference with a hash table
- (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
- (for-each (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (calls (caddr item)))
- (for-each (lambda (callee)
- (hash-table-set! caller-ht callee
- (cons proc
- (hash-table-ref caller-ht callee))))
- calls)))
- all-procs+file+calls)
- (map (lambda (x)
- (let ((k (car x))
- (r (unique-atoms (cdr x))))
- (cons k r)))
- (hash-table->alist caller-ht))))
-
-;; create a handy cross-reference of callees to callers in the form of an alist.
-(define (get-xref all-scm-files)
- (let* ((all-procs+file+atoms
- (apply append (map get-procs+file+atoms all-scm-files)))
- (all-procs (map car all-procs+file+atoms))
- (all-procs+file+calls ; proc calls things in calls list
- (map (lambda (item)
- (let* ((proc (car item))
- (file (cadr item))
- (atoms (caddr item))
- (calls
- (filter identity
- (map
- (lambda (x)
- (if (and ;; (not (equal? x proc)) ;; uncomment to prevent listing self
- (member x all-procs))
- x
- #f))
- atoms))))
- (list proc file calls)))
- all-procs+file+atoms))
- (callers (get-callers-alist all-procs+file+calls)))
- callers))
DELETED common.scm
Index: common.scm
==================================================================
--- common.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 common))
-(declare (uses commonmod))
-(declare (uses processmod))
-(declare (uses configfmod))
-(declare (uses rmtmod))
-(declare (uses debugprint))
-(declare (uses mtargs))
-
-
-(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
- format dot-locking csv-xml z3 udp ;; sql-de-lite
- hostinfo md5 message-digest typed-records directory-utils stack
- matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
- (prefix sqlite3 sqlite3:)
- pkts (prefix dbi dbi:)
- )
-(use posix-extras pathname-expand files)
-
-
-(import commonmod
- processmod
- debugprint
- configfmod
- rmtmod
- (prefix mtargs args:))
-
-(include "common_records.scm")
-
-
-
-
-
-;;======================================================================
-;; (define *common:telemetry-log-state* 'startup)
-;; (define *common:telemetry-log-socket* #f)
-;;
-;; (define (common:telemetry-log-open)
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
-;; (serverport (configf:lookup-number *configdat* "telemetry" "port"))
-;; (user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown")))
-;; (set! *common:telemetry-log-state*
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
-;; 'broken)
-;; (if (and serverhost serverport user host)
-;; (let* ((s (udp-open-socket)))
-;; ;;(udp-bind! s #f 0)
-;; (udp-connect! s serverhost serverport)
-;; (set! *common:telemetry-log-socket* s)
-;; 'open)
-;; 'not-needed))))))
-;;
-;; (define (common:telemetry-log event #!key (payload '()))
-;; (if (eq? *common:telemetry-log-state* 'startup)
-;; (common:telemetry-log-open))
-;;
-;; (if (eq? 'open *common:telemetry-log-state*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
-;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
-;; ;;(common:telemetry-log-close)
-;; (define *common:telemetry-log-state* 'broken-or-no-server)
-;; (set! *common:telemetry-log-socket* #f)
-;; )
-;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
-;; (let* ((user (or (get-environment-variable "USER") "unknown"))
-;; (host (or (get-environment-variable "HOST") "unknown"))
-;; (start (conc "[megatest "event"]"))
-;; (toppath (or *toppath* "/dev/null"))
-;; (payload-serialized
-;; (base64:base64-encode
-;; (z3:encode-buffer
-;; (with-output-to-string (lambda () (pp payload))))))
-;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
-;; toppath":"payload-serialized)))
-;; (udp-send *common:telemetry-log-socket* msg))))))
-;;
-;; (define (common:telemetry-log-close)
-;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (define *common:telemetry-log-state* 'closed-fail)
-;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
-;; )
-;; (begin
-;; (define *common:telemetry-log-state* 'closed)
-;; (udp-close-socket *common:telemetry-log-socket*)
-;; (set! *common:telemetry-log-socket* #f)))))
-
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -50,12 +50,253 @@
(import stml2
)
(module commonmod
- *
+ (
+ ;; globals
+ *already-seen-runconfig-info*
+ *common:badly-ended-states*
+ *common:dont-roll-up-states*
+ *common:ended-states*
+ *common:not-started-ok-statuses*
+ *common:running-states*
+ *common:std-states*
+ *common:std-statuses*
+ *common:well-ended-states*
+ *configdat*
+ *configinfo*
+ *configstatus*
+ *db-access-allowed*
+ *db-api-call-time*
+ *db-cache-path*
+ *db-keys*
+ *default-area-tag*
+ *env-vars-by-run-id*
+ *globalexitstatus*
+ *host-loads*
+ *keyvals*
+ *last-launch*
+ *launch-setup-mutex*
+ *logged-in-clients*
+ *my-client-signature*
+ *on-exit-procs*
+ *passnum*
+ *pkts-info*
+ *pre-reqs-met-cache*
+ *runconfigdat*
+ *runremote*
+ *server-id*
+ *server-info*
+ *target*
+ *task-db*
+ *test-meta-updated*
+ *testconfigs*
+ *time-to-exit*
+ *toppath*
+ *toptest-paths*
+ *transport-type*
+ *common:this-exe-dir*
+
+ common:list-is-sublist
+ seconds->year-week/day-time
+ common:find-start-mark-and-mark-delta
+
+ common:with-orig-env
+ alist->env-vars
+ any->number
+ any->number-if-possible
+ assoc/default
+ client:get-signature
+
+ common:alist-ref/default
+ common:clear-caches
+ common:dir-clean-up
+ common:directory-exists?
+ common:directory-writable?
+ common:fail-safe
+ common:file-exists?
+ common:find-local-megatest
+ common:generic-ssh
+ common:get-area-path-signature
+ common:get-color-from-status
+ common:get-cpu-load
+ common:get-create-writeable-dir
+ common:get-fields
+ common:get-intercept
+ common:get-megatest-exe
+ common:get-megatest-exe-dir
+ common:get-megatest-exe-path
+ common:get-mtexe
+ common:get-normalized-cpu-load
+ common:get-normalized-cpu-load
+ common:get-num-cpus
+ common:get-param-mapping
+ common:get-signature
+ common:get-toppath
+ common:hms-string->seconds
+ common:htree->html
+ common:human-time
+ common:in-running-test?
+ common:join-backgrounded-threads
+ common:lazy-sqlite-db-modification-time
+ common:list->htree
+ common:list-or-null
+ common:logpro-exit-code->status-sym
+ common:low-noise-print
+ common:make-tmpdir-name
+ common:max
+ common:min-max
+ common:nice-path
+ common:pkts-spec
+ common:raw-get-remote-host-load
+ common:read-encoded-string
+ common:real-path
+ common:send-thunk-to-background-thread
+ common:simple-file-lock
+ common:simple-file-lock-and-wait
+ common:simple-file-release-lock
+ common:sparse-list-generate-index
+ common:special-sort
+ common:steps-can-proceed-given-status-sym
+ common:sum
+ common:to-alist
+ common:unix-ping
+ common:val->alist
+ common:version-signature
+ common:which
+ common:with-env-vars
+ common:without-vars
+ common:worse-status-sym
+ commonmod:get-cpu-load
+ commonmod:is-test-alive
+ db:mintest-get-event_time
+ db:patt->like
+
+ db:test-data-get-category
+ db:test-data-get-comment
+ db:test-data-get-expected
+ db:test-data-get-id
+ db:test-data-get-last_update
+ db:test-data-get-status
+ db:test-data-get-test_id
+ db:test-data-get-tol
+ db:test-data-get-type
+ db:test-data-get-units
+ db:test-data-get-value
+ db:test-data-get-variable
+ db:test-get-archived
+ db:test-get-comment
+ db:test-get-cpuload
+ db:test-get-diskfree
+ db:test-get-event_time
+ db:test-get-final_logf
+ db:test-get-fullname
+ db:test-get-host
+ db:test-get-id
+ db:test-get-is-toplevel
+ db:test-get-item-path
+ db:test-get-last_update
+ db:test-get-process_id
+ db:test-get-run_duration
+ db:test-get-run_id
+ db:test-get-rundir
+ db:test-get-state
+ db:test-get-status
+ db:test-get-testname
+ db:test-get-uname
+ db:test-make-full-name
+ db:test-set-state!
+ db:test-set-status!
+ db:test-set-testname!
+
+ db:testmeta-get-author
+ db:testmeta-get-description
+ db:testmeta-get-owner
+ db:testmeta-get-reviewed
+ db:testmeta-get-tags
+
+ get-area-path-signature
+ get-normalized-cpu-load
+ getenv
+ host-last-cpuload
+ host-last-cpuload-set!
+ host-last-update
+ host-last-update-set!
+ host-last-used
+ host-last-used-set!
+ host-reachable
+ host-reachable-set!
+ item-list->path
+ keys->keystr
+ keys->valslots
+ keys:config-get-fields
+ keys:target->keyval
+ keys:target-set-args
+ make-db:testmeta
+ make-host
+ make-sparse-array
+ make-tests:testqueue
+ megatest-fossil-hash
+ megatest-version
+ number-of-processes-running
+ patt-list-match
+ rmt:transport-mode
+ runs:get-std-run-fields
+ safe-setenv
+ save-environment-as-files
+ sdb:qry
+ seconds->hr-min-sec
+ seconds->quarter
+ seconds->time-string
+ seconds->work-week/day
+ seconds->work-week/day-time
+ seconds->year-work-week/day-time
+ setenv
+ sparse-array-ref
+ sparse-array-set!
+ status-sym->string
+ stop-the-train
+ tasks:wait-on-journal
+
+ tdb:step-get-comment
+ tdb:step-get-event_time
+ tdb:step-get-id
+ tdb:step-get-last_update
+ tdb:step-get-logfile
+ tdb:step-get-state
+ tdb:step-get-status
+ tdb:step-get-stepname
+ tdb:step-get-test_id
+ tdb:steps-table-get-end
+ tdb:steps-table-get-log-file
+ tdb:steps-table-get-runtime
+ tdb:steps-table-get-start
+ tdb:steps-table-get-status
+ tdb:steps-table-get-stepname
+
+ tests:glob-like-match
+ tests:lookup-itemmap
+ tests:match
+ tests:match->sqlqry
+
+ tests:testqueue-get-item_path
+ tests:testqueue-get-itemdat
+ tests:testqueue-get-items
+ tests:testqueue-get-priority
+ tests:testqueue-get-testconfig
+ tests:testqueue-get-testname
+ tests:testqueue-get-waitons
+ tests:testqueue-set-item_path!
+ tests:testqueue-set-itemdat!
+ tests:testqueue-set-items!
+ tests:testqueue-set-priority!
+
+ val->alist
+ )
+
(import scheme)
(cond-expand
(chicken-4
(import chicken
@@ -120,10 +361,12 @@
srfi-69
typed-records
system-information
debugprint
+ megatest-fossil-hash
+
)))
;;======================================================================
;; CONTENTS
;;
@@ -285,10 +528,11 @@
(caddr argv))
(else (car argv))))
(fullpath (realpath this-script)))
fullpath))
+;; get rid of these, no need to slow down start up
;;======================================================================
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
@@ -385,10 +629,11 @@
(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.
;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)
+
(define (safe-setenv key val)
(if (or (substring-index "!" key)
(substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
(substring-index "." key)) ;; periods are not allowed in environment variables
(debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
@@ -563,13 +808,10 @@
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
-(define (get-section cfgdat section)
- (hash-table-ref/default cfgdat section '()))
-
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
@@ -2736,8 +2978,228 @@
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
+;;======================================================================
+;; db_records.scm
+;;======================================================================
+
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+(define (make-db:test)(make-vector 20))
+(define (db:test-get-id vec) (vector-ref vec 0))
+(define (db:test-get-run_id vec) (vector-ref vec 1))
+(define (db:test-get-testname vec) (vector-ref vec 2))
+(define (db:test-get-state vec) (vector-ref vec 3))
+(define (db:test-get-status vec) (vector-ref vec 4))
+(define (db:test-get-event_time vec) (vector-ref vec 5))
+(define (db:test-get-host vec) (vector-ref vec 6))
+(define (db:test-get-cpuload vec) (vector-ref vec 7))
+(define (db:test-get-diskfree vec) (vector-ref vec 8))
+(define (db:test-get-uname vec) (vector-ref vec 9))
+;; (define (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
+(define (db:test-get-rundir vec) (vector-ref vec 10))
+(define (db:test-get-item-path vec) (vector-ref vec 11))
+(define (db:test-get-run_duration vec) (vector-ref vec 12))
+(define (db:test-get-final_logf vec) (vector-ref vec 13))
+(define (db:test-get-comment vec) (vector-ref vec 14))
+(define (db:test-get-process_id vec) (vector-ref vec 16))
+(define (db:test-get-archived vec) (vector-ref vec 17))
+(define (db:test-get-last_update vec) (vector-ref vec 18))
+
+;; (define (db:test-get-pass_count vec) (vector-ref vec 15))
+;; (define (db:test-get-fail_count vec) (vector-ref vec 16))
+(define (db:test-get-fullname vec)
+ (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
+
+;; replace runs:make-full-test-name with this routine
+(define (db:test-make-full-name testname itempath)
+ (if (equal? itempath "") testname (conc testname "/" itempath)))
+
+;; (define (db:test-get-first_err vec) (printable (vector-ref vec 15)))
+;; (define (db:test-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
+
+(define (db:test-set-cpuload! vec val)(vector-set! vec 7 val))
+(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
+(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
+(define (db:test-set-state! vec val)(vector-set! vec 3 val))
+(define (db:test-set-status! vec val)(vector-set! vec 4 val))
+(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
+(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
+
+;; Test record utility functions
+
+;; Is a test a toplevel?
+;;
+(define (db:test-get-is-toplevel vec)
+ (and (equal? (db:test-get-item-path vec) "") ;; test is not an item
+ (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
+
+;; make-vector-record "" db mintest id run_id testname state status event_time item_path
+;; RADT => purpose of mintest??
+;;
+(define (make-db:mintest)(make-vector 7))
+(define (db:mintest-get-id vec) (vector-ref vec 0))
+(define (db:mintest-get-run_id vec) (vector-ref vec 1))
+(define (db:mintest-get-testname vec) (vector-ref vec 2))
+(define (db:mintest-get-state vec) (vector-ref vec 3))
+(define (db:mintest-get-status vec) (vector-ref vec 4))
+(define (db:mintest-get-event_time vec) (vector-ref vec 5))
+(define (db:mintest-get-item_path vec) (vector-ref vec 6))
+
+;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
+(define (make-db:testmeta)(make-vector 10 ""))
+(define (db:testmeta-get-id vec) (vector-ref vec 0))
+(define (db:testmeta-get-testname vec) (vector-ref vec 1))
+(define (db:testmeta-get-author vec) (vector-ref vec 2))
+(define (db:testmeta-get-owner vec) (vector-ref vec 3))
+(define (db:testmeta-get-description vec) (vector-ref vec 4))
+(define (db:testmeta-get-reviewed vec) (vector-ref vec 5))
+(define (db:testmeta-get-iterated vec) (vector-ref vec 6))
+(define (db:testmeta-get-avg_runtime vec) (vector-ref vec 7))
+(define (db:testmeta-get-avg_disk vec) (vector-ref vec 8))
+(define (db:testmeta-get-tags vec) (vector-ref vec 9))
+(define (db:testmeta-set-id! vec val)(vector-set! vec 0 val))
+(define (db:testmeta-set-testname! vec val)(vector-set! vec 1 val))
+(define (db:testmeta-set-author! vec val)(vector-set! vec 2 val))
+(define (db:testmeta-set-owner! vec val)(vector-set! vec 3 val))
+(define (db:testmeta-set-description! vec val)(vector-set! vec 4 val))
+(define (db:testmeta-set-reviewed! vec val)(vector-set! vec 5 val))
+(define (db:testmeta-set-iterated! vec val)(vector-set! vec 6 val))
+(define (db:testmeta-set-avg_runtime! vec val)(vector-set! vec 7 val))
+(define (db:testmeta-set-avg_disk! vec val)(vector-set! vec 8 val))
+
+;;======================================================================
+;; S I M P L E R U N
+;;======================================================================
+
+;; (defstruct id "runname" "state" "status" "owner" "event_time"
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+(define (make-db:test-data)(make-vector 10))
+(define (db:test-data-get-id vec) (vector-ref vec 0))
+(define (db:test-data-get-test_id vec) (vector-ref vec 1))
+(define (db:test-data-get-category vec) (vector-ref vec 2))
+(define (db:test-data-get-variable vec) (vector-ref vec 3))
+(define (db:test-data-get-value vec) (vector-ref vec 4))
+(define (db:test-data-get-expected vec) (vector-ref vec 5))
+(define (db:test-data-get-tol vec) (vector-ref vec 6))
+(define (db:test-data-get-units vec) (vector-ref vec 7))
+(define (db:test-data-get-comment vec) (vector-ref vec 8))
+(define (db:test-data-get-status vec) (vector-ref vec 9))
+(define (db:test-data-get-type vec) (vector-ref vec 10))
+(define (db:test-data-get-last_update vec) (vector-ref vec 11))
+
+(define (db:test-data-set-id! vec val)(vector-set! vec 0 val))
+(define (db:test-data-set-test_id! vec val)(vector-set! vec 1 val))
+(define (db:test-data-set-category! vec val)(vector-set! vec 2 val))
+(define (db:test-data-set-variable! vec val)(vector-set! vec 3 val))
+(define (db:test-data-set-value! vec val)(vector-set! vec 4 val))
+(define (db:test-data-set-expected! vec val)(vector-set! vec 5 val))
+(define (db:test-data-set-tol! vec val)(vector-set! vec 6 val))
+(define (db:test-data-set-units! vec val)(vector-set! vec 7 val))
+(define (db:test-data-set-comment! vec val)(vector-set! vec 8 val))
+(define (db:test-data-set-status! vec val)(vector-set! vec 9 val))
+(define (db:test-data-set-type! vec val)(vector-set! vec 10 val))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+;; Run steps
+;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
+(define (make-db:step)(make-vector 9))
+(define (tdb:step-get-id vec) (vector-ref vec 0))
+(define (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define (tdb:step-get-state vec) (vector-ref vec 3))
+(define (tdb:step-get-status vec) (vector-ref vec 4))
+(define (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define (tdb:step-get-comment vec) (vector-ref vec 7))
+(define (tdb:step-get-last_update vec) (vector-ref vec 8))
+(define (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define (tdb:step-set-comment! vec val)(vector-set! vec 7 val))
+
+
+;; The steps table
+(define (make-db:steps-table)(make-vector 5))
+(define (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define (tdb:steps-table-get-log-file vec) (vector-ref vec 5))
+
+(define (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
+
+;; ;; The data structure for handing off requests via wire
+;; (define (make-cdb:packet)(make-vector 6))
+;; (define (cdb:packet-get-client-sig vec) (vector-ref vec 0))
+;; (define (cdb:packet-get-qtype vec) (vector-ref vec 1))
+;; (define (cdb:packet-get-immediate vec) (vector-ref vec 2))
+;; (define (cdb:packet-get-query-sig vec) (vector-ref vec 3))
+;; (define (cdb:packet-get-params vec) (vector-ref vec 4))
+;; (define (cdb:packet-get-qtime vec) (vector-ref vec 5))
+;; (define (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val))
+;; (define (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val))
+;; (define (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val))
+;; (define (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val))
+;; (define (cdb:packet-set-params! vec val)(vector-set! vec 4 val))
+;; (define (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val))
+
+;;======================================================================
+;; key_records
+;;======================================================================
+
+(define (keys->valslots keys) ;; => ?,?,? ....
+ (string-intersperse (map (lambda (x) "?") keys) ","))
+
+;; (define (keys->key/field keys . additional)
+;; (string-join (map (lambda (k)(conc k " TEXT"))
+;; (append keys additional)) ","))
+
+(define (item-list->path itemdat)
+ (if (list? itemdat)
+ (string-intersperse (map cadr itemdat) "/")
+ ""))
+
+
+;;======================================================================
+;; test_records
+;;======================================================================
+
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 7 #f))
+(define (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define (tests:testqueue-get-priority vec) (vector-ref vec 3))
+;; items: #f=no items, list=list of items remaining, proc=need to call to get items
+(define (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+(define (tests:testqueue-get-item_path vec) (vector-ref vec 6))
+
+(define (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
+(define (tests:testqueue-set-item_path! vec val)(vector-set! vec 6 val))
)
DELETED configf.scm
Index: configf.scm
==================================================================
--- configf.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2012, 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 .
-
-;;======================================================================
-
-;;======================================================================
-;; Config file handling
-;;======================================================================
-
-(use regex regex-case matchable) ;; directory-utils)
-(declare (unit configf))
-(declare (uses process))
-(declare (uses env))
-(declare (uses keys))
-(declare (uses debugprint))
-(declare (uses mtargs))
-(declare (uses mtargs.import))
-(declare (uses common))
-(declare (uses commonmod))
-(declare (uses commonmod.import))
-(declare (uses processmod))
-(declare (uses processmod.import))
-(declare (uses configfmod))
-(declare (uses configfmod.import))
-(declare (uses dbfile))
-(declare (uses dbfile.import))
-(declare (uses dbmod))
-(declare (uses dbmod.import))
-(declare (uses mtmod))
-(declare (uses mtmod.import))
-(declare (uses megatestmod))
-(declare (uses megatestmod.import))
-
-;; (include "configf-guts.scm")
-
-;; (define shell configfmod#shell)
-;; (print (runconfigs-get *configdat* "testing"))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -25,11 +25,37 @@
(declare (uses mtargs))
(use regex regex-case)
(module configfmod
-*
+ (
+ configf:map-all-hier-alist
+ configf:read-refdb
+ lookup
+ configf:lookup
+ get-section
+ configf:get-section
+ configf:lookup-number
+ read-config
+ runconfigs-get
+ configf:section-vars
+ configf:read-alist
+ configf:config->alist
+ configf:alist->config
+ configf:set-section-var
+
+ find-and-read-config
+ common:args-get-target
+ configf:eval-string-in-environment
+
+ read-config-set!
+ configf:read-file
+
+ configf:system
+ configf:config->ini
+ shell
+ )
(import scheme
chicken
extras
files
@@ -203,10 +229,12 @@
(if match ;; (and match (list? match)(> (length match) 1))
(cadr match)
#f))
))
#f))
+
+(define lookup configf:lookup)
;; use to have definitive setting:
;; [foo]
;; var yes
;;
@@ -234,10 +262,12 @@
'()
(map car sectdat))))
(define (configf:get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+(define get-section configf:get-section)
(define (configf:set-section-var cfgdat section var val)
(let ((sectdat (configf:get-section cfgdat section)))
(hash-table-set! cfgdat section
(configf:assoc-safe-add sectdat var val))))
@@ -507,13 +537,10 @@
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
-
-
-
(include "configf-guts.scm")
)
Index: cpumod.scm
==================================================================
--- cpumod.scm
+++ cpumod.scm
@@ -29,11 +29,12 @@
(declare (uses mtargs))
(use srfi-69)
(module cpumod
- *
+ ()
+
(import scheme)
(cond-expand
(chicken-4
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -16,348 +16,38 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-;;======================================================================
-;; 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 common))
-(declare (uses commonmod))
-(declare (uses configfmod))
-(declare (uses gutils))
-(declare (uses rmtmod))
-(declare (uses ezsteps))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
-(declare (uses subrun))
-(declare (uses testsmod))
-(declare (uses subrunmod))
-(declare (uses megatestmod))
-
-(use format fmt)
-(require-library iup)
-(import (prefix iup iup:))
-
-(use canvas-draw)
-
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
-
-(include "common_records.scm")
-;; (include "db_records.scm")
-(include "run_records.scm")
-
-(import commonmod
- configfmod
- rmtmod
- testsmod
- subrunmod
- debugprint
- megatestmod
- )
-
-(define (dboard:launch-testpanel run-id test-id)
- (let* ((dboardexe (common:find-local-megatest "dashboard"))
- (cmd (conc dboardexe
- " -test " run-id "," test-id
- " &")))
- (system cmd)))
-
-
-(define (dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
- (list
- (iup:menu-item
- (conc "Rerun " testpatt)
- #:action
- (lambda (obj)
- ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
- (common:run-a-command
- (conc "megatest -run -target " target
- " -runname " runname
- " -testpatt " testpatt
- " -preclean -clean-cache")
- )))
- (iup:menu-item
- "Rerun Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt % "
- " -preclean -clean-cache"))))
- (iup:menu-item
- "Clean Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt % "))))
- (iup:menu-item
- "Kill Complete Run"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt % "
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
- (iup:menu-item
- "Delete Run Data"
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt % "
- " -keep-records"))))))
-
-(define (dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
- (list
- (iup:menu-item
- (conc "Rerun " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -preclean -clean-cache"))))
- (iup:menu-item
- (conc "Kill " item-test-path)
- #:action
- (lambda (obj)
- ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
- (iup:menu-item
- (conc "Delete data : " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -keep-records"))))
- (iup:menu-item
- (conc "Clean "item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -remove-runs -target " target
- " -runname " runname
- " -testpatt " item-test-path))))
- (iup:menu-item
- "Start xterm"
- #:action
- (lambda (obj)
- (dcommon:examine-xterm run-id test-id)))
- ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
- ;; (system cmd))))
- (iup:menu-item
- "Edit testconfig"
- #:action
- (lambda (obj)
- (let* ((all-tests (tests:get-all))
- (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex")
- "\\b(vim?|nano|pico)\\b"))
- (editor (or (configf:lookup *configdat* "setup" "editor")
- (get-environment-variable "VISUAL")
- (get-environment-variable "EDITOR") "vi"))
- (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
- (cmd (conc (if (string-search editor-rx editor)
- (conc "xterm -e " editor)
- editor)
- " " tconfig " &")))
- (system cmd))))))
-
-(define (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info)
- (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; #
- (rundir (db:test-get-rundir test-info)))
-
- (iup:menu-item
- "Step logs"
- (apply iup:menu
- (map (lambda (step)
- (let ((stepname (vector-ref step 0))
- (logfile (vector-ref step 5))
- (status (vector-ref step 3)))
- (iup:menu-item
- (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
- #:action (lambda (obj)
- (let ((fullfile (conc rundir "/" logfile)))
- (if (common:file-exists? fullfile)
- (dcommon:run-html-viewer fullfile)
- (message-window (conc "file " fullfile " not found"))))))))
- steps)))))
-
-(define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info)
- (list
-
- (iup:menu-item
- "Test Control Panel"
- #:action
- (lambda (obj)
- (dboard:launch-testpanel run-id test-id)))
-
- (dashboard:step-logs-menu-item run-id test-id target runname test-name testpatt item-test-path test-info)
-
- (iup:menu-item
- (conc "Rerun " item-test-path)
- #:action
- (lambda (obj)
- (common:run-a-command
- (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -preclean -clean-cache"))))
-
- (iup:menu-item
- "Start xterm"
- #:action
- (lambda (obj)
- (dcommon:examine-xterm run-id test-id)))
-
- (iup:menu-item
- (conc "Kill " item-test-path)
- #:action
- (lambda (obj)
- ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
- (common:run-a-command
- (conc "megatest -set-state-status KILLREQ,n/a -target " target
- " -runname " runname
- " -testpatt " item-test-path
- " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
-
- (let* ((rundir (db:test-get-rundir test-info))
- (has-subrun (subrun:subrun-test-initialized? rundir)))
- (if has-subrun
- (iup:menu-item
- "Launch subrun dashboard"
- #:action
- (lambda (obj)
- (subrun:launch-dashboard rundir)))
- (iup:vbox)))
-
- (iup:menu-item
- (conc "View Log " item-test-path)
- #:action
- (lambda (obj)
- (let* ((rundir (db:test-get-rundir test-info))
- (logf (db:test-get-final_logf test-info))
- (fullfile (conc rundir "/" logf)))
- (if (common:file-exists? fullfile)
- (dcommon:run-html-viewer fullfile)
- (message-window (conc "file " fullfile " not found.")))))
- )
- ))
-;; example section for megatest.config:
-;;
-;;
-;; [custom-context-menu-items]
-;; #