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,25 +16,27 @@ # 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 \ + db.scm keys.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm subrun.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = 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,53 +45,83 @@ 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 +CHICKEN_NUMBER = $(shell csi -e '(print (car (reverse (string-split (repository-path) "/"))))') + +%.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/$(CHICKEN_NUMBER) +MTEGGS=$(MT_EGGS_DIR)/mtconfigf.so $(MT_EGGS_DIR)/mtdebug.so $(MT_EGGS_DIR)/mtargs.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) ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) + +$(MOFILES): $(MTEGGS) $(MT_EGGS_DIR)/types.db #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 \ @@ -99,11 +131,10 @@ http-transport.o \ items.o \ keys.o \ launch.o \ lock-queue.o \ - margs.o \ mt.o \ megatest-version.o \ ods.o \ portlogger.o \ process.o \ @@ -113,12 +144,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,39 +168,63 @@ $(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 -common_records.scm : altdb.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) $(MT_EGGS_DIR)/types.db +common_records.scm : altdb.scm modules.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 megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm 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 +$(OFILES) $(GOFILES) : common_records.scm modules.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 +322,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 +355,15 @@ $(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 \ + rm -rf $(PREFIX)/* #====================================================================== # Make the records files #====================================================================== @@ -342,31 +404,31 @@ csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard # DATASHAREO=common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ # megatest-version.o tdb.o ods.o mt.o keys.o -datashare-testing/sd : datashare.scm $(OFILES) +datashare-testing/sd : datashare.scm $(OFILES) modules.scm csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd -datashare-testing/sdat: sharedat.scm $(OFILES) +datashare-testing/sdat: sharedat.scm $(OFILES) modules.scm 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) - csc $(CSCOPTS) spublish.scm megatest-version.o margs.o process.o common.o -o datashare-testing/spublish +datashare-testing/spublish : spublish.scm $(OFILES) modules.scm + csc $(CSCOPTS) spublish.scm megatest-version.o process.o common.o -o datashare-testing/spublish -datashare-testing/sretrieve : sretrieve.scm $(OFILES) - csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sretrieve +datashare-testing/sretrieve : sretrieve.scm $(OFILES) modules.scm + csc $(CSCOPTS) sretrieve.scm megatest-version.o process.o common.o -o datashare-testing/sretrieve -datashare-testing/sauthorize : sauthorize.scm $(OFILES) - csc $(CSCOPTS) sauthorize.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sauthorize +datashare-testing/sauthorize : sauthorize.scm $(OFILES) modules.scm + csc $(CSCOPTS) sauthorize.scm megatest-version.o process.o common.o -o datashare-testing/sauthorize sauth-init: mkdir -p datashare-testing rm datashare-testing/sauthorize rm datashare-testing/sretrieve @@ -396,12 +458,12 @@ fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf 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 @@ -24,12 +24,57 @@ matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) - +(declare (uses process)) (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-number (car (reverse (string-split (repository-path) "/")))) + (libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/" libpath-number))) + (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) @@ -125,11 +170,11 @@ (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing -(define *default-log-port* (current-error-port)) +;;(define *default-log-port* (current-error-port)) moved to modules.scm (define *time-zero* (current-seconds)) ;; for the watchdog (define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. @@ -192,42 +237,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 +273,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 +912,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 +1004,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) @@ -655,11 +658,11 @@ (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin - (safe-setenv var (config:eval-string-in-environment val))) ;; val) + (safe-setenv var (configf:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") @@ -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,43 @@ +;;====================================================================== +;; 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-verbosity (args:get-arg "-debug"))) +(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 +(define *default-log-port* (current-error-port)) +(let* ((normal-fn debug:print) + (info-fn debug:print-info) + (error-fn debug:print-error) + (default-port *default-log-port*)) + (configf:set-debug-printers normal-fn info-fn error-fn default-port)) + +(configf:add-eval-string "(import (prefix mtargs args:)) + (import mtdebug) + (import (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,13 +22,13 @@ (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 - +(include "modules.scm") (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 (exists (common:file-exists? fname)) (db (if avail 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)) @@ -29,11 +29,11 @@ ;; (import pgdb) ;; pgdb is a module (include "task_records.scm") (include "db_records.scm") - +(include "modules.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away 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