Index: .fossil-settings/ignore-glob
==================================================================
--- .fossil-settings/ignore-glob
+++ .fossil-settings/ignore-glob
@@ -1,5 +1,6 @@
+tmpinstall
tests/fullrun/logs/*
tests/fullrun/lt
tests/fullrun/megatest.db
altdb.scm
utils/build/*
@@ -46,5 +47,8 @@
tests/fdktestqa/testqa/monitor.db
megatest-fossil-hash.scm
tests/release/runs/*
tests/release/links/*
tests/release/megatest.db
+tcmt
+mtut
+*.import.scm
Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -16,12 +16,12 @@
# along with Megatest. If not, see .
# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less
SHELL=/bin/bash
-PREFIX=$(PWD)
-CSCOPTS=
+PREFIX=$(PWD)/tmpinstall
+
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
ods.scm runconfig.scm server.scm \
db.scm keys.scm margs.scm megatest-version.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
@@ -31,10 +31,12 @@
rmt.scm api.scm subrun.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = ftail.scm
+# mtcommon.scm mtdb.scm mtconfigf.scm
+
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -43,25 +45,38 @@
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))
+MOFILES = $(MSRCFILES:%.scm=%.o)
-mofiles/%.o : %.scm
- mkdir -p mofiles
- csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+
+
+%.o : %.scm ../adat.scm $(MTEGGS)
+ csc $(CSCOPTS) -J -c $< -o $*.o
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}')
+MT_EGGS_BASE=$(PREFIX)/eggs
+MT_EGGS_DIR=$(MT_EGGS_BASE)/lib/chicken/7
+MTEGGS=$(MT_EGGS_DIR)/mtconfigf.so $(MT_EGGS_DIR)/mtdebug.so
+CHICKEN_REPOSITORY=$(MT_EGGS_DIR)
+export CHICKEN_REPOSITORY
+#CSCOPTS=-Wl,-rpath,$(MT_EGGS_DIR)
+
+
+# prefix commands with $(withenv) following as a means to collect env vars for compilation...
+withenv=CHICKEN_REPOSITORY=$(MT_EGGS_DIR)
+
ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif
+CKREPOSITORY=$(shell chicken-install -repository)
CSIPATH=$(shell which csi)
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
@@ -69,27 +84,42 @@
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
-all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
+all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut eggs
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MTEGGS)
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
showmtesthash:
@echo $(MTESTHASH)
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
-ndboard : newdashboard.scm $(OFILES) $(GOFILES)
- csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
+mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
-mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
- csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
+eggs: $(MTEGGS)
+# Needed only for adat.scm
+OPENSRC_DIR=../opensrc
+MTUTILS_DIR=$(OPENSRC_DIR)/mtutils
+../adat.scm : $(MTUTILS_DIR)/adat.scm
+ ln -sf $(PWD)/$< $@
+
+# # stuff for handling external files from opensrc package
+# mtcommon.scm : $(MTUTILS_DIR)/mtcommon/mtcommon.scm
+# ln -sf $< $@
+#
+# mtdb.scm : $(MTUTILS_DIR)/mtdb/mtdb.scm
+# ln -sf $< $@
+#
+# mtconfigf.scm : $(MTUTILS_DIR)/mtconfigf/mtconfigf.scm
+# ln -sf $< $@
+#
TCMTOBJS = \
api.o \
archive.o \
cgisetup/models/pgdb.o \
client.o \
@@ -113,12 +143,13 @@
runs.o \
server.o \
tasks.o \
tdb.o \
tests.o \
- subrun.o \
+ subrun.o
+# mtconfigf.o
tcmt : $(TCMTOBJS) tcmt.scm
csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
@@ -136,26 +167,49 @@
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
-#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
-# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard
+# setup the eggs dir in $PREFIX
+#
+$(MT_EGGS_DIR) :
+ mkdir -p $(MT_EGGS_DIR)
-#
-# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
-# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
+$(MT_EGGS_DIR)/types.db : $(MT_EGGS_DIR)
+ cp -rsf $(CKREPOSITORY)/ $(MT_EGGS_BASE)/lib/chicken/
+# chicken-install -init $(MT_EGGS_DIR)
+csi:
+ csi
+
+$(MT_EGGS_DIR)/mtargs.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtargs/mtargs.scm
+ cd $(MTUTILS_DIR)/mtargs && chicken-install -prefix $(MT_EGGS_BASE)
+
+
+$(MT_EGGS_DIR)/mtdebug.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtdebug/mtdebug.scm $(MT_EGGS_DIR)/mtargs.so
+ cd $(MTUTILS_DIR)/mtdebug && chicken-install -prefix $(MT_EGGS_BASE)
+
+
+$(MT_EGGS_DIR)/mtconfigf.so : $(MT_EGGS_DIR)/types.db $(MTUTILS_DIR)/mtconfigf/mtconfigf.scm $(MT_EGGS_DIR)/mtdebug.so
+ cd $(MTUTILS_DIR)/mtconfigf && chicken-install -prefix $(MT_EGGS_BASE)
+
+#
# Special dependencies for the includes
+#
+
+# anything that depends on the special MOFILES needs to be listed on the left here
+launch.o : $(MOFILES)
+# mtconfigf.o : $(MTUTILS_DIR)/mtconfigf/mtconfigf.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
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
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
megatest.o : megatest-fossil-hash.scm
-rmt.scm client.scm common.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
+rmt.scm client.scm common.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 $(MTEGGS)
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
@@ -164,11 +218,12 @@
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
-%.o : %.scm
+# TODO: make modules.scm changes trigger rebuild. modules.scm in following recipe does not work.
+%.o : %.scm modules.scm
csc $(CSCOPTS) -c $<
$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
@@ -266,10 +321,12 @@
make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
mtest-reaper: $(PREFIX)/bin/mtest-reaper
# install dashboard as dboard so wrapper script can be called dashboard
+# NOTE: Should be able to add something like -Wl,'$ORIGIN/../lib' to find IUP libs
+#
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
@@ -297,11 +354,14 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
+ rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest \
+ $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o \
+ megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o mtut.o \
+ *.import.scm mofiles/*.import.scm *.bak *~ *-original *-merge *-baseline
#======================================================================
# Make the records files
#======================================================================
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -18,15 +18,51 @@
TODO
====
. Dashboard should resist running from non-homehost
-
-
Migration to inmem db plus per run db
-------------------------------------
. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
+
+archive.scm:(declare (uses common))
+client.scm:(declare (uses common))
+dashboard-context-menu.scm:(declare (uses common))
+dashboard-guimonitor.scm:(declare (uses common))
+dashboard-tests.scm:(declare (uses common))
+dashboard.scm:(declare (uses common))
+db.scm:(declare (uses common))
+diff-report.scm:(declare (uses common))
+ezsteps.scm:(declare (uses common))
+fs-transport.scm:(declare (uses common))
+http-transport.scm:(declare (uses common))
+index-tree.scm:(declare (uses common))
+items.scm:(declare (uses common))
+keys.scm:(declare (uses common))
+launch.scm:(declare (uses common))
+lock-queue.scm:(declare (uses common))
+margs.scm:;; (declare (uses common))
+megatest.scm:(declare (uses common))
+mlaunch.scm:(declare (uses common))
+monitor.scm:(declare (uses common))
+mt.scm:(declare (uses common))
+mtut-dunno.scm:(declare (uses common))
+mtut.scm:(declare (uses common))
+newdashboard.scm:(declare (uses common))
+ods.scm:(declare (uses common))
+old-tcmt.scm:(declare (uses common))
+rpc-transport.scm:(declare (uses common))
+runconfig.scm:(declare (uses common))
+runs.scm:(declare (uses common))
+sauthorize.scm:;(declare (uses common))
+server.scm:(declare (uses common))
+sretrieve.scm:;(declare (uses common))
+subrun.scm:(declare (uses common))
+tasks.scm:(declare (uses common))
+tcmt.scm:(declare (uses common))
+tdb.scm:(declare (uses common))
+tests.scm:(declare (uses common))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -21,11 +21,11 @@
(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))
-
+;;;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;;
Index: cgisetup/models/pgdb.scm
==================================================================
--- cgisetup/models/pgdb.scm
+++ cgisetup/models/pgdb.scm
@@ -17,11 +17,11 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit pgdb))
-;; (declare (uses configf))
+;;(declare (uses mtconfigf))
(use (prefix mtconfigf configf:))
;; I don't know how to mix compilation units and modules, so no module here.
;;
;; (module pgdb
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -26,10 +26,54 @@
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
+
+(use posix-extras pathname-expand files)
+
+;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
+(let-values (( (chicken-release-number chicken-major-version)
+ (apply values
+ (map string->number
+ (take
+ (string-split (chicken-version) ".")
+ 2)))))
+ (let ((resolve-pathname-broken?
+ (or (> chicken-release-number 4)
+ (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
+ (if resolve-pathname-broken?
+ (define ##sys#expand-home-path pathname-expand))))
+
+(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+
+(define (common:get-this-exe-fullpath #!key (argv (argv)))
+ (let* ((this-script
+ (cond
+ ((and (> (length argv) 2)
+ (string-match "^(.*/csi|csi)$" (car argv))
+ (string-match "^-(s|ss|sx|script)$" (cadr argv)))
+ (caddr argv))
+ (else (car argv))))
+ (fullpath (realpath this-script)))
+ fullpath))
+(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*))
+
+(let* ((libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/7")))
+ (if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
+ (directory-exists? libpath))
+ (repository-path libpath)))
+
+
+
+;;(declare (uses mtconfigf))
+;; (use (prefix mtconfigf configf:))
+;;(configf:add-eval-string "(use common)")
+
+
(include "common_records.scm")
;; (require-library margs)
@@ -192,42 +236,10 @@
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
;; Miscellaneous
(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
-
-(use posix-extras pathname-expand files)
-
-;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
-(let-values (( (chicken-release-number chicken-major-version)
- (apply values
- (map string->number
- (take
- (string-split (chicken-version) ".")
- 2)))))
- (let ((resolve-pathname-broken?
- (or (> chicken-release-number 4)
- (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
- (if resolve-pathname-broken?
- (define ##sys#expand-home-path pathname-expand))))
-
-(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
-
-(define (common:get-this-exe-fullpath #!key (argv (argv)))
- (let* ((this-script
- (cond
- ((and (> (length argv) 2)
- (string-match "^(.*/csi|csi)$" (car argv))
- (string-match "^-(s|ss|sx|script)$" (cadr argv)))
- (caddr argv))
- (else (car argv))))
- (fullpath (realpath this-script)))
- fullpath))
-(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*))
-
@@ -260,14 +272,10 @@
;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than
;; five seconds ago
(define *pre-reqs-met-cache* (make-hash-table))
-;; cache of verbosity given string
-;;
-(define *verbosity-cache* (make-hash-table))
-
(define (common:clear-caches)
(set! *target* (make-hash-table))
(set! *keys* (make-hash-table))
(set! *keyvals* (make-hash-table))
(set! *toptest-paths* (make-hash-table))
@@ -903,11 +911,11 @@
#t))
;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
(hash-table-ref/default
- (or configf (read-config "megatest.config" #f #t))
+ (or configf (configf:read-config "megatest.config" #f #t))
"disks" '("none" "")))
;; return first command that exists, else #f
;;
(define (common:which cmds)
@@ -995,11 +1003,11 @@
;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t))))
;;
(define (common:get-runconfig-targets #!key (configf #f))
(let ((targs (sort (map car (hash-table->alist
(or configf ;; NOTE: There is no value in using runconfig:read here.
- (read-config (conc *toppath* "/runconfigs.config")
+ (configf:read-config (conc *toppath* "/runconfigs.config")
#f #t)
(make-hash-table))))
stringnumber (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")
- (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 (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))
@@ -212,40 +147,13 @@
(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: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -24,11 +24,11 @@
;;======================================================================
(use format fmt)
(require-library iup)
(import (prefix iup iup:))
-
+;; (use (prefix mtconfigf configf:))
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -23,11 +23,11 @@
;;======================================================================
(use format fmt)
(require-library iup)
(import (prefix iup iup:))
-
+;; (use (prefix mtconfigf configf:))
(use canvas-draw)
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -20,24 +20,25 @@
(use format)
(require-library iup)
(import (prefix iup iup:))
-
+;; (use (prefix mtconfigf configf:))
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
-(use (prefix mtconfigf configf:))
(declare (uses common))
-(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
-;; (declare (uses configf))
+
+;;(declare (uses mtconfigf))
+
+
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses dashboard-guimonitor))
@@ -1924,11 +1925,11 @@
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
- (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
+ (let* ((rawconfig (configf:read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(changed #f))
(iup:vbox
(iup:split
#:value 300
(iup:frame
Index: datashare.scm
==================================================================
--- datashare.scm
+++ datashare.scm
@@ -30,20 +30,20 @@
(require-library iup)
(import (prefix iup iup:))
(require-library ini-file)
(import (prefix ini-file ini:))
-
+;; (use (prefix mtconfigf configf:))
(use canvas-draw)
(import canvas-draw-iup)
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
-
-(declare (uses configf))
+(include "modules.scm")
+;;(declare (uses configf))
(declare (uses tree))
-(declare (uses margs))
+;;(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
@@ -716,11 +716,11 @@
(let* ((fname (conc exe-dir "/." exe-name ".config")))
(ini:property-separator-patt " * *")
(ini:property-separator #\space)
(if (common:file-exists? fname)
;; (ini:read-ini fname)
- (read-config fname #f #t)
+ (configf:read-config fname #f #t)
(make-hash-table))))
(define (datashare:process-action configdat action . args)
(case (string->symbol action)
((get)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -33,11 +33,11 @@
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
@@ -250,11 +250,12 @@
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
- (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
+ (exn () (debug:print 0 *default-log-port* "ERROR: (1) Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))
+ )
(condition-case
(begin
(debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
(let ((db (sqlite3:open-database fname)))
@@ -262,11 +263,11 @@
db))
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
- (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
+ (exn () (debug:print 0 *default-log-port* "ERROR: (2) Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -29,11 +29,11 @@
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -26,20 +26,20 @@
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (ezsteps:run-from testdat start-step-name run-one)
(let* ((test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
- (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
+ (testconfig (configf:read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
(rollup-status 0)
(exit-info (vector #t #t #t))
(test-id (db:test-get-id testdat))
Index: ftail.scm
==================================================================
--- ftail.scm
+++ ftail.scm
@@ -17,10 +17,11 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit ftail))
+
(module ftail
(
open-tail-db
tail-write
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -26,11 +26,11 @@
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(declare (unit http-transport))
-
+;; (use (prefix mtconfigf configf:))
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,11 +21,11 @@
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
@@ -117,11 +117,11 @@
#f)))
res)))
;; Nope, not now, return null as of 6/6/2011
(define (items:check-valid-items class item)
- (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
+ (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -24,11 +24,11 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit keys))
(declare (uses common))
-
+;; (use (prefix mtconfigf configf:))
(include "key_records.scm")
(include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -21,11 +21,11 @@
;;
;;======================================================================
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use typed-records pathname-expand matchable)
-(use (prefix mtconfigf configf:))
+;;;; (use (prefix mtconfigf configf:))
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
@@ -32,10 +32,13 @@
(declare (uses subrun))
(declare (uses common))
;; (declare (uses configf))
(declare (uses db))
+;;(declare (uses mtconfigf))
+;; (use (prefix mtconfigf configf:))
+
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
@@ -69,11 +72,11 @@
;; the comment can be set in the step record in launch.scm
;;
(define (launch:load-logpro-dat run-id test-id stepname)
(let ((cname (conc stepname ".dat")))
(if (common:file-exists? cname)
- (let* ((dat (read-config cname #f #f))
+ (let* ((dat (configf:read-config cname #f #f))
(csvr (db:logpro-dat->csv dat stepname))
(csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
(fmt-csv (map list->csv-record csvr))))
(status (configf:lookup dat "final" "exit-status"))
(msg (configf:lookup dat "final" "message")))
@@ -643,11 +646,11 @@
;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This
;; seems non-ideal but could well break stuff
;; BUG? BUG? BUG?
(let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))))
- (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
+ (wconfig (configf:read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists
;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target)
;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id))
;; Now have runconfigs data loaded, set environment vars
(for-each
(lambda (section)
@@ -957,19 +960,19 @@
;; we have all the info needed to fully process runconfigs and megatest.config
((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it?
mtcachef
rccachef) ;; BB- why are we doing this without asking if caching is desired?
;;(BB> "launch:setup-body -- cond branch 2")
- (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
+ (let* ((first-pass (configf:find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
toppath
(car first-pass))))
- (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
+ (configf:read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
(conc (if (string? toppath)
toppath
(get-environment-variable "MT_RUN_AREA_HOME"))
"/runconfigs.config")
*runconfigdat* #t
@@ -993,20 +996,20 @@
(key-vals (keys:target->keyval keys target))
(linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
; (if *configdat*
; (configf:lookup *configdat* "setup" "linktree")
; (conc *toppath* "/lt"))))
- (second-pass (find-and-read-config
+ (second-pass (configf:find-and-read-config
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals)
- (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
+ (configf:read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342
@@ -1031,19 +1034,19 @@
;; else read what you can and set the flag accordingly
;; here we don't have either mtconfig or rccachef
(else
;;(BB> "launch:setup-body -- cond branch 3 - else")
- (let* ((cfgdat (find-and-read-config
+ (let* ((cfgdat (configf:find-and-read-config
(or (args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME")))
(if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
(let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
- (rdat (read-config (conc toppath ;; convert this to use runconfig:read!
+ (rdat (configf:read-config (conc toppath ;; convert this to use runconfig:read!
"/runconfigs.config") *runconfigdat* #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
@@ -1113,11 +1116,11 @@
;; if have -append-config then read and append here
(let ((cfname (args:get-arg "-append-config")))
(if (and cfname
(file-read-access? cfname))
- (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
+ (configf:read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
*toppath*)))
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
@@ -1142,11 +1145,11 @@
(cons 1 (conc *toppath* "/runs"))
(loop (car tail) (cdr tail)))))))))))))) ;; the code creates the necessary directories if it does not exist and returns the path.
(define (launch:test-copy test-src-path test-path)
- (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
+ (let* ((ovrcmd (let ((cmd (configf:lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
(string-substitute "TEST_TARG_PATH" test-path
(string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t)
#f)))
@@ -1195,11 +1198,11 @@
(toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base))
(test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base))
;; ensure this exists first as links to subtests must be created there
(linktree (common:get-linktree))
- ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree")))
+ ;; WAS: (let ((rd (configf:lookup *configdat* "setup" "linktree")))
;; (if rd rd (conc *toppath* "/runs"))))
;; which seems wrong ...
(lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
@@ -1384,23 +1387,23 @@
;; for tconfig, why do we allow fallback to test-conf?
(tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t)
(begin
(debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
test-conf))) ;; force re-read now that all vars are set
- (useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell")))
+ (useshell (let ((ush (configf:lookup *configdat* "jobtools" "useshell")))
(if ush
(if (equal? ush "no") ;; must use "no" to NOT use shell
#f
ush)
#t))) ;; default is yes
- (runscript (config-lookup tconfig "setup" "runscript"))
+ (runscript (configf:lookup tconfig "setup" "runscript"))
(ezsteps (> (length (hash-table-ref/default tconfig "ezsteps" '())) 0)) ;; don't send all the steps, could be big, just send a flag
(subrun (> (length (hash-table-ref/default tconfig "subrun" '())) 0)) ;; send a flag to process a subrun
- ;; (diskspace (config-lookup tconfig "requirements" "diskspace"))
- ;; (memory (config-lookup tconfig "requirements" "memory"))
- ;; (hosts (config-lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
- (remote-megatest (config-lookup *configdat* "setup" "executable"))
+ ;; (diskspace (configf:lookup tconfig "requirements" "diskspace"))
+ ;; (memory (configf:lookup tconfig "requirements" "memory"))
+ ;; (hosts (configf:lookup *configdat* "jobtools" "workhosts")) ;; I'm pretty sure this was never completed
+ (remote-megatest (configf:lookup *configdat* "setup" "executable"))
(run-time-limit (or (configf:lookup tconfig "requirements" "runtimelim")
(configf:lookup *configdat* "setup" "runtimelim")))
;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to
;; allow running from dashboard. Extract the path
;; from the called megatest and convert dashboard
@@ -1412,11 +1415,11 @@
(case (string->symbol exe)
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
- (launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
+ (launcher (common:get-launcher *configdat* test-name item-path)) ;; (configf:lookup *configdat* "jobtools" "launcher"))
(test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
(work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -34,11 +34,10 @@
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
-(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
@@ -53,10 +52,12 @@
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)
+;;(declare (uses mtconfigf))
+
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -571,17 +572,17 @@
(process:children #f))
(original-exit exit-code)))))
;; for some switches always print the command to stderr
;;
-(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
+(if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required (list "-cleanup-db" "-server")))
- (if (apply args:any? homehost-required)
+ (if (apply args:any-defined? homehost-required)
(if (not (common:on-homehost?))
(for-each
(lambda (switch)
(if (args:get-arg switch)
(begin
@@ -594,11 +595,12 @@
;; Misc setup stuff
;;======================================================================
(debug:setup)
-(if (args:get-arg "-logging")(set! *logging* #t))
+(if (args:get-arg "-logging")
+ (debug:add-logging-callback db:log-event))
(if (debug:debug-mode 3) ;; we are obviously debugging
(set! open-run-close open-run-close-no-exception-handling))
(if (args:get-arg "-itempatt")
@@ -1888,11 +1890,16 @@
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
- (change-directory testpath)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: the work directory " testpath " has disappeared or become unreadable! Cannot proceed, exiting now.")
+ (exit 1))
+ (change-directory testpath))
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
ADDED modules.scm
Index: modules.scm
==================================================================
--- /dev/null
+++ modules.scm
@@ -0,0 +1,42 @@
+;;======================================================================
+;; Copyright 2006-2018, 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 .
+;;======================================================================
+
+(use (prefix mtargs args:))
+(use mtdebug)
+(use (prefix mtconfigf configf:))
+
+;; configure mtdebug ;; TODO: move to megatest.scm with other command line arg processing
+(if (args:get-arg "-v") (debug:set-verbose-mode))
+(if (args:get-arg "-q") (debug:set-quiet-mode))
+(if (args:get-arg "-debug") (debug:set-debug-mode))
+(if (args:get-arg "-color")
+ (case (string->symbol (args:get-arg "-color"))
+ ((y Y yes YES t T) (debug:force-color))
+ ((n N no NO f F) (debug:suppress-color))))
+
+;; configure mtconfigf
+(let* ((normal-fn debug:print)
+ (info-fn debug:print-info)
+ (error-fn debug:print-error)
+ (default-port *default-log-port*))
+ (set-debug-printers normal-fn info-fn error-fn default-port))
+
+(configf:add-eval-string "(use (prefix mtargs args:))
+ (use mtdebug)
+ (use (prefix mtconfigf configf:))")
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -28,11 +28,11 @@
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
@@ -276,11 +276,11 @@
(if (and (common:file-exists? tconfig-file)
(file-read-access? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
- (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
+ (let ((newtcfg (configf:read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -20,21 +20,24 @@
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
+(use srfi-1 posix srfi-69 readline
+ srfi-19 srfi-18 extras format
+ pkts regex regex-case
(prefix dbi dbi:)
- nanomsg
- (prefix mtconfigf configf:))
+ nanomsg)
(declare (uses common))
(declare (uses megatest-version))
-(declare (uses margs))
-;; (declare (uses configf))
+;;(declare (uses margs))
;; (declare (uses rmt))
+
+;; mtconfigf is compiled in as a compilation unit
+;;(declare (uses mtconfigf))
+;; (use (prefix mtconfigf configf:))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
@@ -472,11 +475,11 @@
(member *action* '("db" "tsend" "tlisten")) ;; very loose checks on db and tsend/listen
(equal? *action* "show") ;; just keep going if list
)))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
-(if (or (args:any? "-h" "help" "-help" "--help")
+(if (or (args:any-defined? "-h" "help" "-help" "--help")
(member *action* '("-h" "-help" "--help" "help")))
(begin
(print help)
(exit 1)))
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -28,12 +28,12 @@
(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(prefix dbi dbi:))
(declare (uses common))
(declare (uses megatest-version))
-(declare (uses margs))
-
+;;(declare (uses margs))
+;; (use (prefix mtconfigf configf:))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -22,11 +22,11 @@
(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))
(declare (unit portlogger))
(declare (uses db))
-
+;; (use (prefix mtconfigf configf:))
;; lsof -i
(define (portlogger:open-db fname)
(let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ rpc-transport.scm
@@ -27,11 +27,11 @@
(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
;; procstr is the name of the procedure to be called as a string
(define (rpc-transport:autoremote procstr params)
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -22,17 +22,17 @@
(use format directory-utils)
(declare (unit runconfig))
(declare (uses common))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(define (runconfig:read fname target environ-patt)
(let ((ht (make-hash-table)))
(if target (hash-table-set! ht target '()))
- (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
+ (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
;; NB// to process a runconfig ensure to use environ-patt with target!
;;
(define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t))
(let* ((keys (map car keyvals))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -29,11 +29,11 @@
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
@@ -247,11 +247,11 @@
);; obviously haven't had any work to do for a while
(else 0)))
(let* ((num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
- (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
+ (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
(runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
@@ -531,11 +531,11 @@
(debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry))
((hed-mode)
- (let ((m (config-lookup config "requirements" "mode")))
+ (let ((m (configf:lookup config "requirements" "mode")))
(if m (map string->symbol (string-split m)) '(normal))))
((hed-itemized-waiton) ;; are items in hed waiting on items of waiton?
(not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait)))))
)
(debug:print-info 8 *default-log-port* "waitons: " waitons)
@@ -552,11 +552,11 @@
(if (not (hash-table-ref/default test-records hed #f)) ;; waiton-tconfig below will be #f until that test is visted here at least once
(hash-table-set! test-records ;; BB: we are doing a manual make-tests:testqueue
hed (vector hed ;; 0 ;; testname
config ;; 1
waitons ;; 2
- (config-lookup config "requirements" "priority") ;; priority 3
+ (configf:lookup config "requirements" "priority") ;; priority 3
(tests:get-items config) ;; 4 ;; expand the [items] and or [itemstable] into explict items
#f ;; itemsdat 5
#f ;; spare - used for item-path
waitors ;;
)))
@@ -1320,11 +1320,11 @@
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
- (max-retries (config-lookup *configdat* "setup" "maxretries"))
+ (max-retries (configf:lookup *configdat* "setup" "maxretries"))
(max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50))
(reglen (if (number? reglen-in) reglen-in 1))
(last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle
(last-time-some-running (current-seconds))
;; (tdbdat (tasks:open-db))
@@ -1392,12 +1392,12 @@
;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
(let* ((test-record (hash-table-ref test-records hed))
(test-name (tests:testqueue-get-testname test-record))
(tconfig (tests:testqueue-get-testconfig test-record))
- (jobgroup (config-lookup tconfig "test_meta" "jobgroup"))
- (testmode (let ((m (config-lookup tconfig "requirements" "mode")))
+ (jobgroup (configf:lookup tconfig "test_meta" "jobgroup"))
+ (testmode (let ((m (configf:lookup tconfig "requirements" "mode")))
(if m (map string->symbol (string-split m)) '(normal))))
(itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap"))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
@@ -2395,11 +2395,11 @@
(set! keys (keys:config-get-fields *configdat*))
;; have enough to process -target or -reqtarg here
(if (args:get-arg "-reqtarg")
(let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL
- (runconfig (read-config runconfigf #f #t environ-patt: #f)))
+ (runconfig (configf:read-config runconfigf #f #t environ-patt: #f)))
(if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
(keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
(begin
(debug:print-error 0 *default-log-port* "[" (args:get-arg "-reqtarg") "] not found in " runconfigf)
@@ -2451,11 +2451,11 @@
(rmt:testmeta-add-record test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
- (val (config-lookup test-conf "test_meta" fld)))
+ (val (configf:lookup test-conf "test_meta" fld)))
;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ sauthorize.scm
@@ -25,11 +25,12 @@
(use refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
-(declare (uses margs))
+(require "modules.scm")
+;;(declare (uses margs))
(declare (uses megatest-version))
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -32,11 +32,11 @@
;; (declare (uses synchash))
(declare (uses http-transport))
;;(declare (uses rpc-transport))
(declare (uses launch))
;; (declare (uses daemon))
-
+;; (use (prefix mtconfigf configf:))
(include "common_records.scm")
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
Index: sharedat.scm
==================================================================
--- sharedat.scm
+++ sharedat.scm
@@ -28,20 +28,21 @@
;; (use posix)
;; (use json)
;; (use csv)
(use srfi-18)
(use format)
-
+(require "modules.scm")
+;;;; (use (prefix mtconfigf configf:))
(require-library ini-file)
(import (prefix ini-file ini:))
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;;
-(declare (uses configf))
+;; (declare (uses configf))
;; (declare (uses tree))
-(declare (uses margs))
+;; (declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
@@ -342,11 +343,11 @@
(let* ((fname (conc exe-dir "/." exe-name ".config")))
(ini:property-separator-patt " * *")
(ini:property-separator #\space)
(if (file-exists? fname)
;; (ini:read-ini fname)
- (read-config fname #f #t)
+ (configf:read-config fname #f #t)
(make-hash-table))))
(define (spublish:process-action configdat action . args)
(let* ((target-dir (configf:lookup configdat "settings" "target-dir"))
(user (current-user-name))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -21,15 +21,15 @@
(use refdb)
(use srfi-18)
(use srfi-19)
(use format)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
-
+;;;; (use (prefix mtconfigf configf:))
;(declare (uses configf))
;; (declare (uses tree))
-(declare (uses margs))
-
+;;(declare (uses margs))
+(require "modules.scm")
(declare (uses megatest-version))
;; (declare (uses tbd))
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -23,14 +23,14 @@
(use srfi-19)
(use refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
-(declare (uses margs))
+;;(declare (uses margs))
(declare (uses megatest-version))
-
-
+;;;; (use (prefix mtconfigf configf:))
+(include "modules.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
@@ -505,11 +505,11 @@
value))
(define (sretrieve:load-shell-config fname)
(if (file-exists? fname)
- (read-config fname #f #f)
+ (configf:read-config fname #f #f)
))
(define (is_directory target-path)
(let* ((retval #f))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -23,10 +23,11 @@
call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
+;; (use (prefix mtconfigf configf:))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;(declare (uses server))
(declare (uses mt))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -18,11 +18,11 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
-
+;; (use (prefix mtconfigf configf:))
(declare (unit tasks))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -25,12 +25,11 @@
(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
(use trace)
;; (trace-call-sites #t)
-
-(declare (uses margs))
+;;(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))
(include "megatest-fossil-hash.scm")
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -23,11 +23,11 @@
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
-
+;; (use (prefix mtconfigf configf:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
@@ -166,16 +166,16 @@
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
(let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) ;; assuming no problems with immediate evaluation, this could be simplified ('return-procs -> #t)
(let ((instr (if config
- (config-lookup config "requirements" "waiton")
+ (configf:lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
(instr2 (if config
- (config-lookup config "requirements" "waitor")
+ (configf:lookup config "requirements" "waitor")
"")))
(debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2)
(let ((newwaitons
(string-split (cond
((procedure? instr) ;; here
@@ -1549,11 +1549,11 @@
(test-path (or (hash-table-ref/default treg test-name #f)
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (and (common:file-exists? test-configf)(file-read-access? test-configf)))
(tcfg (if testexists
- (read-config test-configf #f system-allowed
+ (configf:read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
@@ -1593,12 +1593,12 @@
(b-record (hash-table-ref test-records b))
(a-waitons (or (tests:testqueue-get-waitons a-record) '()))
(b-waitons (or (tests:testqueue-get-waitons b-record) '()))
(a-config (tests:testqueue-get-testconfig a-record))
(b-config (tests:testqueue-get-testconfig b-record))
- (a-raw-pri (config-lookup a-config "requirements" "priority"))
- (b-raw-pri (config-lookup b-config "requirements" "priority"))
+ (a-raw-pri (configf:lookup a-config "requirements" "priority"))
+ (b-raw-pri (configf:lookup b-config "requirements" "priority"))
(a-priority (mungepriority a-raw-pri))
(b-priority (mungepriority b-raw-pri)))
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
@@ -1788,11 +1788,11 @@
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
;; don't know item-path at this time, let the testconfig get the top level testconfig
(let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs))
(waitons (let ((instr (if config
- (config-lookup config "requirements" "waiton")
+ (configf:lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
(debug:print-info 8 *default-log-port* "waitons string is " instr)
(string-split (cond
@@ -1821,11 +1821,11 @@
(if (not (hash-table-ref/default test-records hed #f))
(hash-table-set! test-records
hed (vector hed ;; 0
config ;; 1
waitons ;; 2
- (config-lookup config "requirements" "priority") ;; priority 3
+ (configf:lookup config "requirements" "priority") ;; priority 3
(let ((items (hash-table-ref/default config "items" #f)) ;; items 4
(itemstable (hash-table-ref/default config "itemstable" #f)))
;; if either items or items table is a proc return it so test running
;; process can know to call items:get-items-from-config
;; if either is a list and none is a proc go ahead and call get-items
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -25,11 +25,10 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit tree))
-(declare (uses margs))
(declare (uses launch))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses server))
Index: utils/mk_wrapper
==================================================================
--- utils/mk_wrapper
+++ utils/mk_wrapper
@@ -23,11 +23,11 @@
cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh"
if [ "$LD_LIBRARY_PATH" != "" ];then
echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2
( cat << __EOF
-if [ "\$LD_LIBRARY_PATH" != "" ];then
+if [[ -z \$LD_LIBRARY_PATH ]];then
export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH
else
export LD_LIBRARY_PATH=$LD_LIBRARY_PATH
fi
__EOF